*> \brief \b DASUM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION DX(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DASUM takes the sum of the absolute values.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] DX
*> \verbatim
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of DX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup asum
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 3/93 to return if incx .le. 0.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
DOUBLE PRECISION FUNCTION DASUM(N,DX,INCX)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INCX,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION DTEMP
INTEGER I,M,MP1,NINCX
* ..
* .. Intrinsic Functions ..
INTRINSIC DABS,MOD
* ..
DASUM = 0.0d0
DTEMP = 0.0d0
IF (N.LE.0 .OR. INCX.LE.0) RETURN
IF (INCX.EQ.1) THEN
* code for increment equal to 1
*
*
* clean-up loop
*
M = MOD(N,6)
IF (M.NE.0) THEN
DO I = 1,M
DTEMP = DTEMP + DABS(DX(I))
END DO
IF (N.LT.6) THEN
DASUM = DTEMP
RETURN
END IF
END IF
MP1 = M + 1
DO I = MP1,N,6
DTEMP = DTEMP + DABS(DX(I)) + DABS(DX(I+1)) +
$ DABS(DX(I+2)) + DABS(DX(I+3)) +
$ DABS(DX(I+4)) + DABS(DX(I+5))
END DO
ELSE
*
* code for increment not equal to 1
*
NINCX = N*INCX
DO I = 1,NINCX,INCX
DTEMP = DTEMP + DABS(DX(I))
END DO
END IF
DASUM = DTEMP
RETURN
*
* End of DASUM
*
END
*> \brief \b DAXPY
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION DA
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION DX(*),DY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DAXPY constant times a vector plus a vector.
*> uses unrolled loops for increments equal to one.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] DA
*> \verbatim
*> DA is DOUBLE PRECISION
*> On entry, DA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] DX
*> \verbatim
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of DX
*> \endverbatim
*>
*> \param[in,out] DY
*> \verbatim
*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of DY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup axpy
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DAXPY(N,DA,DX,INCX,DY,INCY)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
DOUBLE PRECISION DA
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*),DY(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I,IX,IY,M,MP1
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
IF (N.LE.0) RETURN
IF (DA.EQ.0.0d0) RETURN
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
*
* code for both increments equal to 1
*
*
* clean-up loop
*
M = MOD(N,4)
IF (M.NE.0) THEN
DO I = 1,M
DY(I) = DY(I) + DA*DX(I)
END DO
END IF
IF (N.LT.4) RETURN
MP1 = M + 1
DO I = MP1,N,4
DY(I) = DY(I) + DA*DX(I)
DY(I+1) = DY(I+1) + DA*DX(I+1)
DY(I+2) = DY(I+2) + DA*DX(I+2)
DY(I+3) = DY(I+3) + DA*DX(I+3)
END DO
ELSE
*
* code for unequal increments or equal increments
* not equal to 1
*
IX = 1
IY = 1
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
DO I = 1,N
DY(IY) = DY(IY) + DA*DX(IX)
IX = IX + INCX
IY = IY + INCY
END DO
END IF
RETURN
*
* End of DAXPY
*
END
*> \brief \b DCOPY
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DCOPY(N,DX,INCX,DY,INCY)
*
* .. Scalar Arguments ..
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION DX(*),DY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DCOPY copies a vector, x, to a vector, y.
*> uses unrolled loops for increments equal to 1.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] DX
*> \verbatim
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of DX
*> \endverbatim
*>
*> \param[out] DY
*> \verbatim
*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of DY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup copy
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DCOPY(N,DX,INCX,DY,INCY)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*),DY(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I,IX,IY,M,MP1
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
IF (N.LE.0) RETURN
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
*
* code for both increments equal to 1
*
*
* clean-up loop
*
M = MOD(N,7)
IF (M.NE.0) THEN
DO I = 1,M
DY(I) = DX(I)
END DO
IF (N.LT.7) RETURN
END IF
MP1 = M + 1
DO I = MP1,N,7
DY(I) = DX(I)
DY(I+1) = DX(I+1)
DY(I+2) = DX(I+2)
DY(I+3) = DX(I+3)
DY(I+4) = DX(I+4)
DY(I+5) = DX(I+5)
DY(I+6) = DX(I+6)
END DO
ELSE
*
* code for unequal increments or equal increments
* not equal to 1
*
IX = 1
IY = 1
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
DO I = 1,N
DY(IY) = DX(IX)
IX = IX + INCX
IY = IY + INCY
END DO
END IF
RETURN
*
* End of DCOPY
*
END
*> \brief \b DDOT
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
*
* .. Scalar Arguments ..
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION DX(*),DY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DDOT forms the dot product of two vectors.
*> uses unrolled loops for increments equal to one.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] DX
*> \verbatim
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of DX
*> \endverbatim
*>
*> \param[in] DY
*> \verbatim
*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of DY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup dot
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
DOUBLE PRECISION FUNCTION DDOT(N,DX,INCX,DY,INCY)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*),DY(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION DTEMP
INTEGER I,IX,IY,M,MP1
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
DDOT = 0.0d0
DTEMP = 0.0d0
IF (N.LE.0) RETURN
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
*
* code for both increments equal to 1
*
*
* clean-up loop
*
M = MOD(N,5)
IF (M.NE.0) THEN
DO I = 1,M
DTEMP = DTEMP + DX(I)*DY(I)
END DO
IF (N.LT.5) THEN
DDOT=DTEMP
RETURN
END IF
END IF
MP1 = M + 1
DO I = MP1,N,5
DTEMP = DTEMP + DX(I)*DY(I) + DX(I+1)*DY(I+1) +
$ DX(I+2)*DY(I+2) + DX(I+3)*DY(I+3) + DX(I+4)*DY(I+4)
END DO
ELSE
*
* code for unequal increments or equal increments
* not equal to 1
*
IX = 1
IY = 1
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
DO I = 1,N
DTEMP = DTEMP + DX(IX)*DY(IY)
IX = IX + INCX
IY = IY + INCY
END DO
END IF
DDOT = DTEMP
RETURN
*
* End of DDOT
*
END
*> \brief \b DGECON
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DGECON + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK,
* INFO )
*
* .. Scalar Arguments ..
* CHARACTER NORM
* INTEGER INFO, LDA, N
* DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
* DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGECON estimates the reciprocal of the condition number of a general
*> real matrix A, in either the 1-norm or the infinity-norm, using
*> the LU factorization computed by DGETRF.
*>
*> An estimate is obtained for norm(inv(A)), and the reciprocal of the
*> condition number is computed as
*> RCOND = 1 / ( norm(A) * norm(inv(A)) ).
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] NORM
*> \verbatim
*> NORM is CHARACTER*1
*> Specifies whether the 1-norm condition number or the
*> infinity-norm condition number is required:
*> = '1' or 'O': 1-norm;
*> = 'I': Infinity-norm.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> The factors L and U from the factorization A = P*L*U
*> as computed by DGETRF.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] ANORM
*> \verbatim
*> ANORM is DOUBLE PRECISION
*> If NORM = '1' or 'O', the 1-norm of the original matrix A.
*> If NORM = 'I', the infinity-norm of the original matrix A.
*> \endverbatim
*>
*> \param[out] RCOND
*> \verbatim
*> RCOND is DOUBLE PRECISION
*> The reciprocal of the condition number of the matrix A,
*> computed as RCOND = 1/(norm(A) * norm(inv(A))).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (4*N)
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value.
*> NaNs are illegal values for ANORM, and they propagate to
*> the output parameter RCOND.
*> Infinity is illegal for ANORM, and it propagates to the output
*> parameter RCOND as 0.
*> = 1: if RCOND = NaN, or
*> RCOND = Inf, or
*> the computed norm of the inverse of A is 0.
*> In the latter, RCOND = 0 is returned.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gecon
*
* =====================================================================
SUBROUTINE DGECON( NORM, N, A, LDA, ANORM, RCOND, WORK, IWORK,
$ INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER INFO, LDA, N
DOUBLE PRECISION ANORM, RCOND
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL ONENRM
CHARACTER NORMIN
INTEGER IX, KASE, KASE1
DOUBLE PRECISION AINVNM, SCALE, SL, SMLNUM, SU, HUGEVAL
* ..
* .. Local Arrays ..
INTEGER ISAVE( 3 )
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL LSAME, IDAMAX, DLAMCH, DISNAN
* ..
* .. External Subroutines ..
EXTERNAL DLACN2, DLATRS, DRSCL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
HUGEVAL = DLAMCH( 'Overflow' )
*
* Test the input parameters.
*
INFO = 0
ONENRM = NORM.EQ.'1' .OR. LSAME( NORM, 'O' )
IF( .NOT.ONENRM .AND. .NOT.LSAME( NORM, 'I' ) ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -4
ELSE IF( ANORM.LT.ZERO ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGECON', -INFO )
RETURN
END IF
*
* Quick return if possible
*
RCOND = ZERO
IF( N.EQ.0 ) THEN
RCOND = ONE
RETURN
ELSE IF( ANORM.EQ.ZERO ) THEN
RETURN
ELSE IF( DISNAN( ANORM ) ) THEN
RCOND = ANORM
INFO = -5
RETURN
ELSE IF( ANORM.GT.HUGEVAL ) THEN
INFO = -5
RETURN
END IF
*
SMLNUM = DLAMCH( 'Safe minimum' )
*
* Estimate the norm of inv(A).
*
AINVNM = ZERO
NORMIN = 'N'
IF( ONENRM ) THEN
KASE1 = 1
ELSE
KASE1 = 2
END IF
KASE = 0
10 CONTINUE
CALL DLACN2( N, WORK( N+1 ), WORK, IWORK, AINVNM, KASE, ISAVE )
IF( KASE.NE.0 ) THEN
IF( KASE.EQ.KASE1 ) THEN
*
* Multiply by inv(L).
*
CALL DLATRS( 'Lower', 'No transpose', 'Unit', NORMIN, N,
$ A,
$ LDA, WORK, SL, WORK( 2*N+1 ), INFO )
*
* Multiply by inv(U).
*
CALL DLATRS( 'Upper', 'No transpose', 'Non-unit', NORMIN,
$ N,
$ A, LDA, WORK, SU, WORK( 3*N+1 ), INFO )
ELSE
*
* Multiply by inv(U**T).
*
CALL DLATRS( 'Upper', 'Transpose', 'Non-unit', NORMIN, N,
$ A,
$ LDA, WORK, SU, WORK( 3*N+1 ), INFO )
*
* Multiply by inv(L**T).
*
CALL DLATRS( 'Lower', 'Transpose', 'Unit', NORMIN, N, A,
$ LDA, WORK, SL, WORK( 2*N+1 ), INFO )
END IF
*
* Divide X by 1/(SL*SU) if doing so will not cause overflow.
*
SCALE = SL*SU
NORMIN = 'Y'
IF( SCALE.NE.ONE ) THEN
IX = IDAMAX( N, WORK, 1 )
IF( SCALE.LT.ABS( WORK( IX ) )*SMLNUM .OR. SCALE.EQ.ZERO )
$ GO TO 20
CALL DRSCL( N, SCALE, WORK, 1 )
END IF
GO TO 10
END IF
*
* Compute the estimate of the reciprocal condition number.
*
IF( AINVNM.NE.ZERO ) THEN
RCOND = ( ONE / AINVNM ) / ANORM
ELSE
INFO = 1
RETURN
END IF
*
* Check for NaNs and Infs
*
IF( DISNAN( RCOND ) .OR. RCOND.GT.HUGEVAL )
$ INFO = 1
*
20 CONTINUE
RETURN
*
* End of DGECON
*
END
*> \brief \b DGEMM
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,BETA,C,LDC)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION ALPHA,BETA
* INTEGER K,LDA,LDB,LDC,M,N
* CHARACTER TRANSA,TRANSB
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGEMM performs one of the matrix-matrix operations
*>
*> C := alpha*op( A )*op( B ) + beta*C,
*>
*> where op( X ) is one of
*>
*> op( X ) = X or op( X ) = X**T,
*>
*> alpha and beta are scalars, and A, B and C are matrices, with op( A )
*> an m by k matrix, op( B ) a k by n matrix and C an m by n matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANSA
*> \verbatim
*> TRANSA is CHARACTER*1
*> On entry, TRANSA specifies the form of op( A ) to be used in
*> the matrix multiplication as follows:
*>
*> TRANSA = 'N' or 'n', op( A ) = A.
*>
*> TRANSA = 'T' or 't', op( A ) = A**T.
*>
*> TRANSA = 'C' or 'c', op( A ) = A**T.
*> \endverbatim
*>
*> \param[in] TRANSB
*> \verbatim
*> TRANSB is CHARACTER*1
*> On entry, TRANSB specifies the form of op( B ) to be used in
*> the matrix multiplication as follows:
*>
*> TRANSB = 'N' or 'n', op( B ) = B.
*>
*> TRANSB = 'T' or 't', op( B ) = B**T.
*>
*> TRANSB = 'C' or 'c', op( B ) = B**T.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of the matrix
*> op( A ) and of the matrix C. M must be at least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of the matrix
*> op( B ) and the number of columns of the matrix C. N must be
*> at least zero.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> On entry, K specifies the number of columns of the matrix
*> op( A ) and the number of rows of the matrix op( B ). K must
*> be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is DOUBLE PRECISION.
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension ( LDA, ka ), where ka is
*> k when TRANSA = 'N' or 'n', and is m otherwise.
*> Before entry with TRANSA = 'N' or 'n', the leading m by k
*> part of the array A must contain the matrix A, otherwise
*> the leading k by m part of the array A must contain the
*> matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. When TRANSA = 'N' or 'n' then
*> LDA must be at least max( 1, m ), otherwise LDA must be at
*> least max( 1, k ).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension ( LDB, kb ), where kb is
*> n when TRANSB = 'N' or 'n', and is k otherwise.
*> Before entry with TRANSB = 'N' or 'n', the leading k by n
*> part of the array B must contain the matrix B, otherwise
*> the leading n by k part of the array B must contain the
*> matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> On entry, LDB specifies the first dimension of B as declared
*> in the calling (sub) program. When TRANSB = 'N' or 'n' then
*> LDB must be at least max( 1, k ), otherwise LDB must be at
*> least max( 1, n ).
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is DOUBLE PRECISION.
*> On entry, BETA specifies the scalar beta. When BETA is
*> supplied as zero then C need not be set on input.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension ( LDC, N )
*> Before entry, the leading m by n part of the array C must
*> contain the matrix C, except when beta is zero, in which
*> case C need not be set on entry.
*> On exit, the array C is overwritten by the m by n matrix
*> ( alpha*op( A )*op( B ) + beta*C ).
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> On entry, LDC specifies the first dimension of C as declared
*> in the calling (sub) program. LDC must be at least
*> max( 1, m ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gemm
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 3 Blas routine.
*>
*> -- Written on 8-February-1989.
*> Jack Dongarra, Argonne National Laboratory.
*> Iain Duff, AERE Harwell.
*> Jeremy Du Croz, Numerical Algorithms Group Ltd.
*> Sven Hammarling, Numerical Algorithms Group Ltd.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DGEMM(TRANSA,TRANSB,M,N,K,ALPHA,A,LDA,B,LDB,
+ BETA,C,LDC)
*
* -- Reference BLAS level3 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA,BETA
INTEGER K,LDA,LDB,LDC,M,N
CHARACTER TRANSA,TRANSB
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),B(LDB,*),C(LDC,*)
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP
INTEGER I,INFO,J,L,NROWA,NROWB
LOGICAL NOTA,NOTB
* ..
* .. Parameters ..
DOUBLE PRECISION ONE,ZERO
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
* ..
*
* Set NOTA and NOTB as true if A and B respectively are not
* transposed and set NROWA and NROWB as the number of rows of A
* and B respectively.
*
NOTA = LSAME(TRANSA,'N')
NOTB = LSAME(TRANSB,'N')
IF (NOTA) THEN
NROWA = M
ELSE
NROWA = K
END IF
IF (NOTB) THEN
NROWB = K
ELSE
NROWB = N
END IF
*
* Test the input parameters.
*
INFO = 0
IF ((.NOT.NOTA) .AND. (.NOT.LSAME(TRANSA,'C')) .AND.
+ (.NOT.LSAME(TRANSA,'T'))) THEN
INFO = 1
ELSE IF ((.NOT.NOTB) .AND. (.NOT.LSAME(TRANSB,'C')) .AND.
+ (.NOT.LSAME(TRANSB,'T'))) THEN
INFO = 2
ELSE IF (M.LT.0) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (K.LT.0) THEN
INFO = 5
ELSE IF (LDA.LT.MAX(1,NROWA)) THEN
INFO = 8
ELSE IF (LDB.LT.MAX(1,NROWB)) THEN
INFO = 10
ELSE IF (LDC.LT.MAX(1,M)) THEN
INFO = 13
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DGEMM ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
+ (((ALPHA.EQ.ZERO).OR. (K.EQ.0)).AND. (BETA.EQ.ONE))) RETURN
*
* And if alpha.eq.zero.
*
IF (ALPHA.EQ.ZERO) THEN
IF (BETA.EQ.ZERO) THEN
DO 20 J = 1,N
DO 10 I = 1,M
C(I,J) = ZERO
10 CONTINUE
20 CONTINUE
ELSE
DO 40 J = 1,N
DO 30 I = 1,M
C(I,J) = BETA*C(I,J)
30 CONTINUE
40 CONTINUE
END IF
RETURN
END IF
*
* Start the operations.
*
IF (NOTB) THEN
IF (NOTA) THEN
*
* Form C := alpha*A*B + beta*C.
*
DO 90 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 50 I = 1,M
C(I,J) = ZERO
50 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 60 I = 1,M
C(I,J) = BETA*C(I,J)
60 CONTINUE
END IF
DO 80 L = 1,K
TEMP = ALPHA*B(L,J)
DO 70 I = 1,M
C(I,J) = C(I,J) + TEMP*A(I,L)
70 CONTINUE
80 CONTINUE
90 CONTINUE
ELSE
*
* Form C := alpha*A**T*B + beta*C
*
DO 120 J = 1,N
DO 110 I = 1,M
TEMP = ZERO
DO 100 L = 1,K
TEMP = TEMP + A(L,I)*B(L,J)
100 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
110 CONTINUE
120 CONTINUE
END IF
ELSE
IF (NOTA) THEN
*
* Form C := alpha*A*B**T + beta*C
*
DO 170 J = 1,N
IF (BETA.EQ.ZERO) THEN
DO 130 I = 1,M
C(I,J) = ZERO
130 CONTINUE
ELSE IF (BETA.NE.ONE) THEN
DO 140 I = 1,M
C(I,J) = BETA*C(I,J)
140 CONTINUE
END IF
DO 160 L = 1,K
TEMP = ALPHA*B(J,L)
DO 150 I = 1,M
C(I,J) = C(I,J) + TEMP*A(I,L)
150 CONTINUE
160 CONTINUE
170 CONTINUE
ELSE
*
* Form C := alpha*A**T*B**T + beta*C
*
DO 200 J = 1,N
DO 190 I = 1,M
TEMP = ZERO
DO 180 L = 1,K
TEMP = TEMP + A(L,I)*B(J,L)
180 CONTINUE
IF (BETA.EQ.ZERO) THEN
C(I,J) = ALPHA*TEMP
ELSE
C(I,J) = ALPHA*TEMP + BETA*C(I,J)
END IF
190 CONTINUE
200 CONTINUE
END IF
END IF
*
RETURN
*
* End of DGEMM
*
END
*> \brief \b DGEMV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION ALPHA,BETA
* INTEGER INCX,INCY,LDA,M,N
* CHARACTER TRANS
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGEMV performs one of the matrix-vector operations
*>
*> y := alpha*A*x + beta*y, or y := alpha*A**T*x + beta*y,
*>
*> where alpha and beta are scalars, x and y are vectors and A is an
*> m by n matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the operation to be performed as
*> follows:
*>
*> TRANS = 'N' or 'n' y := alpha*A*x + beta*y.
*>
*> TRANS = 'T' or 't' y := alpha*A**T*x + beta*y.
*>
*> TRANS = 'C' or 'c' y := alpha*A**T*x + beta*y.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of the matrix A.
*> M must be at least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is DOUBLE PRECISION.
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension ( LDA, N )
*> Before entry, the leading m by n part of the array A must
*> contain the matrix of coefficients.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> max( 1, m ).
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is DOUBLE PRECISION array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ) when TRANS = 'N' or 'n'
*> and at least
*> ( 1 + ( m - 1 )*abs( INCX ) ) otherwise.
*> Before entry, the incremented array X must contain the
*> vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is DOUBLE PRECISION.
*> On entry, BETA specifies the scalar beta. When BETA is
*> supplied as zero then Y need not be set on input.
*> \endverbatim
*>
*> \param[in,out] Y
*> \verbatim
*> Y is DOUBLE PRECISION array, dimension at least
*> ( 1 + ( m - 1 )*abs( INCY ) ) when TRANS = 'N' or 'n'
*> and at least
*> ( 1 + ( n - 1 )*abs( INCY ) ) otherwise.
*> Before entry with BETA non-zero, the incremented array Y
*> must contain the vector y. On exit, Y is overwritten by the
*> updated vector y.
*> If either m or n is zero, then Y not referenced and the function
*> performs a quick return.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> Y. INCY must not be zero.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gemv
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*> The vector and matrix arguments are not referenced when N = 0, or M = 0
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DGEMV(TRANS,M,N,ALPHA,A,LDA,X,INCX,BETA,Y,INCY)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA,BETA
INTEGER INCX,INCY,LDA,M,N
CHARACTER TRANS
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE,ZERO
PARAMETER (ONE=1.0D+0,ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP
INTEGER I,INFO,IX,IY,J,JX,JY,KX,KY,LENX,LENY
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(TRANS,'N') .AND. .NOT.LSAME(TRANS,'T') .AND.
+ .NOT.LSAME(TRANS,'C')) THEN
INFO = 1
ELSE IF (M.LT.0) THEN
INFO = 2
ELSE IF (N.LT.0) THEN
INFO = 3
ELSE IF (LDA.LT.MAX(1,M)) THEN
INFO = 6
ELSE IF (INCX.EQ.0) THEN
INFO = 8
ELSE IF (INCY.EQ.0) THEN
INFO = 11
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DGEMV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((M.EQ.0) .OR. (N.EQ.0) .OR.
+ ((ALPHA.EQ.ZERO).AND. (BETA.EQ.ONE))) RETURN
*
* Set LENX and LENY, the lengths of the vectors x and y, and set
* up the start points in X and Y.
*
IF (LSAME(TRANS,'N')) THEN
LENX = N
LENY = M
ELSE
LENX = M
LENY = N
END IF
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (LENX-1)*INCX
END IF
IF (INCY.GT.0) THEN
KY = 1
ELSE
KY = 1 - (LENY-1)*INCY
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through A.
*
* First form y := beta*y.
*
IF (BETA.NE.ONE) THEN
IF (INCY.EQ.1) THEN
IF (BETA.EQ.ZERO) THEN
DO 10 I = 1,LENY
Y(I) = ZERO
10 CONTINUE
ELSE
DO 20 I = 1,LENY
Y(I) = BETA*Y(I)
20 CONTINUE
END IF
ELSE
IY = KY
IF (BETA.EQ.ZERO) THEN
DO 30 I = 1,LENY
Y(IY) = ZERO
IY = IY + INCY
30 CONTINUE
ELSE
DO 40 I = 1,LENY
Y(IY) = BETA*Y(IY)
IY = IY + INCY
40 CONTINUE
END IF
END IF
END IF
IF (ALPHA.EQ.ZERO) RETURN
IF (LSAME(TRANS,'N')) THEN
*
* Form y := alpha*A*x + y.
*
JX = KX
IF (INCY.EQ.1) THEN
DO 60 J = 1,N
TEMP = ALPHA*X(JX)
DO 50 I = 1,M
Y(I) = Y(I) + TEMP*A(I,J)
50 CONTINUE
JX = JX + INCX
60 CONTINUE
ELSE
DO 80 J = 1,N
TEMP = ALPHA*X(JX)
IY = KY
DO 70 I = 1,M
Y(IY) = Y(IY) + TEMP*A(I,J)
IY = IY + INCY
70 CONTINUE
JX = JX + INCX
80 CONTINUE
END IF
ELSE
*
* Form y := alpha*A**T*x + y.
*
JY = KY
IF (INCX.EQ.1) THEN
DO 100 J = 1,N
TEMP = ZERO
DO 90 I = 1,M
TEMP = TEMP + A(I,J)*X(I)
90 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP
JY = JY + INCY
100 CONTINUE
ELSE
DO 120 J = 1,N
TEMP = ZERO
IX = KX
DO 110 I = 1,M
TEMP = TEMP + A(I,J)*X(IX)
IX = IX + INCX
110 CONTINUE
Y(JY) = Y(JY) + ALPHA*TEMP
JY = JY + INCY
120 CONTINUE
END IF
END IF
*
RETURN
*
* End of DGEMV
*
END
*> \brief \b DGEQR2 computes the QR factorization of a general rectangular matrix using an unblocked algorithm.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DGEQR2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGEQR2 computes a QR factorization of a real m-by-n matrix A:
*>
*> A = Q * ( R ),
*> ( 0 )
*>
*> where:
*>
*> Q is a m-by-m orthogonal matrix;
*> R is an upper-triangular n-by-n matrix;
*> 0 is a (m-n)-by-n zero matrix, if m > n.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the m by n matrix A.
*> On exit, the elements on and above the diagonal of the array
*> contain the min(m,n) by n upper trapezoidal matrix R (R is
*> upper triangular if m >= n); the elements below the diagonal,
*> with the array TAU, represent the orthogonal matrix Q as a
*> product of elementary reflectors (see Further Details).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup geqr2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrix Q is represented as a product of elementary reflectors
*>
*> Q = H(1) H(2) . . . H(k), where k = min(m,n).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**T
*>
*> where tau is a real scalar, and v is a real vector with
*> v(1:i-1) = 0 and v(i) = 1; v(i+1:m) is stored on exit in A(i+1:m,i),
*> and tau in TAU(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DGEQR2( M, N, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, K
* ..
* .. External Subroutines ..
EXTERNAL DLARF1F, DLARFG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGEQR2', -INFO )
RETURN
END IF
*
K = MIN( M, N )
*
DO 10 I = 1, K
*
* Generate elementary reflector H(i) to annihilate A(i+1:m,i)
*
CALL DLARFG( M-I+1, A( I, I ), A( MIN( I+1, M ), I ), 1,
$ TAU( I ) )
IF( I.LT.N ) THEN
*
* Apply H(i) to A(i:m,i+1:n) from the left
*
CALL DLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
$ A( I, I+1 ), LDA, WORK )
END IF
10 CONTINUE
RETURN
*
* End of DGEQR2
*
END
*> \brief \b DGER
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION ALPHA
* INTEGER INCX,INCY,LDA,M,N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A(LDA,*),X(*),Y(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGER performs the rank 1 operation
*>
*> A := alpha*x*y**T + A,
*>
*> where alpha is a scalar, x is an m element vector, y is an n element
*> vector and A is an m by n matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the number of rows of the matrix A.
*> M must be at least zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the number of columns of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is DOUBLE PRECISION.
*> On entry, ALPHA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in] X
*> \verbatim
*> X is DOUBLE PRECISION array, dimension at least
*> ( 1 + ( m - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the m
*> element vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is DOUBLE PRECISION array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCY ) ).
*> Before entry, the incremented array Y must contain the n
*> element vector y.
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> On entry, INCY specifies the increment for the elements of
*> Y. INCY must not be zero.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension ( LDA, N )
*> Before entry, the leading m by n part of the array A must
*> contain the matrix of coefficients. On exit, A is
*> overwritten by the updated matrix.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> max( 1, m ).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup ger
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Level 2 Blas routine.
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DGER(M,N,ALPHA,X,INCX,Y,INCY,A,LDA)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
DOUBLE PRECISION ALPHA
INTEGER INCX,INCY,LDA,M,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),X(*),Y(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER (ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP
INTEGER I,INFO,IX,J,JY,KX
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
*
* Test the input parameters.
*
INFO = 0
IF (M.LT.0) THEN
INFO = 1
ELSE IF (N.LT.0) THEN
INFO = 2
ELSE IF (INCX.EQ.0) THEN
INFO = 5
ELSE IF (INCY.EQ.0) THEN
INFO = 7
ELSE IF (LDA.LT.MAX(1,M)) THEN
INFO = 9
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DGER ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF ((M.EQ.0) .OR. (N.EQ.0) .OR. (ALPHA.EQ.ZERO)) RETURN
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through A.
*
IF (INCY.GT.0) THEN
JY = 1
ELSE
JY = 1 - (N-1)*INCY
END IF
IF (INCX.EQ.1) THEN
DO 20 J = 1,N
IF (Y(JY).NE.ZERO) THEN
TEMP = ALPHA*Y(JY)
DO 10 I = 1,M
A(I,J) = A(I,J) + X(I)*TEMP
10 CONTINUE
END IF
JY = JY + INCY
20 CONTINUE
ELSE
IF (INCX.GT.0) THEN
KX = 1
ELSE
KX = 1 - (M-1)*INCX
END IF
DO 40 J = 1,N
IF (Y(JY).NE.ZERO) THEN
TEMP = ALPHA*Y(JY)
IX = KX
DO 30 I = 1,M
A(I,J) = A(I,J) + X(IX)*TEMP
IX = IX + INCX
30 CONTINUE
END IF
JY = JY + INCY
40 CONTINUE
END IF
*
RETURN
*
* End of DGER
*
END
*> \brief \b DGERQ2 computes the RQ factorization of a general rectangular matrix using an unblocked algorithm.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DGERQ2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGERQ2 computes an RQ factorization of a real m by n matrix A:
*> A = R * Q.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the m by n matrix A.
*> On exit, if m <= n, the upper triangle of the subarray
*> A(1:m,n-m+1:n) contains the m by m upper triangular matrix R;
*> if m >= n, the elements on and above the (m-n)-th subdiagonal
*> contain the m by n upper trapezoidal matrix R; the remaining
*> elements, with the array TAU, represent the orthogonal matrix
*> Q as a product of elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION array, dimension (min(M,N))
*> The scalar factors of the elementary reflectors (see Further
*> Details).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (M)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gerq2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> The matrix Q is represented as a product of elementary reflectors
*>
*> Q = H(1) H(2) . . . H(k), where k = min(m,n).
*>
*> Each H(i) has the form
*>
*> H(i) = I - tau * v * v**T
*>
*> where tau is a real scalar, and v is a real vector with
*> v(n-k+i+1:n) = 0 and v(n-k+i) = 1; v(1:n-k+i-1) is stored on exit in
*> A(m-k+i,1:n-k+i-1), and tau in TAU(i).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DGERQ2( M, N, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, K
* ..
* .. External Subroutines ..
EXTERNAL DLARF1L, DLARFG, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX, MIN
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 ) THEN
INFO = -2
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -4
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGERQ2', -INFO )
RETURN
END IF
*
K = MIN( M, N )
*
DO 10 I = K, 1, -1
*
* Generate elementary reflector H(i) to annihilate
* A(m-k+i,1:n-k+i-1)
*
CALL DLARFG( N-K+I, A( M-K+I, N-K+I ), A( M-K+I, 1 ), LDA,
$ TAU( I ) )
*
* Apply H(i) to A(1:m-k+i-1,1:n-k+i) from the right
*
CALL DLARF1L( 'Right', M-K+I-1, N-K+I, A( M-K+I, 1 ), LDA,
$ TAU( I ), A, LDA, WORK )
10 CONTINUE
RETURN
*
* End of DGERQ2
*
END
*> \brief \b DGESC2 solves a system of linear equations using the LU factorization with complete pivoting computed by sgetc2.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DGESC2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )
*
* .. Scalar Arguments ..
* INTEGER LDA, N
* DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
* INTEGER IPIV( * ), JPIV( * )
* DOUBLE PRECISION A( LDA, * ), RHS( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGESC2 solves a system of linear equations
*>
*> A * X = scale* RHS
*>
*> with a general N-by-N matrix A using the LU factorization with
*> complete pivoting computed by DGETC2.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the LU part of the factorization of the n-by-n
*> matrix A computed by DGETC2: A = P * L * U * Q
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1, N).
*> \endverbatim
*>
*> \param[in,out] RHS
*> \verbatim
*> RHS is DOUBLE PRECISION array, dimension (N).
*> On entry, the right hand side vector b.
*> On exit, the solution vector X.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N).
*> The pivot indices; for 1 <= i <= N, row i of the
*> matrix has been interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[in] JPIV
*> \verbatim
*> JPIV is INTEGER array, dimension (N).
*> The pivot indices; for 1 <= j <= N, column j of the
*> matrix has been interchanged with column JPIV(j).
*> \endverbatim
*>
*> \param[out] SCALE
*> \verbatim
*> SCALE is DOUBLE PRECISION
*> On exit, SCALE contains the scale factor. SCALE is chosen
*> 0 <= SCALE <= 1 to prevent overflow in the solution.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup gesc2
*
*> \par Contributors:
* ==================
*>
*> Bo Kagstrom and Peter Poromaa, Department of Computing Science,
*> Umea University, S-901 87 Umea, Sweden.
*
* =====================================================================
SUBROUTINE DGESC2( N, A, LDA, RHS, IPIV, JPIV, SCALE )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER LDA, N
DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), JPIV( * )
DOUBLE PRECISION A( LDA, * ), RHS( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, TWO
PARAMETER ( ONE = 1.0D+0, TWO = 2.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION BIGNUM, EPS, SMLNUM, TEMP
* ..
* .. External Subroutines ..
EXTERNAL DLASWP, DSCAL
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DLAMCH
EXTERNAL IDAMAX, DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Set constant to control overflow
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
BIGNUM = ONE / SMLNUM
*
* Apply permutations IPIV to RHS
*
CALL DLASWP( 1, RHS, LDA, 1, N-1, IPIV, 1 )
*
* Solve for L part
*
DO 20 I = 1, N - 1
DO 10 J = I + 1, N
RHS( J ) = RHS( J ) - A( J, I )*RHS( I )
10 CONTINUE
20 CONTINUE
*
* Solve for U part
*
SCALE = ONE
*
* Check for scaling
*
I = IDAMAX( N, RHS, 1 )
IF( TWO*SMLNUM*ABS( RHS( I ) ).GT.ABS( A( N, N ) ) ) THEN
TEMP = ( ONE / TWO ) / ABS( RHS( I ) )
CALL DSCAL( N, TEMP, RHS( 1 ), 1 )
SCALE = SCALE*TEMP
END IF
*
DO 40 I = N, 1, -1
TEMP = ONE / A( I, I )
RHS( I ) = RHS( I )*TEMP
DO 30 J = I + 1, N
RHS( I ) = RHS( I ) - RHS( J )*( A( I, J )*TEMP )
30 CONTINUE
40 CONTINUE
*
* Apply permutations JPIV to the solution (RHS)
*
CALL DLASWP( 1, RHS, LDA, 1, N-1, JPIV, -1 )
RETURN
*
* End of DGESC2
*
END
*> \brief \b DGETC2 computes the LU factorization with complete pivoting of the general n-by-n matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DGETC2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * ), JPIV( * )
* DOUBLE PRECISION A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DGETC2 computes an LU factorization with complete pivoting of the
*> n-by-n matrix A. The factorization has the form A = P * L * U * Q,
*> where P and Q are permutation matrices, L is lower triangular with
*> unit diagonal elements and U is upper triangular.
*>
*> This is the Level 2 BLAS algorithm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA, N)
*> On entry, the n-by-n matrix A to be factored.
*> On exit, the factors L and U from the factorization
*> A = P*L*U*Q; the unit diagonal elements of L are not stored.
*> If U(k, k) appears to be less than SMIN, U(k, k) is given the
*> value of SMIN, i.e., giving a nonsingular perturbed system.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[out] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension(N).
*> The pivot indices; for 1 <= i <= N, row i of the
*> matrix has been interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[out] JPIV
*> \verbatim
*> JPIV is INTEGER array, dimension(N).
*> The pivot indices; for 1 <= j <= N, column j of the
*> matrix has been interchanged with column JPIV(j).
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> > 0: if INFO = k, U(k, k) is likely to produce overflow if
*> we try to solve for x in Ax = b. So U is perturbed to
*> avoid the overflow.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup getc2
*
*> \par Contributors:
* ==================
*>
*> Bo Kagstrom and Peter Poromaa, Department of Computing Science,
*> Umea University, S-901 87 Umea, Sweden.
*
* =====================================================================
SUBROUTINE DGETC2( N, A, LDA, IPIV, JPIV, INFO )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), JPIV( * )
DOUBLE PRECISION A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, IP, IPV, J, JP, JPV
DOUBLE PRECISION BIGNUM, EPS, SMIN, SMLNUM, XMAX
* ..
* .. External Subroutines ..
EXTERNAL DGER, DSWAP
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
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
*
* Handle the case N=1 by itself
*
IF( N.EQ.1 ) THEN
IPIV( 1 ) = 1
JPIV( 1 ) = 1
IF( ABS( A( 1, 1 ) ).LT.SMLNUM ) THEN
INFO = 1
A( 1, 1 ) = SMLNUM
END IF
RETURN
END IF
*
* Factorize A using complete pivoting.
* Set pivots less than SMIN to SMIN.
*
DO 40 I = 1, N - 1
*
* Find max element in matrix A
*
XMAX = ZERO
DO 20 JP = I, N
DO 10 IP = I, N
IF( ABS( A( IP, JP ) ).GE.XMAX ) THEN
XMAX = ABS( A( IP, JP ) )
IPV = IP
JPV = JP
END IF
10 CONTINUE
20 CONTINUE
IF( I.EQ.1 )
$ SMIN = MAX( EPS*XMAX, SMLNUM )
*
* Swap rows
*
IF( IPV.NE.I )
$ CALL DSWAP( N, A( IPV, 1 ), LDA, A( I, 1 ), LDA )
IPIV( I ) = IPV
*
* Swap columns
*
IF( JPV.NE.I )
$ CALL DSWAP( N, A( 1, JPV ), 1, A( 1, I ), 1 )
JPIV( I ) = JPV
*
* Check for singularity
*
IF( ABS( A( I, I ) ).LT.SMIN ) THEN
INFO = I
A( I, I ) = SMIN
END IF
DO 30 J = I + 1, N
A( J, I ) = A( J, I ) / A( I, I )
30 CONTINUE
CALL DGER( N-I, N-I, -ONE, A( I+1, I ), 1, A( I, I+1 ), LDA,
$ A( I+1, I+1 ), LDA )
40 CONTINUE
*
IF( ABS( A( N, N ) ).LT.SMIN ) THEN
INFO = N
A( N, N ) = SMIN
END IF
*
* Set last pivots to N
*
IPIV( N ) = N
JPIV( N ) = N
*
RETURN
*
* End of DGETC2
*
END
*> \brief \b DISNAN tests input for NaN.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DISNAN + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* LOGICAL FUNCTION DISNAN( DIN )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION, INTENT(IN) :: DIN
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DISNAN returns .TRUE. if its argument is NaN, and .FALSE.
*> otherwise. To be replaced by the Fortran 2003 intrinsic in the
*> future.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] DIN
*> \verbatim
*> DIN is DOUBLE PRECISION
*> Input to test for NaN.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup isnan
*
* =====================================================================
LOGICAL FUNCTION DISNAN( DIN )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
DOUBLE PRECISION, INTENT(IN) :: DIN
* ..
*
* =====================================================================
*
* .. External Functions ..
LOGICAL DLAISNAN
EXTERNAL DLAISNAN
* ..
* .. Executable Statements ..
DISNAN = DLAISNAN(DIN,DIN)
RETURN
END
*> \brief \b DLACN2 estimates the 1-norm of a square matrix, using reverse communication for evaluating matrix-vector products.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLACN2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE )
*
* .. Scalar Arguments ..
* INTEGER KASE, N
* DOUBLE PRECISION EST
* ..
* .. Array Arguments ..
* INTEGER ISGN( * ), ISAVE( 3 )
* DOUBLE PRECISION V( * ), X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLACN2 estimates the 1-norm of a square, real matrix A.
*> Reverse communication is used for evaluating matrix-vector products.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix. N >= 1.
*> \endverbatim
*>
*> \param[out] V
*> \verbatim
*> V is DOUBLE PRECISION array, dimension (N)
*> On the final return, V = A*W, where EST = norm(V)/norm(W)
*> (W is not returned).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is DOUBLE PRECISION array, dimension (N)
*> On an intermediate return, X should be overwritten by
*> A * X, if KASE=1,
*> A**T * X, if KASE=2,
*> and DLACN2 must be re-called with all the other parameters
*> unchanged.
*> \endverbatim
*>
*> \param[out] ISGN
*> \verbatim
*> ISGN is INTEGER array, dimension (N)
*> \endverbatim
*>
*> \param[in,out] EST
*> \verbatim
*> EST is DOUBLE PRECISION
*> On entry with KASE = 1 or 2 and ISAVE(1) = 3, EST should be
*> unchanged from the previous call to DLACN2.
*> On exit, EST is an estimate (a lower bound) for norm(A).
*> \endverbatim
*>
*> \param[in,out] KASE
*> \verbatim
*> KASE is INTEGER
*> On the initial call to DLACN2, KASE should be 0.
*> On an intermediate return, KASE will be 1 or 2, indicating
*> whether X should be overwritten by A * X or A**T * X.
*> On the final return from DLACN2, KASE will again be 0.
*> \endverbatim
*>
*> \param[in,out] ISAVE
*> \verbatim
*> ISAVE is INTEGER array, dimension (3)
*> ISAVE is used to save variables between calls to DLACN2
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup lacn2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Originally named SONEST, dated March 16, 1988.
*>
*> This is a thread safe version of DLACON, which uses the array ISAVE
*> in place of a SAVE statement, as follows:
*>
*> DLACON DLACN2
*> JUMP ISAVE(1)
*> J ISAVE(2)
*> ITER ISAVE(3)
*> \endverbatim
*
*> \par Contributors:
* ==================
*>
*> Nick Higham, University of Manchester
*
*> \par References:
* ================
*>
*> N.J. Higham, "FORTRAN codes for estimating the one-norm of
*> a real or complex matrix, with applications to condition estimation",
*> ACM Trans. Math. Soft., vol. 14, no. 4, pp. 381-396, December 1988.
*>
* =====================================================================
SUBROUTINE DLACN2( N, V, X, ISGN, EST, KASE, ISAVE )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER KASE, N
DOUBLE PRECISION EST
* ..
* .. Array Arguments ..
INTEGER ISGN( * ), ISAVE( 3 )
DOUBLE PRECISION V( * ), X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER ITMAX
PARAMETER ( ITMAX = 5 )
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, JLAST
DOUBLE PRECISION ALTSGN, ESTOLD, TEMP, XS
* ..
* .. External Functions ..
INTEGER IDAMAX
DOUBLE PRECISION DASUM
EXTERNAL IDAMAX, DASUM
* ..
* .. External Subroutines ..
EXTERNAL DCOPY
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, DBLE, NINT
* ..
* .. Executable Statements ..
*
IF( KASE.EQ.0 ) THEN
DO 10 I = 1, N
X( I ) = ONE / DBLE( N )
10 CONTINUE
KASE = 1
ISAVE( 1 ) = 1
RETURN
END IF
*
GO TO ( 20, 40, 70, 110, 140 )ISAVE( 1 )
*
* ................ ENTRY (ISAVE( 1 ) = 1)
* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY A*X.
*
20 CONTINUE
IF( N.EQ.1 ) THEN
V( 1 ) = X( 1 )
EST = ABS( V( 1 ) )
* ... QUIT
GO TO 150
END IF
EST = DASUM( N, X, 1 )
*
DO 30 I = 1, N
IF( X(I).GE.ZERO ) THEN
X(I) = ONE
ELSE
X(I) = -ONE
END IF
ISGN( I ) = NINT( X( I ) )
30 CONTINUE
KASE = 2
ISAVE( 1 ) = 2
RETURN
*
* ................ ENTRY (ISAVE( 1 ) = 2)
* FIRST ITERATION. X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
*
40 CONTINUE
ISAVE( 2 ) = IDAMAX( N, X, 1 )
ISAVE( 3 ) = 2
*
* MAIN LOOP - ITERATIONS 2,3,...,ITMAX.
*
50 CONTINUE
DO 60 I = 1, N
X( I ) = ZERO
60 CONTINUE
X( ISAVE( 2 ) ) = ONE
KASE = 1
ISAVE( 1 ) = 3
RETURN
*
* ................ ENTRY (ISAVE( 1 ) = 3)
* X HAS BEEN OVERWRITTEN BY A*X.
*
70 CONTINUE
CALL DCOPY( N, X, 1, V, 1 )
ESTOLD = EST
EST = DASUM( N, V, 1 )
DO 80 I = 1, N
IF( X(I).GE.ZERO ) THEN
XS = ONE
ELSE
XS = -ONE
END IF
IF( NINT( XS ).NE.ISGN( I ) )
$ GO TO 90
80 CONTINUE
* REPEATED SIGN VECTOR DETECTED, HENCE ALGORITHM HAS CONVERGED.
GO TO 120
*
90 CONTINUE
* TEST FOR CYCLING.
IF( EST.LE.ESTOLD )
$ GO TO 120
*
DO 100 I = 1, N
IF( X(I).GE.ZERO ) THEN
X(I) = ONE
ELSE
X(I) = -ONE
END IF
ISGN( I ) = NINT( X( I ) )
100 CONTINUE
KASE = 2
ISAVE( 1 ) = 4
RETURN
*
* ................ ENTRY (ISAVE( 1 ) = 4)
* X HAS BEEN OVERWRITTEN BY TRANSPOSE(A)*X.
*
110 CONTINUE
JLAST = ISAVE( 2 )
ISAVE( 2 ) = IDAMAX( N, X, 1 )
IF( ( X( JLAST ).NE.ABS( X( ISAVE( 2 ) ) ) ) .AND.
$ ( ISAVE( 3 ).LT.ITMAX ) ) THEN
ISAVE( 3 ) = ISAVE( 3 ) + 1
GO TO 50
END IF
*
* ITERATION COMPLETE. FINAL STAGE.
*
120 CONTINUE
ALTSGN = ONE
DO 130 I = 1, N
X( I ) = ALTSGN*( ONE+DBLE( I-1 ) / DBLE( N-1 ) )
ALTSGN = -ALTSGN
130 CONTINUE
KASE = 1
ISAVE( 1 ) = 5
RETURN
*
* ................ ENTRY (ISAVE( 1 ) = 5)
* X HAS BEEN OVERWRITTEN BY A*X.
*
140 CONTINUE
TEMP = TWO*( DASUM( N, X, 1 ) / DBLE( 3*N ) )
IF( TEMP.GT.EST ) THEN
CALL DCOPY( N, X, 1, V, 1 )
EST = TEMP
END IF
*
150 CONTINUE
KASE = 0
RETURN
*
* End of DLACN2
*
END
*> \brief \b DLACPY copies all or part of one two-dimensional array to another.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLACPY + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, LDB, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLACPY copies all or part of a two-dimensional matrix A to another
*> matrix B.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies the part of the matrix A to be copied to B.
*> = 'U': Upper triangular part
*> = 'L': Lower triangular part
*> Otherwise: All of the matrix A
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> The m by n matrix A. If UPLO = 'U', only the upper triangle
*> or trapezoid is accessed; if UPLO = 'L', only the lower
*> triangle or trapezoid is accessed.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[out] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (LDB,N)
*> On exit, B = A in the locations specified by UPLO.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup lacpy
*
* =====================================================================
SUBROUTINE DLACPY( UPLO, M, N, A, LDA, B, LDB )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, LDB, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( LSAME( UPLO, 'U' ) ) THEN
DO 20 J = 1, N
DO 10 I = 1, MIN( J, M )
B( I, J ) = A( I, J )
10 CONTINUE
20 CONTINUE
ELSE IF( LSAME( UPLO, 'L' ) ) THEN
DO 40 J = 1, N
DO 30 I = J, M
B( I, J ) = A( I, J )
30 CONTINUE
40 CONTINUE
ELSE
DO 60 J = 1, N
DO 50 I = 1, M
B( I, J ) = A( I, J )
50 CONTINUE
60 CONTINUE
END IF
RETURN
*
* End of DLACPY
*
END
*> \brief \b DLAG2 computes the eigenvalues of a 2-by-2 generalized eigenvalue problem, with scaling as necessary to avoid over-/underflow.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLAG2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1,
* WR2, WI )
*
* .. Scalar Arguments ..
* INTEGER LDA, LDB
* DOUBLE PRECISION SAFMIN, SCALE1, SCALE2, WI, WR1, WR2
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAG2 computes the eigenvalues of a 2 x 2 generalized eigenvalue
*> problem A - w B, with scaling as necessary to avoid over-/underflow.
*>
*> The scaling factor "s" results in a modified eigenvalue equation
*>
*> s A - w B
*>
*> where s is a non-negative scaling factor chosen so that w, w B,
*> and s A do not overflow and, if possible, do not underflow, either.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA, 2)
*> On entry, the 2 x 2 matrix A. It is assumed that its 1-norm
*> is less than 1/SAFMIN. Entries less than
*> sqrt(SAFMIN)*norm(A) are subject to being treated as zero.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= 2.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (LDB, 2)
*> On entry, the 2 x 2 upper triangular matrix B. It is
*> assumed that the one-norm of B is less than 1/SAFMIN. The
*> diagonals should be at least sqrt(SAFMIN) times the largest
*> element of B (in absolute value); if a diagonal is smaller
*> than that, then +/- sqrt(SAFMIN) will be used instead of
*> that diagonal.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= 2.
*> \endverbatim
*>
*> \param[in] SAFMIN
*> \verbatim
*> SAFMIN is DOUBLE PRECISION
*> The smallest positive number s.t. 1/SAFMIN does not
*> overflow. (This should always be DLAMCH('S') -- it is an
*> argument in order to avoid having to call DLAMCH frequently.)
*> \endverbatim
*>
*> \param[out] SCALE1
*> \verbatim
*> SCALE1 is DOUBLE PRECISION
*> A scaling factor used to avoid over-/underflow in the
*> eigenvalue equation which defines the first eigenvalue. If
*> the eigenvalues are complex, then the eigenvalues are
*> ( WR1 +/- WI i ) / SCALE1 (which may lie outside the
*> exponent range of the machine), SCALE1=SCALE2, and SCALE1
*> will always be positive. If the eigenvalues are real, then
*> the first (real) eigenvalue is WR1 / SCALE1 , but this may
*> overflow or underflow, and in fact, SCALE1 may be zero or
*> less than the underflow threshold if the exact eigenvalue
*> is sufficiently large.
*> \endverbatim
*>
*> \param[out] SCALE2
*> \verbatim
*> SCALE2 is DOUBLE PRECISION
*> A scaling factor used to avoid over-/underflow in the
*> eigenvalue equation which defines the second eigenvalue. If
*> the eigenvalues are complex, then SCALE2=SCALE1. If the
*> eigenvalues are real, then the second (real) eigenvalue is
*> WR2 / SCALE2 , but this may overflow or underflow, and in
*> fact, SCALE2 may be zero or less than the underflow
*> threshold if the exact eigenvalue is sufficiently large.
*> \endverbatim
*>
*> \param[out] WR1
*> \verbatim
*> WR1 is DOUBLE PRECISION
*> If the eigenvalue is real, then WR1 is SCALE1 times the
*> eigenvalue closest to the (2,2) element of A B**(-1). If the
*> eigenvalue is complex, then WR1=WR2 is SCALE1 times the real
*> part of the eigenvalues.
*> \endverbatim
*>
*> \param[out] WR2
*> \verbatim
*> WR2 is DOUBLE PRECISION
*> If the eigenvalue is real, then WR2 is SCALE2 times the
*> other eigenvalue. If the eigenvalue is complex, then
*> WR1=WR2 is SCALE1 times the real part of the eigenvalues.
*> \endverbatim
*>
*> \param[out] WI
*> \verbatim
*> WI is DOUBLE PRECISION
*> If the eigenvalue is real, then WI is zero. If the
*> eigenvalue is complex, then WI is SCALE1 times the imaginary
*> part of the eigenvalues. WI will always be non-negative.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup lag2
*
* =====================================================================
SUBROUTINE DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1,
$ WR2, WI )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER LDA, LDB
DOUBLE PRECISION SAFMIN, SCALE1, SCALE2, WI, WR1, WR2
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE, TWO
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0, TWO = 2.0D+0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = ONE / TWO )
DOUBLE PRECISION FUZZY1
PARAMETER ( FUZZY1 = ONE+1.0D-5 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION A11, A12, A21, A22, ABI22, ANORM, AS11, AS12,
$ AS22, ASCALE, B11, B12, B22, BINV11, BINV22,
$ BMIN, BNORM, BSCALE, BSIZE, C1, C2, C3, C4, C5,
$ DIFF, DISCR, PP, QQ, R, RTMAX, RTMIN, S1, S2,
$ SAFMAX, SHIFT, SS, SUM, WABS, WBIG, WDET,
$ WSCALE, WSIZE, WSMALL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SIGN, SQRT
* ..
* .. Executable Statements ..
*
RTMIN = SQRT( SAFMIN )
RTMAX = ONE / RTMIN
SAFMAX = ONE / SAFMIN
*
* Scale A
*
ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ),
$ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN )
ASCALE = ONE / ANORM
A11 = ASCALE*A( 1, 1 )
A21 = ASCALE*A( 2, 1 )
A12 = ASCALE*A( 1, 2 )
A22 = ASCALE*A( 2, 2 )
*
* Perturb B if necessary to insure non-singularity
*
B11 = B( 1, 1 )
B12 = B( 1, 2 )
B22 = B( 2, 2 )
BMIN = RTMIN*MAX( ABS( B11 ), ABS( B12 ), ABS( B22 ), RTMIN )
IF( ABS( B11 ).LT.BMIN )
$ B11 = SIGN( BMIN, B11 )
IF( ABS( B22 ).LT.BMIN )
$ B22 = SIGN( BMIN, B22 )
*
* Scale B
*
BNORM = MAX( ABS( B11 ), ABS( B12 )+ABS( B22 ), SAFMIN )
BSIZE = MAX( ABS( B11 ), ABS( B22 ) )
BSCALE = ONE / BSIZE
B11 = B11*BSCALE
B12 = B12*BSCALE
B22 = B22*BSCALE
*
* Compute larger eigenvalue by method described by C. van Loan
*
* ( AS is A shifted by -SHIFT*B )
*
BINV11 = ONE / B11
BINV22 = ONE / B22
S1 = A11*BINV11
S2 = A22*BINV22
IF( ABS( S1 ).LE.ABS( S2 ) ) THEN
AS12 = A12 - S1*B12
AS22 = A22 - S1*B22
SS = A21*( BINV11*BINV22 )
ABI22 = AS22*BINV22 - SS*B12
PP = HALF*ABI22
SHIFT = S1
ELSE
AS12 = A12 - S2*B12
AS11 = A11 - S2*B11
SS = A21*( BINV11*BINV22 )
ABI22 = -SS*B12
PP = HALF*( AS11*BINV11+ABI22 )
SHIFT = S2
END IF
QQ = SS*AS12
IF( ABS( PP*RTMIN ).GE.ONE ) THEN
DISCR = ( RTMIN*PP )**2 + QQ*SAFMIN
R = SQRT( ABS( DISCR ) )*RTMAX
ELSE
IF( PP**2+ABS( QQ ).LE.SAFMIN ) THEN
DISCR = ( RTMAX*PP )**2 + QQ*SAFMAX
R = SQRT( ABS( DISCR ) )*RTMIN
ELSE
DISCR = PP**2 + QQ
R = SQRT( ABS( DISCR ) )
END IF
END IF
*
* Note: the test of R in the following IF is to cover the case when
* DISCR is small and negative and is flushed to zero during
* the calculation of R. On machines which have a consistent
* flush-to-zero threshold and handle numbers above that
* threshold correctly, it would not be necessary.
*
IF( DISCR.GE.ZERO .OR. R.EQ.ZERO ) THEN
SUM = PP + SIGN( R, PP )
DIFF = PP - SIGN( R, PP )
WBIG = SHIFT + SUM
*
* Compute smaller eigenvalue
*
WSMALL = SHIFT + DIFF
IF( HALF*ABS( WBIG ).GT.MAX( ABS( WSMALL ), SAFMIN ) ) THEN
WDET = ( A11*A22-A12*A21 )*( BINV11*BINV22 )
WSMALL = WDET / WBIG
END IF
*
* Choose (real) eigenvalue closest to 2,2 element of A*B**(-1)
* for WR1.
*
IF( PP.GT.ABI22 ) THEN
WR1 = MIN( WBIG, WSMALL )
WR2 = MAX( WBIG, WSMALL )
ELSE
WR1 = MAX( WBIG, WSMALL )
WR2 = MIN( WBIG, WSMALL )
END IF
WI = ZERO
ELSE
*
* Complex eigenvalues
*
WR1 = SHIFT + PP
WR2 = WR1
WI = R
END IF
*
* Further scaling to avoid underflow and overflow in computing
* SCALE1 and overflow in computing w*B.
*
* This scale factor (WSCALE) is bounded from above using C1 and C2,
* and from below using C3 and C4.
* C1 implements the condition s A must never overflow.
* C2 implements the condition w B must never overflow.
* C3, with C2,
* implement the condition that s A - w B must never overflow.
* C4 implements the condition s should not underflow.
* C5 implements the condition max(s,|w|) should be at least 2.
*
C1 = BSIZE*( SAFMIN*MAX( ONE, ASCALE ) )
C2 = SAFMIN*MAX( ONE, BNORM )
C3 = BSIZE*SAFMIN
IF( ASCALE.LE.ONE .AND. BSIZE.LE.ONE ) THEN
C4 = MIN( ONE, ( ASCALE / SAFMIN )*BSIZE )
ELSE
C4 = ONE
END IF
IF( ASCALE.LE.ONE .OR. BSIZE.LE.ONE ) THEN
C5 = MIN( ONE, ASCALE*BSIZE )
ELSE
C5 = ONE
END IF
*
* Scale first eigenvalue
*
WABS = ABS( WR1 ) + ABS( WI )
WSIZE = MAX( SAFMIN, C1, FUZZY1*( WABS*C2+C3 ),
$ MIN( C4, HALF*MAX( WABS, C5 ) ) )
IF( WSIZE.NE.ONE ) THEN
WSCALE = ONE / WSIZE
IF( WSIZE.GT.ONE ) THEN
SCALE1 = ( MAX( ASCALE, BSIZE )*WSCALE )*
$ MIN( ASCALE, BSIZE )
ELSE
SCALE1 = ( MIN( ASCALE, BSIZE )*WSCALE )*
$ MAX( ASCALE, BSIZE )
END IF
WR1 = WR1*WSCALE
IF( WI.NE.ZERO ) THEN
WI = WI*WSCALE
WR2 = WR1
SCALE2 = SCALE1
END IF
ELSE
SCALE1 = ASCALE*BSIZE
SCALE2 = SCALE1
END IF
*
* Scale second eigenvalue (if real)
*
IF( WI.EQ.ZERO ) THEN
WSIZE = MAX( SAFMIN, C1, FUZZY1*( ABS( WR2 )*C2+C3 ),
$ MIN( C4, HALF*MAX( ABS( WR2 ), C5 ) ) )
IF( WSIZE.NE.ONE ) THEN
WSCALE = ONE / WSIZE
IF( WSIZE.GT.ONE ) THEN
SCALE2 = ( MAX( ASCALE, BSIZE )*WSCALE )*
$ MIN( ASCALE, BSIZE )
ELSE
SCALE2 = ( MIN( ASCALE, BSIZE )*WSCALE )*
$ MAX( ASCALE, BSIZE )
END IF
WR2 = WR2*WSCALE
ELSE
SCALE2 = ASCALE*BSIZE
END IF
END IF
*
* End of DLAG2
*
RETURN
END
*> \brief \b DLAGV2 computes the Generalized Schur factorization of a real 2-by-2 matrix pencil (A,B) where B is upper triangular.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLAGV2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL, SNL,
* CSR, SNR )
*
* .. Scalar Arguments ..
* INTEGER LDA, LDB
* DOUBLE PRECISION CSL, CSR, SNL, SNR
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ),
* $ B( LDB, * ), BETA( 2 )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAGV2 computes the Generalized Schur factorization of a real 2-by-2
*> matrix pencil (A,B) where B is upper triangular. This routine
*> computes orthogonal (rotation) matrices given by CSL, SNL and CSR,
*> SNR such that
*>
*> 1) if the pencil (A,B) has two real eigenvalues (include 0/0 or 1/0
*> types), then
*>
*> [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]
*> [ 0 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]
*>
*> [ b11 b12 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]
*> [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ],
*>
*> 2) if the pencil (A,B) has a pair of complex conjugate eigenvalues,
*> then
*>
*> [ a11 a12 ] := [ CSL SNL ] [ a11 a12 ] [ CSR -SNR ]
*> [ a21 a22 ] [ -SNL CSL ] [ a21 a22 ] [ SNR CSR ]
*>
*> [ b11 0 ] := [ CSL SNL ] [ b11 b12 ] [ CSR -SNR ]
*> [ 0 b22 ] [ -SNL CSL ] [ 0 b22 ] [ SNR CSR ]
*>
*> where b11 >= b22 > 0.
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA, 2)
*> On entry, the 2 x 2 matrix A.
*> On exit, A is overwritten by the ``A-part'' of the
*> generalized Schur form.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> THe leading dimension of the array A. LDA >= 2.
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (LDB, 2)
*> On entry, the upper triangular 2 x 2 matrix B.
*> On exit, B is overwritten by the ``B-part'' of the
*> generalized Schur form.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> THe leading dimension of the array B. LDB >= 2.
*> \endverbatim
*>
*> \param[out] ALPHAR
*> \verbatim
*> ALPHAR is DOUBLE PRECISION array, dimension (2)
*> \endverbatim
*>
*> \param[out] ALPHAI
*> \verbatim
*> ALPHAI is DOUBLE PRECISION array, dimension (2)
*> \endverbatim
*>
*> \param[out] BETA
*> \verbatim
*> BETA is DOUBLE PRECISION array, dimension (2)
*> (ALPHAR(k)+i*ALPHAI(k))/BETA(k) are the eigenvalues of the
*> pencil (A,B), k=1,2, i = sqrt(-1). Note that BETA(k) may
*> be zero.
*> \endverbatim
*>
*> \param[out] CSL
*> \verbatim
*> CSL is DOUBLE PRECISION
*> The cosine of the left rotation matrix.
*> \endverbatim
*>
*> \param[out] SNL
*> \verbatim
*> SNL is DOUBLE PRECISION
*> The sine of the left rotation matrix.
*> \endverbatim
*>
*> \param[out] CSR
*> \verbatim
*> CSR is DOUBLE PRECISION
*> The cosine of the right rotation matrix.
*> \endverbatim
*>
*> \param[out] SNR
*> \verbatim
*> SNR is DOUBLE PRECISION
*> The sine of the right rotation matrix.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup lagv2
*
*> \par Contributors:
* ==================
*>
*> Mark Fahey, Department of Mathematics, Univ. of Kentucky, USA
*
* =====================================================================
SUBROUTINE DLAGV2( A, LDA, B, LDB, ALPHAR, ALPHAI, BETA, CSL,
$ SNL,
$ CSR, SNR )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER LDA, LDB
DOUBLE PRECISION CSL, CSR, SNL, SNR
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), ALPHAI( 2 ), ALPHAR( 2 ),
$ B( LDB, * ), BETA( 2 )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION ANORM, ASCALE, BNORM, BSCALE, H1, H2, H3, QQ,
$ R, RR, SAFMIN, SCALE1, SCALE2, T, ULP, WI, WR1,
$ WR2
* ..
* .. External Subroutines ..
EXTERNAL DLAG2, DLARTG, DLASV2, DROT
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY2
EXTERNAL DLAMCH, DLAPY2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX
* ..
* .. Executable Statements ..
*
SAFMIN = DLAMCH( 'S' )
ULP = DLAMCH( 'P' )
*
* Scale A
*
ANORM = MAX( ABS( A( 1, 1 ) )+ABS( A( 2, 1 ) ),
$ ABS( A( 1, 2 ) )+ABS( A( 2, 2 ) ), SAFMIN )
ASCALE = ONE / ANORM
A( 1, 1 ) = ASCALE*A( 1, 1 )
A( 1, 2 ) = ASCALE*A( 1, 2 )
A( 2, 1 ) = ASCALE*A( 2, 1 )
A( 2, 2 ) = ASCALE*A( 2, 2 )
*
* Scale B
*
BNORM = MAX( ABS( B( 1, 1 ) ), ABS( B( 1, 2 ) )+ABS( B( 2, 2 ) ),
$ SAFMIN )
BSCALE = ONE / BNORM
B( 1, 1 ) = BSCALE*B( 1, 1 )
B( 1, 2 ) = BSCALE*B( 1, 2 )
B( 2, 2 ) = BSCALE*B( 2, 2 )
*
* Check if A can be deflated
*
IF( ABS( A( 2, 1 ) ).LE.ULP ) THEN
CSL = ONE
SNL = ZERO
CSR = ONE
SNR = ZERO
A( 2, 1 ) = ZERO
B( 2, 1 ) = ZERO
WI = ZERO
*
* Check if B is singular
*
ELSE IF( ABS( B( 1, 1 ) ).LE.ULP ) THEN
CALL DLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R )
CSR = ONE
SNR = ZERO
CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
A( 2, 1 ) = ZERO
B( 1, 1 ) = ZERO
B( 2, 1 ) = ZERO
WI = ZERO
*
ELSE IF( ABS( B( 2, 2 ) ).LE.ULP ) THEN
CALL DLARTG( A( 2, 2 ), A( 2, 1 ), CSR, SNR, T )
SNR = -SNR
CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
CSL = ONE
SNL = ZERO
A( 2, 1 ) = ZERO
B( 2, 1 ) = ZERO
B( 2, 2 ) = ZERO
WI = ZERO
*
ELSE
*
* B is nonsingular, first compute the eigenvalues of (A,B)
*
CALL DLAG2( A, LDA, B, LDB, SAFMIN, SCALE1, SCALE2, WR1,
$ WR2,
$ WI )
*
IF( WI.EQ.ZERO ) THEN
*
* two real eigenvalues, compute s*A-w*B
*
H1 = SCALE1*A( 1, 1 ) - WR1*B( 1, 1 )
H2 = SCALE1*A( 1, 2 ) - WR1*B( 1, 2 )
H3 = SCALE1*A( 2, 2 ) - WR1*B( 2, 2 )
*
RR = DLAPY2( H1, H2 )
QQ = DLAPY2( SCALE1*A( 2, 1 ), H3 )
*
IF( RR.GT.QQ ) THEN
*
* find right rotation matrix to zero 1,1 element of
* (sA - wB)
*
CALL DLARTG( H2, H1, CSR, SNR, T )
*
ELSE
*
* find right rotation matrix to zero 2,1 element of
* (sA - wB)
*
CALL DLARTG( H3, SCALE1*A( 2, 1 ), CSR, SNR, T )
*
END IF
*
SNR = -SNR
CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
*
* compute inf norms of A and B
*
H1 = MAX( ABS( A( 1, 1 ) )+ABS( A( 1, 2 ) ),
$ ABS( A( 2, 1 ) )+ABS( A( 2, 2 ) ) )
H2 = MAX( ABS( B( 1, 1 ) )+ABS( B( 1, 2 ) ),
$ ABS( B( 2, 1 ) )+ABS( B( 2, 2 ) ) )
*
IF( ( SCALE1*H1 ).GE.ABS( WR1 )*H2 ) THEN
*
* find left rotation matrix Q to zero out B(2,1)
*
CALL DLARTG( B( 1, 1 ), B( 2, 1 ), CSL, SNL, R )
*
ELSE
*
* find left rotation matrix Q to zero out A(2,1)
*
CALL DLARTG( A( 1, 1 ), A( 2, 1 ), CSL, SNL, R )
*
END IF
*
CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
*
A( 2, 1 ) = ZERO
B( 2, 1 ) = ZERO
*
ELSE
*
* a pair of complex conjugate eigenvalues
* first compute the SVD of the matrix B
*
CALL DLASV2( B( 1, 1 ), B( 1, 2 ), B( 2, 2 ), R, T, SNR,
$ CSR, SNL, CSL )
*
* Form (A,B) := Q(A,B)Z**T where Q is left rotation matrix and
* Z is right rotation matrix computed from DLASV2
*
CALL DROT( 2, A( 1, 1 ), LDA, A( 2, 1 ), LDA, CSL, SNL )
CALL DROT( 2, B( 1, 1 ), LDB, B( 2, 1 ), LDB, CSL, SNL )
CALL DROT( 2, A( 1, 1 ), 1, A( 1, 2 ), 1, CSR, SNR )
CALL DROT( 2, B( 1, 1 ), 1, B( 1, 2 ), 1, CSR, SNR )
*
B( 2, 1 ) = ZERO
B( 1, 2 ) = ZERO
*
END IF
*
END IF
*
* Unscaling
*
A( 1, 1 ) = ANORM*A( 1, 1 )
A( 2, 1 ) = ANORM*A( 2, 1 )
A( 1, 2 ) = ANORM*A( 1, 2 )
A( 2, 2 ) = ANORM*A( 2, 2 )
B( 1, 1 ) = BNORM*B( 1, 1 )
B( 2, 1 ) = BNORM*B( 2, 1 )
B( 1, 2 ) = BNORM*B( 1, 2 )
B( 2, 2 ) = BNORM*B( 2, 2 )
*
IF( WI.EQ.ZERO ) THEN
ALPHAR( 1 ) = A( 1, 1 )
ALPHAR( 2 ) = A( 2, 2 )
ALPHAI( 1 ) = ZERO
ALPHAI( 2 ) = ZERO
BETA( 1 ) = B( 1, 1 )
BETA( 2 ) = B( 2, 2 )
ELSE
ALPHAR( 1 ) = ANORM*WR1 / SCALE1 / BNORM
ALPHAI( 1 ) = ANORM*WI / SCALE1 / BNORM
ALPHAR( 2 ) = ALPHAR( 1 )
ALPHAI( 2 ) = -ALPHAI( 1 )
BETA( 1 ) = ONE
BETA( 2 ) = ONE
END IF
*
RETURN
*
* End of DLAGV2
*
END
*> \brief \b DLAISNAN tests input for NaN by comparing two arguments for inequality.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLAISNAN + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> This routine is not for general use. It exists solely to avoid
*> over-optimization in DISNAN.
*>
*> DLAISNAN checks for NaNs by comparing its two arguments for
*> inequality. NaN is the only floating-point value where NaN != NaN
*> returns .TRUE. To check for NaNs, pass the same variable as both
*> arguments.
*>
*> A compiler must assume that the two arguments are
*> not the same variable, and the test will not be optimized away.
*> Interprocedural or whole-program optimization may delete this
*> test. The ISNAN functions will be replaced by the correct
*> Fortran 03 intrinsic once the intrinsic is widely available.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] DIN1
*> \verbatim
*> DIN1 is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] DIN2
*> \verbatim
*> DIN2 is DOUBLE PRECISION
*> Two numbers to compare for inequality.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup laisnan
*
* =====================================================================
LOGICAL FUNCTION DLAISNAN( DIN1, DIN2 )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
DOUBLE PRECISION, INTENT(IN) :: DIN1, DIN2
* ..
*
* =====================================================================
*
* .. Executable Statements ..
DLAISNAN = (DIN1.NE.DIN2)
RETURN
END
*> \brief \b DLANGE returns the value of the 1-norm, Frobenius norm, infinity-norm, or the largest absolute value of any element of a general rectangular matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLANGE + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK )
*
* .. Scalar Arguments ..
* CHARACTER NORM
* INTEGER LDA, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLANGE returns the value of the one norm, or the Frobenius norm, or
*> the infinity norm, or the element of largest absolute value of a
*> real matrix A.
*> \endverbatim
*>
*> \return DLANGE
*> \verbatim
*>
*> DLANGE = ( max(abs(A(i,j))), NORM = 'M' or 'm'
*> (
*> ( norm1(A), NORM = '1', 'O' or 'o'
*> (
*> ( normI(A), NORM = 'I' or 'i'
*> (
*> ( normF(A), NORM = 'F', 'f', 'E' or 'e'
*>
*> where norm1 denotes the one norm of a matrix (maximum column sum),
*> normI denotes the infinity norm of a matrix (maximum row sum) and
*> normF denotes the Frobenius norm of a matrix (square root of sum of
*> squares). Note that max(abs(A(i,j))) is not a consistent matrix norm.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] NORM
*> \verbatim
*> NORM is CHARACTER*1
*> Specifies the value to be returned in DLANGE as described
*> above.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0. When M = 0,
*> DLANGE is set to zero.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0. When N = 0,
*> DLANGE is set to zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(M,1).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)),
*> where LWORK >= M when NORM = 'I'; otherwise, WORK is not
*> referenced.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup lange
*
* =====================================================================
DOUBLE PRECISION FUNCTION DLANGE( NORM, M, N, A, LDA, WORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER NORM
INTEGER LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION SCALE, SUM, VALUE, TEMP
* ..
* .. External Subroutines ..
EXTERNAL DLASSQ
* ..
* .. External Functions ..
LOGICAL LSAME, DISNAN
EXTERNAL LSAME, DISNAN
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MIN, SQRT
* ..
* .. Executable Statements ..
*
IF( MIN( M, N ).EQ.0 ) THEN
VALUE = ZERO
ELSE IF( LSAME( NORM, 'M' ) ) THEN
*
* Find max(abs(A(i,j))).
*
VALUE = ZERO
DO 20 J = 1, N
DO 10 I = 1, M
TEMP = ABS( A( I, J ) )
IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP
10 CONTINUE
20 CONTINUE
ELSE IF( ( LSAME( NORM, 'O' ) ) .OR. ( NORM.EQ.'1' ) ) THEN
*
* Find norm1(A).
*
VALUE = ZERO
DO 40 J = 1, N
SUM = ZERO
DO 30 I = 1, M
SUM = SUM + ABS( A( I, J ) )
30 CONTINUE
IF( VALUE.LT.SUM .OR. DISNAN( SUM ) ) VALUE = SUM
40 CONTINUE
ELSE IF( LSAME( NORM, 'I' ) ) THEN
*
* Find normI(A).
*
DO 50 I = 1, M
WORK( I ) = ZERO
50 CONTINUE
DO 70 J = 1, N
DO 60 I = 1, M
WORK( I ) = WORK( I ) + ABS( A( I, J ) )
60 CONTINUE
70 CONTINUE
VALUE = ZERO
DO 80 I = 1, M
TEMP = WORK( I )
IF( VALUE.LT.TEMP .OR. DISNAN( TEMP ) ) VALUE = TEMP
80 CONTINUE
ELSE IF( ( LSAME( NORM, 'F' ) ) .OR.
$ ( LSAME( NORM, 'E' ) ) ) THEN
*
* Find normF(A).
*
SCALE = ZERO
SUM = ONE
DO 90 J = 1, N
CALL DLASSQ( M, A( 1, J ), 1, SCALE, SUM )
90 CONTINUE
VALUE = SCALE*SQRT( SUM )
END IF
*
DLANGE = VALUE
RETURN
*
* End of DLANGE
*
END
*> \brief \b DLAPY2 returns sqrt(x2+y2).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLAPY2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION X, Y
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAPY2 returns sqrt(x**2+y**2), taking care not to cause unnecessary
*> overflow and unnecessary underflow.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] X
*> \verbatim
*> X is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] Y
*> \verbatim
*> Y is DOUBLE PRECISION
*> X and Y specify the values x and y.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup lapy2
*
* =====================================================================
DOUBLE PRECISION FUNCTION DLAPY2( X, Y )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
DOUBLE PRECISION X, Y
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION W, XABS, YABS, Z, HUGEVAL
LOGICAL X_IS_NAN, Y_IS_NAN
* ..
* .. External Functions ..
LOGICAL DISNAN
EXTERNAL DISNAN
* ..
* .. External Subroutines ..
DOUBLE PRECISION DLAMCH
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN, SQRT
* ..
* .. Executable Statements ..
*
X_IS_NAN = DISNAN( X )
Y_IS_NAN = DISNAN( Y )
IF ( X_IS_NAN ) DLAPY2 = X
IF ( Y_IS_NAN ) DLAPY2 = Y
HUGEVAL = DLAMCH( 'Overflow' )
*
IF ( .NOT.( X_IS_NAN.OR.Y_IS_NAN ) ) THEN
XABS = ABS( X )
YABS = ABS( Y )
W = MAX( XABS, YABS )
Z = MIN( XABS, YABS )
IF( Z.EQ.ZERO .OR. W.GT.HUGEVAL ) THEN
DLAPY2 = W
ELSE
DLAPY2 = W*SQRT( ONE+( Z / W )**2 )
END IF
END IF
RETURN
*
* End of DLAPY2
*
END
*> \brief \b DLARF applies an elementary reflector to a general rectangular matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLARF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* .. Scalar Arguments ..
* CHARACTER SIDE
* INTEGER INCV, LDC, M, N
* DOUBLE PRECISION TAU
* ..
* .. Array Arguments ..
* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLARF applies a real elementary reflector H to a real m by n matrix
*> C, from either the left or the right. H is represented in the form
*>
*> H = I - tau * v * v**T
*>
*> where tau is a real scalar and v is a real vector.
*>
*> If tau = 0, then H is taken to be the unit matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': form H * C
*> = 'R': form C * H
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C.
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is DOUBLE PRECISION array, dimension
*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
*> The vector v in the representation of H. V is not used if
*> TAU = 0.
*> \endverbatim
*>
*> \param[in] INCV
*> \verbatim
*> INCV is INTEGER
*> The increment between elements of v. INCV <> 0.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION
*> The value tau in the representation of H.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (LDC,N)
*> On entry, the m by n matrix C.
*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
*> or C * H if SIDE = 'R'.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension
*> (N) if SIDE = 'L'
*> or (M) if SIDE = 'R'
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup larf
*
* =====================================================================
SUBROUTINE DLARF( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER SIDE
INTEGER INCV, LDC, M, N
DOUBLE PRECISION TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL APPLYLEFT
INTEGER I, LASTV, LASTC
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DGER
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILADLR, ILADLC
EXTERNAL LSAME, ILADLR, ILADLC
* ..
* .. Executable Statements ..
*
APPLYLEFT = LSAME( SIDE, 'L' )
LASTV = 0
LASTC = 0
IF( TAU.NE.ZERO ) THEN
! Set up variables for scanning V. LASTV begins pointing to the end
! of V.
IF( APPLYLEFT ) THEN
LASTV = M
ELSE
LASTV = N
END IF
IF( INCV.GT.0 ) THEN
I = 1 + (LASTV-1) * INCV
ELSE
I = 1
END IF
! Look for the last non-zero row in V.
DO WHILE( LASTV.GT.0 .AND. V( I ).EQ.ZERO )
LASTV = LASTV - 1
I = I - INCV
END DO
IF( APPLYLEFT ) THEN
! Scan for the last non-zero column in C(1:lastv,:).
LASTC = ILADLC(LASTV, N, C, LDC)
ELSE
! Scan for the last non-zero row in C(:,1:lastv).
LASTC = ILADLR(M, LASTV, C, LDC)
END IF
END IF
! Note that lastc.eq.0 renders the BLAS operations null; no special
! case is needed at this level.
IF( APPLYLEFT ) THEN
*
* Form H * C
*
IF( LASTV.GT.0 ) THEN
*
* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1)
*
CALL DGEMV( 'Transpose', LASTV, LASTC, ONE, C, LDC, V,
$ INCV,
$ ZERO, WORK, 1 )
*
* C(1:lastv,1:lastc) := C(...) - v(1:lastv,1) * w(1:lastc,1)**T
*
CALL DGER( LASTV, LASTC, -TAU, V, INCV, WORK, 1, C, LDC )
END IF
ELSE
*
* Form C * H
*
IF( LASTV.GT.0 ) THEN
*
* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
*
CALL DGEMV( 'No transpose', LASTC, LASTV, ONE, C, LDC,
$ V, INCV, ZERO, WORK, 1 )
*
* C(1:lastc,1:lastv) := C(...) - w(1:lastc,1) * v(1:lastv,1)**T
*
CALL DGER( LASTC, LASTV, -TAU, WORK, 1, V, INCV, C, LDC )
END IF
END IF
RETURN
*
* End of DLARF
*
END
*> \brief \b DLARF1F applies an elementary reflector to a general rectangular
* matrix assuming v(1) = 1.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLARF1F + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* .. Scalar Arguments ..
* CHARACTER SIDE
* INTEGER INCV, LDC, M, N
* DOUBLE PRECISION TAU
* ..
* .. Array Arguments ..
* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLARF1F applies a real elementary reflector H to a real m by n matrix
*> C, from either the left or the right. H is represented in the form
*>
*> H = I - tau * v * v**T
*>
*> where tau is a real scalar and v is a real vector.
*>
*> If tau = 0, then H is taken to be the unit matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': form H * C
*> = 'R': form C * H
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C.
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is DOUBLE PRECISION array, dimension
*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
*> The vector v in the representation of H. V is not used if
*> TAU = 0. V(1) is not referenced or modified.
*> \endverbatim
*>
*> \param[in] INCV
*> \verbatim
*> INCV is INTEGER
*> The increment between elements of v. INCV <> 0.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION
*> The value tau in the representation of H.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (LDC,N)
*> On entry, the m by n matrix C.
*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
*> or C * H if SIDE = 'R'.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension
*> (N) if SIDE = 'L'
*> or (M) if SIDE = 'R'
*> \endverbatim
*
* To take advantage of the fact that v(1) = 1, we do the following
* v = [ 1 v_2 ]**T
* If SIDE='L'
* |-----|
* | C_1 |
* C =| C_2 |
* |-----|
* C_1\in\mathbb{R}^{1\times n}, C_2\in\mathbb{R}^{m-1\times n}
* So we compute:
* C = HC = (I - \tau vv**T)C
* = C - \tau vv**T C
* w = C**T v = [ C_1**T C_2**T ] [ 1 v_2 ]**T
* = C_1**T + C_2**T v ( DGEMM then DAXPY )
* C = C - \tau vv**T C
* = C - \tau vw**T
* Giving us C_1 = C_1 - \tau w**T ( DAXPY )
* and
* C_2 = C_2 - \tau v_2w**T ( DGER )
* If SIDE='R'
*
* C = [ C_1 C_2 ]
* C_1\in\mathbb{R}^{m\times 1}, C_2\in\mathbb{R}^{m\times n-1}
* So we compute:
* C = CH = C(I - \tau vv**T)
* = C - \tau Cvv**T
*
* w = Cv = [ C_1 C_2 ] [ 1 v_2 ]**T
* = C_1 + C_2v_2 ( DGEMM then DAXPY )
* C = C - \tau Cvv**T
* = C - \tau wv**T
* Giving us C_1 = C_1 - \tau w ( DAXPY )
* and
* C_2 = C_2 - \tau wv_2**T ( DGER )
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup larf
*
* =====================================================================
SUBROUTINE DLARF1F( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER SIDE
INTEGER INCV, LDC, M, N
DOUBLE PRECISION TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL APPLYLEFT
INTEGER I, LASTV, LASTC
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DGER, DAXPY, DSCAL
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILADLR, ILADLC
EXTERNAL LSAME, ILADLR, ILADLC
* ..
* .. Executable Statements ..
*
APPLYLEFT = LSAME( SIDE, 'L' )
LASTV = 1
LASTC = 0
IF( TAU.NE.ZERO ) THEN
! Set up variables for scanning V. LASTV begins pointing to the end
! of V.
IF( APPLYLEFT ) THEN
LASTV = M
ELSE
LASTV = N
END IF
IF( INCV.GT.0 ) THEN
I = 1 + (LASTV-1) * INCV
ELSE
I = 1
END IF
! Look for the last non-zero row in V.
! Since we are assuming that V(1) = 1, and it is not stored, so we
! shouldn't access it.
DO WHILE( LASTV.GT.1 .AND. V( I ).EQ.ZERO )
LASTV = LASTV - 1
I = I - INCV
END DO
IF( APPLYLEFT ) THEN
! Scan for the last non-zero column in C(1:lastv,:).
LASTC = ILADLC(LASTV, N, C, LDC)
ELSE
! Scan for the last non-zero row in C(:,1:lastv).
LASTC = ILADLR(M, LASTV, C, LDC)
END IF
END IF
IF( LASTC.EQ.0 ) THEN
RETURN
END IF
IF( APPLYLEFT ) THEN
*
* Form H * C
*
! Check if lastv = 1. This means v = 1, So we just need to compute
! C := HC = (1-\tau)C.
IF( LASTV.EQ.1 ) THEN
*
* C(1,1:lastc) := ( 1 - tau ) * C(1,1:lastc)
*
CALL DSCAL(LASTC, ONE - TAU, C, LDC)
ELSE
*
* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1)
*
! w(1:lastc,1) := C(2:lastv,1:lastc)**T * v(2:lastv,1)
CALL DGEMV( 'Transpose', LASTV-1, LASTC, ONE, C(1+1,1),
$ LDC, V(1+INCV), INCV, ZERO, WORK, 1)
! w(1:lastc,1) += C(1,1:lastc)**T * v(1,1) = C(1,1:lastc)**T
CALL DAXPY(LASTC, ONE, C, LDC, WORK, 1)
*
* C(1:lastv,1:lastc) := C(...) - tau * v(1:lastv,1) * w(1:lastc,1)**T
*
! C(1, 1:lastc) := C(...) - tau * v(1,1) * w(1:lastc,1)**T
! = C(...) - tau * w(1:lastc,1)**T
CALL DAXPY(LASTC, -TAU, WORK, 1, C, LDC)
! C(2:lastv,1:lastc) := C(...) - tau * v(2:lastv,1)*w(1:lastc,1)**T
CALL DGER(LASTV-1, LASTC, -TAU, V(1+INCV), INCV, WORK, 1,
$ C(1+1,1), LDC)
END IF
ELSE
*
* Form C * H
*
! Check if n = 1. This means v = 1, so we just need to compute
! C := CH = C(1-\tau).
IF( LASTV.EQ.1 ) THEN
*
* C(1:lastc,1) := ( 1 - tau ) * C(1:lastc,1)
*
CALL DSCAL(LASTC, ONE - TAU, C, 1)
ELSE
*
* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
*
! w(1:lastc,1) := C(1:lastc,2:lastv) * v(2:lastv,1)
CALL DGEMV( 'No transpose', LASTC, LASTV-1, ONE,
$ C(1,1+1), LDC, V(1+INCV), INCV, ZERO, WORK, 1 )
! w(1:lastc,1) += C(1:lastc,1) v(1,1) = C(1:lastc,1)
CALL DAXPY(LASTC, ONE, C, 1, WORK, 1)
*
* C(1:lastc,1:lastv) := C(...) - tau * w(1:lastc,1) * v(1:lastv,1)**T
*
! C(1:lastc,1) := C(...) - tau * w(1:lastc,1) * v(1,1)**T
! = C(...) - tau * w(1:lastc,1)
CALL DAXPY(LASTC, -TAU, WORK, 1, C, 1)
! C(1:lastc,2:lastv) := C(...) - tau * w(1:lastc,1) * v(2:lastv)**T
CALL DGER( LASTC, LASTV-1, -TAU, WORK, 1, V(1+INCV),
$ INCV, C(1,1+1), LDC )
END IF
END IF
RETURN
*
* End of DLARF1F
*
END
*> \brief \b DLARF1L applies an elementary reflector to a general rectangular
* matrix assuming v(lastv) = 1 where lastv is the last non-zero
* element
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLARF1L + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* .. Scalar Arguments ..
* CHARACTER SIDE
* INTEGER INCV, LDC, M, N
* DOUBLE PRECISION TAU
* ..
* .. Array Arguments ..
* DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLARF1L applies a real elementary reflector H to a real m by n matrix
*> C, from either the left or the right. H is represented in the form
*>
*> H = I - tau * v * v**T
*>
*> where tau is a real scalar and v is a real vector.
*>
*> If tau = 0, then H is taken to be the unit matrix.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': form H * C
*> = 'R': form C * H
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C.
*> \endverbatim
*>
*> \param[in] V
*> \verbatim
*> V is DOUBLE PRECISION array, dimension
*> (1 + (M-1)*abs(INCV)) if SIDE = 'L'
*> or (1 + (N-1)*abs(INCV)) if SIDE = 'R'
*> The vector v in the representation of H. V is not used if
*> TAU = 0.
*> \endverbatim
*>
*> \param[in] INCV
*> \verbatim
*> INCV is INTEGER
*> The increment between elements of v. INCV <> 0.
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION
*> The value tau in the representation of H.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (LDC,N)
*> On entry, the m by n matrix C.
*> On exit, C is overwritten by the matrix H * C if SIDE = 'L',
*> or C * H if SIDE = 'R'.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension
*> (N) if SIDE = 'L'
*> or (M) if SIDE = 'R'
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup larf
*
* =====================================================================
SUBROUTINE DLARF1L( SIDE, M, N, V, INCV, TAU, C, LDC, WORK )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER SIDE
INTEGER INCV, LDC, M, N
DOUBLE PRECISION TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION C( LDC, * ), V( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL APPLYLEFT
INTEGER I, FIRSTV, LASTV, LASTC
* ..
* .. External Subroutines ..
EXTERNAL DGEMV, DGER
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER ILADLR, ILADLC
EXTERNAL LSAME, ILADLR, ILADLC
* ..
* .. Executable Statements ..
*
APPLYLEFT = LSAME( SIDE, 'L' )
FIRSTV = 1
LASTC = 0
IF( TAU.NE.ZERO ) THEN
! Set up variables for scanning V. LASTV begins pointing to the end
! of V.
IF( APPLYLEFT ) THEN
LASTV = M
ELSE
LASTV = N
END IF
I = 1
! Look for the last non-zero row in V.
DO WHILE( LASTV.GT.FIRSTV .AND. V( I ).EQ.ZERO )
FIRSTV = FIRSTV + 1
I = I + INCV
END DO
IF( APPLYLEFT ) THEN
! Scan for the last non-zero column in C(1:lastv,:).
LASTC = ILADLC(LASTV, N, C, LDC)
ELSE
! Scan for the last non-zero row in C(:,1:lastv).
LASTC = ILADLR(M, LASTV, C, LDC)
END IF
END IF
IF( LASTC.EQ.0 ) THEN
RETURN
END IF
IF( APPLYLEFT ) THEN
*
* Form H * C
*
IF( LASTV.GT.0 ) THEN
! Check if m = 1. This means v = 1, So we just need to compute
! C := HC = (1-\tau)C.
IF( LASTV.EQ.FIRSTV ) THEN
CALL DSCAL(LASTC, ONE - TAU, C( FIRSTV, 1), LDC)
ELSE
*
* w(1:lastc,1) := C(1:lastv,1:lastc)**T * v(1:lastv,1)
*
! w(1:lastc,1) := C(1:lastv-1,1:lastc)**T * v(1:lastv-1,1)
CALL DGEMV( 'Transpose', LASTV-FIRSTV, LASTC, ONE,
$ C(FIRSTV,1), LDC, V(I), INCV, ZERO,
$ WORK, 1)
! w(1:lastc,1) += C(lastv,1:lastc)**T * v(lastv,1) = C(lastv,1:lastc)**T
CALL DAXPY(LASTC, ONE, C(LASTV,1), LDC, WORK, 1)
*
* C(1:lastv,1:lastc) := C(...) - tau * v(1:lastv,1) * w(1:lastc,1)**T
*
! C(lastv, 1:lastc) := C(...) - tau * v(lastv,1) * w(1:lastc,1)**T
! = C(...) - tau * w(1:lastc,1)**T
CALL DAXPY(LASTC, -TAU, WORK, 1, C(LASTV,1), LDC)
! C(1:lastv-1,1:lastc) := C(...) - tau * v(1:lastv-1,1)*w(1:lastc,1)**T
CALL DGER(LASTV-FIRSTV, LASTC, -TAU, V(I), INCV,
$ WORK, 1, C(FIRSTV,1), LDC)
END IF
END IF
ELSE
*
* Form C * H
*
IF( LASTV.GT.0 ) THEN
! Check if n = 1. This means v = 1, so we just need to compute
! C := CH = C(1-\tau).
IF( LASTV.EQ.FIRSTV ) THEN
CALL DSCAL(LASTC, ONE - TAU, C, 1)
ELSE
*
* w(1:lastc,1) := C(1:lastc,1:lastv) * v(1:lastv,1)
*
! w(1:lastc,1) := C(1:lastc,1:lastv-1) * v(1:lastv-1,1)
CALL DGEMV( 'No transpose', LASTC, LASTV-FIRSTV,
$ ONE, C(1,FIRSTV), LDC, V(I), INCV, ZERO, WORK, 1 )
! w(1:lastc,1) += C(1:lastc,lastv) * v(lastv,1) = C(1:lastc,lastv)
CALL DAXPY(LASTC, ONE, C(1,LASTV), 1, WORK, 1)
*
* C(1:lastc,1:lastv) := C(...) - tau * w(1:lastc,1) * v(1:lastv,1)**T
*
! C(1:lastc,lastv) := C(...) - tau * w(1:lastc,1) * v(lastv,1)**T
! = C(...) - tau * w(1:lastc,1)
CALL DAXPY(LASTC, -TAU, WORK, 1, C(1,LASTV), 1)
! C(1:lastc,1:lastv-1) := C(...) - tau * w(1:lastc,1) * v(1:lastv-1)**T
CALL DGER( LASTC, LASTV-FIRSTV, -TAU, WORK, 1, V(I),
$ INCV, C(1,FIRSTV), LDC )
END IF
END IF
END IF
RETURN
*
* End of DLARF1L
*
END
*> \brief \b DLARFG generates an elementary reflector (Householder matrix).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLARFG + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* DOUBLE PRECISION ALPHA, TAU
* ..
* .. Array Arguments ..
* DOUBLE PRECISION X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLARFG generates a real elementary reflector H of order n, such
*> that
*>
*> H * ( alpha ) = ( beta ), H**T * H = I.
*> ( x ) ( 0 )
*>
*> where alpha and beta are scalars, and x is an (n-1)-element real
*> vector. H is represented in the form
*>
*> H = I - tau * ( 1 ) * ( 1 v**T ) ,
*> ( v )
*>
*> where tau is a real scalar and v is a real (n-1)-element
*> vector.
*>
*> If the elements of x are all zero, then tau = 0 and H is taken to be
*> the unit matrix.
*>
*> Otherwise 1 <= tau <= 2.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the elementary reflector.
*> \endverbatim
*>
*> \param[in,out] ALPHA
*> \verbatim
*> ALPHA is DOUBLE PRECISION
*> On entry, the value alpha.
*> On exit, it is overwritten with the value beta.
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is DOUBLE PRECISION array, dimension
*> (1+(N-2)*abs(INCX))
*> On entry, the vector x.
*> On exit, it is overwritten with the vector v.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between elements of X. INCX > 0.
*> \endverbatim
*>
*> \param[out] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION
*> The value tau.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup larfg
*
* =====================================================================
SUBROUTINE DLARFG( N, ALPHA, X, INCX, TAU )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INCX, N
DOUBLE PRECISION ALPHA, TAU
* ..
* .. Array Arguments ..
DOUBLE PRECISION X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER J, KNT
DOUBLE PRECISION BETA, RSAFMN, SAFMIN, XNORM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH, DLAPY2, DNRM2
EXTERNAL DLAMCH, DLAPY2, DNRM2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN
* ..
* .. External Subroutines ..
EXTERNAL DSCAL
* ..
* .. Executable Statements ..
*
IF( N.LE.1 ) THEN
TAU = ZERO
RETURN
END IF
*
XNORM = DNRM2( N-1, X, INCX )
*
IF( XNORM.EQ.ZERO ) THEN
*
* H = I
*
TAU = ZERO
ELSE
*
* general case
*
BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
SAFMIN = DLAMCH( 'S' ) / DLAMCH( 'E' )
KNT = 0
IF( ABS( BETA ).LT.SAFMIN ) THEN
*
* XNORM, BETA may be inaccurate; scale X and recompute them
*
RSAFMN = ONE / SAFMIN
10 CONTINUE
KNT = KNT + 1
CALL DSCAL( N-1, RSAFMN, X, INCX )
BETA = BETA*RSAFMN
ALPHA = ALPHA*RSAFMN
IF( (ABS( BETA ).LT.SAFMIN) .AND. (KNT .LT. 20) )
$ GO TO 10
*
* New BETA is at most 1, at least SAFMIN
*
XNORM = DNRM2( N-1, X, INCX )
BETA = -SIGN( DLAPY2( ALPHA, XNORM ), ALPHA )
END IF
TAU = ( BETA-ALPHA ) / BETA
CALL DSCAL( N-1, ONE / ( ALPHA-BETA ), X, INCX )
*
* If ALPHA is subnormal, it may lose relative accuracy
*
DO 20 J = 1, KNT
BETA = BETA*SAFMIN
20 CONTINUE
ALPHA = BETA
END IF
*
RETURN
*
* End of DLARFG
*
END
!> \brief \b DLARTG generates a plane rotation with real cosine and real sine.
!
! =========== DOCUMENTATION ===========
!
! Online html documentation available at
! http://www.netlib.org/lapack/explore-html/
!
! Definition:
! ===========
!
! SUBROUTINE DLARTG( F, G, C, S, R )
!
! .. Scalar Arguments ..
! REAL(wp) C, F, G, R, S
! ..
!
!> \par Purpose:
! =============
!>
!> \verbatim
!>
!> DLARTG generates a plane rotation so that
!>
!> [ C S ] . [ F ] = [ R ]
!> [ -S C ] [ G ] [ 0 ]
!>
!> where C**2 + S**2 = 1.
!>
!> The mathematical formulas used for C and S are
!> R = sign(F) * sqrt(F**2 + G**2)
!> C = F / R
!> S = G / R
!> Hence C >= 0. The algorithm used to compute these quantities
!> incorporates scaling to avoid overflow or underflow in computing the
!> square root of the sum of squares.
!>
!> This version is discontinuous in R at F = 0 but it returns the same
!> C and S as ZLARTG for complex inputs (F,0) and (G,0).
!>
!> This is a more accurate version of the BLAS1 routine DROTG,
!> with the following other differences:
!> F and G are unchanged on return.
!> If G=0, then C=1 and S=0.
!> If F=0 and (G .ne. 0), then C=0 and S=sign(1,G) without doing any
!> floating point operations (saves work in DBDSQR when
!> there are zeros on the diagonal).
!>
!> Below, wp=>dp stands for double precision from LA_CONSTANTS module.
!> \endverbatim
!
! Arguments:
! ==========
!
!> \param[in] F
!> \verbatim
!> F is REAL(wp)
!> The first component of vector to be rotated.
!> \endverbatim
!>
!> \param[in] G
!> \verbatim
!> G is REAL(wp)
!> The second component of vector to be rotated.
!> \endverbatim
!>
!> \param[out] C
!> \verbatim
!> C is REAL(wp)
!> The cosine of the rotation.
!> \endverbatim
!>
!> \param[out] S
!> \verbatim
!> S is REAL(wp)
!> The sine of the rotation.
!> \endverbatim
!>
!> \param[out] R
!> \verbatim
!> R is REAL(wp)
!> The nonzero component of the rotated vector.
!> \endverbatim
!
! Authors:
! ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \date July 2016
!
!> \ingroup lartg
!
!> \par Contributors:
! ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!
!> \par Further Details:
! =====================
!>
!> \verbatim
!>
!> Anderson E. (2017)
!> Algorithm 978: Safe Scaling in the Level 1 BLAS
!> ACM Trans Math Softw 44:1--28
!> https://doi.org/10.1145/3061665
!>
!> \endverbatim
!
subroutine DLARTG( f, g, c, s, r )
use LA_CONSTANTS, &
only: wp=>dp, zero=>dzero, half=>dhalf, one=>done, &
safmin=>dsafmin, safmax=>dsafmax
!
! -- LAPACK auxiliary routine --
! -- LAPACK is a software package provided by Univ. of Tennessee, --
! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
! February 2021
!
! .. Scalar Arguments ..
real(wp) :: c, f, g, r, s
! ..
! .. Local Scalars ..
real(wp) :: d, f1, fs, g1, gs, u, rtmin, rtmax
! ..
! .. Intrinsic Functions ..
intrinsic :: abs, sign, sqrt
! ..
! .. Constants ..
rtmin = sqrt( safmin )
rtmax = sqrt( safmax/2 )
! ..
! .. Executable Statements ..
!
f1 = abs( f )
g1 = abs( g )
if( g == zero ) then
c = one
s = zero
r = f
else if( f == zero ) then
c = zero
s = sign( one, g )
r = g1
else if( f1 > rtmin .and. f1 < rtmax .and. &
g1 > rtmin .and. g1 < rtmax ) then
d = sqrt( f*f + g*g )
c = f1 / d
r = sign( d, f )
s = g / r
else
u = min( safmax, max( safmin, f1, g1 ) )
fs = f / u
gs = g / u
d = sqrt( fs*fs + gs*gs )
c = abs( fs ) / d
r = sign( d, f )
s = gs / r
r = r*u
end if
return
end subroutine
*> \brief \b DLASET initializes the off-diagonal elements and the diagonal elements of a matrix to given values.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLASET + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
*
* .. Scalar Arguments ..
* CHARACTER UPLO
* INTEGER LDA, M, N
* DOUBLE PRECISION ALPHA, BETA
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLASET initializes an m-by-n matrix A to BETA on the diagonal and
*> ALPHA on the offdiagonals.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies the part of the matrix A to be set.
*> = 'U': Upper triangular part is set; the strictly lower
*> triangular part of A is not changed.
*> = 'L': Lower triangular part is set; the strictly upper
*> triangular part of A is not changed.
*> Otherwise: All of the matrix A is set.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] ALPHA
*> \verbatim
*> ALPHA is DOUBLE PRECISION
*> The constant to which the offdiagonal elements are to be set.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*> BETA is DOUBLE PRECISION
*> The constant to which the diagonal elements are to be set.
*> \endverbatim
*>
*> \param[out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On exit, the leading m-by-n submatrix of A is set as follows:
*>
*> if UPLO = 'U', A(i,j) = ALPHA, 1<=i<=j-1, 1<=j<=n,
*> if UPLO = 'L', A(i,j) = ALPHA, j+1<=i<=m, 1<=j<=n,
*> otherwise, A(i,j) = ALPHA, 1<=i<=m, 1<=j<=n, i.ne.j,
*>
*> and, for all UPLO, A(i,i) = BETA, 1<=i<=min(m,n).
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup laset
*
* =====================================================================
SUBROUTINE DLASET( UPLO, M, N, ALPHA, BETA, A, LDA )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER UPLO
INTEGER LDA, M, N
DOUBLE PRECISION ALPHA, BETA
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, J
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC MIN
* ..
* .. Executable Statements ..
*
IF( LSAME( UPLO, 'U' ) ) THEN
*
* Set the strictly upper triangular or trapezoidal part of the
* array to ALPHA.
*
DO 20 J = 2, N
DO 10 I = 1, MIN( J-1, M )
A( I, J ) = ALPHA
10 CONTINUE
20 CONTINUE
*
ELSE IF( LSAME( UPLO, 'L' ) ) THEN
*
* Set the strictly lower triangular or trapezoidal part of the
* array to ALPHA.
*
DO 40 J = 1, MIN( M, N )
DO 30 I = J + 1, M
A( I, J ) = ALPHA
30 CONTINUE
40 CONTINUE
*
ELSE
*
* Set the leading m-by-n submatrix to ALPHA.
*
DO 60 J = 1, N
DO 50 I = 1, M
A( I, J ) = ALPHA
50 CONTINUE
60 CONTINUE
END IF
*
* Set the first min(M,N) diagonal elements to BETA.
*
DO 70 I = 1, MIN( M, N )
A( I, I ) = BETA
70 CONTINUE
*
RETURN
*
* End of DLASET
*
END
!> \brief \b DLASSQ updates a sum of squares represented in scaled form.
!
! =========== DOCUMENTATION ===========
!
! Online html documentation available at
! http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download DLASSQ + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
! Definition:
! ===========
!
! SUBROUTINE DLASSQ( N, X, INCX, SCALE, SUMSQ )
!
! .. Scalar Arguments ..
! INTEGER INCX, N
! DOUBLE PRECISION SCALE, SUMSQ
! ..
! .. Array Arguments ..
! DOUBLE PRECISION X( * )
! ..
!
!
!> \par Purpose:
! =============
!>
!> \verbatim
!>
!> DLASSQ returns the values scale_out and sumsq_out such that
!>
!> (scale_out**2)*sumsq_out = x( 1 )**2 +...+ x( n )**2 + (scale**2)*sumsq,
!>
!> where x( i ) = X( 1 + ( i - 1 )*INCX ). The value of sumsq is
!> assumed to be non-negative.
!>
!> scale and sumsq must be supplied in SCALE and SUMSQ and
!> scale_out and sumsq_out are overwritten on SCALE and SUMSQ respectively.
!>
!> \endverbatim
!
! Arguments:
! ==========
!
!> \param[in] N
!> \verbatim
!> N is INTEGER
!> The number of elements to be used from the vector x.
!> \endverbatim
!>
!> \param[in] X
!> \verbatim
!> X is DOUBLE PRECISION array, dimension (1+(N-1)*abs(INCX))
!> The vector for which a scaled sum of squares is computed.
!> x( i ) = X( 1 + ( i - 1 )*INCX ), 1 <= i <= n.
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!> INCX is INTEGER
!> The increment between successive values of the vector x.
!> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n
!> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n
!> If INCX = 0, x isn't a vector so there is no need to call
!> this subroutine. If you call it anyway, it will count x(1)
!> in the vector norm N times.
!> \endverbatim
!>
!> \param[in,out] SCALE
!> \verbatim
!> SCALE is DOUBLE PRECISION
!> On entry, the value scale in the equation above.
!> On exit, SCALE is overwritten by scale_out, the scaling factor
!> for the sum of squares.
!> \endverbatim
!>
!> \param[in,out] SUMSQ
!> \verbatim
!> SUMSQ is DOUBLE PRECISION
!> On entry, the value sumsq in the equation above.
!> On exit, SUMSQ is overwritten by sumsq_out, the basic sum of
!> squares from which scale_out has been factored out.
!> \endverbatim
!
! Authors:
! ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \par Contributors:
! ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!> Nick Papior, Technical University of Denmark, DK
!
!> \par Further Details:
! =====================
!>
!> \verbatim
!>
!> Anderson E. (2017)
!> Algorithm 978: Safe Scaling in the Level 1 BLAS
!> ACM Trans Math Softw 44:1--28
!> https://doi.org/10.1145/3061665
!>
!> Blue, James L. (1978)
!> A Portable Fortran Program to Find the Euclidean Norm of a Vector
!> ACM Trans Math Softw 4:15--23
!> https://doi.org/10.1145/355769.355771
!>
!> \endverbatim
!
!> \ingroup lassq
!
! =====================================================================
subroutine DLASSQ( n, x, incx, scale, sumsq )
use LA_CONSTANTS, &
only: wp=>dp, zero=>dzero, one=>done, &
sbig=>dsbig, ssml=>dssml, tbig=>dtbig, tsml=>dtsml
use LA_XISNAN
!
! -- LAPACK auxiliary routine --
! -- LAPACK is a software package provided by Univ. of Tennessee, --
! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!
! .. Scalar Arguments ..
integer :: incx, n
real(wp) :: scale, sumsq
! ..
! .. Array Arguments ..
real(wp) :: x(*)
! ..
! .. Local Scalars ..
integer :: i, ix
logical :: notbig
real(wp) :: abig, amed, asml, ax, ymax, ymin
! ..
!
! Quick return if possible
!
if( LA_ISNAN(scale) .or. LA_ISNAN(sumsq) ) return
if( sumsq == zero ) scale = one
if( scale == zero ) then
scale = one
sumsq = zero
end if
if (n <= 0) then
return
end if
!
! Compute the sum of squares in 3 accumulators:
! abig -- sums of squares scaled down to avoid overflow
! asml -- sums of squares scaled up to avoid underflow
! amed -- sums of squares that do not require scaling
! The thresholds and multipliers are
! tbig -- values bigger than this are scaled down by sbig
! tsml -- values smaller than this are scaled up by ssml
!
notbig = .true.
asml = zero
amed = zero
abig = zero
ix = 1
if( incx < 0 ) ix = 1 - (n-1)*incx
do i = 1, n
ax = abs(x(ix))
if (ax > tbig) then
abig = abig + (ax*sbig)**2
notbig = .false.
else if (ax < tsml) then
if (notbig) asml = asml + (ax*ssml)**2
else
amed = amed + ax**2
end if
ix = ix + incx
end do
!
! Put the existing sum of squares into one of the accumulators
!
if( sumsq > zero ) then
ax = scale*sqrt( sumsq )
if (ax > tbig) then
if (scale > one) then
scale = scale * sbig
abig = abig + scale * (scale * sumsq)
else
! sumsq > tbig^2 => (sbig * (sbig * sumsq)) is representable
abig = abig + scale * (scale * (sbig * (sbig * sumsq)))
end if
else if (ax < tsml) then
if (notbig) then
if (scale < one) then
scale = scale * ssml
asml = asml + scale * (scale * sumsq)
else
! sumsq < tsml^2 => (ssml * (ssml * sumsq)) is representable
asml = asml + scale * (scale * (ssml * (ssml * sumsq)))
end if
end if
else
amed = amed + scale * (scale * sumsq)
end if
end if
!
! Combine abig and amed or amed and asml if more than one
! accumulator was used.
!
if (abig > zero) then
!
! Combine abig and amed if abig > 0.
!
if (amed > zero .or. LA_ISNAN(amed)) then
abig = abig + (amed*sbig)*sbig
end if
scale = one / sbig
sumsq = abig
else if (asml > zero) then
!
! Combine amed and asml if asml > 0.
!
if (amed > zero .or. LA_ISNAN(amed)) then
amed = sqrt(amed)
asml = sqrt(asml) / ssml
if (asml > amed) then
ymin = amed
ymax = asml
else
ymin = asml
ymax = amed
end if
scale = one
sumsq = ymax**2*( one + (ymin/ymax)**2 )
else
scale = one / ssml
sumsq = asml
end if
else
!
! Otherwise all values are mid-range or zero
!
scale = one
sumsq = amed
end if
return
end subroutine
*> \brief \b DLASV2 computes the singular value decomposition of a 2-by-2 triangular matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLASV2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )
*
* .. Scalar Arguments ..
* DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLASV2 computes the singular value decomposition of a 2-by-2
*> triangular matrix
*> [ F G ]
*> [ 0 H ].
*> On return, abs(SSMAX) is the larger singular value, abs(SSMIN) is the
*> smaller singular value, and (CSL,SNL) and (CSR,SNR) are the left and
*> right singular vectors for abs(SSMAX), giving the decomposition
*>
*> [ CSL SNL ] [ F G ] [ CSR -SNR ] = [ SSMAX 0 ]
*> [-SNL CSL ] [ 0 H ] [ SNR CSR ] [ 0 SSMIN ].
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] F
*> \verbatim
*> F is DOUBLE PRECISION
*> The (1,1) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[in] G
*> \verbatim
*> G is DOUBLE PRECISION
*> The (1,2) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[in] H
*> \verbatim
*> H is DOUBLE PRECISION
*> The (2,2) element of the 2-by-2 matrix.
*> \endverbatim
*>
*> \param[out] SSMIN
*> \verbatim
*> SSMIN is DOUBLE PRECISION
*> abs(SSMIN) is the smaller singular value.
*> \endverbatim
*>
*> \param[out] SSMAX
*> \verbatim
*> SSMAX is DOUBLE PRECISION
*> abs(SSMAX) is the larger singular value.
*> \endverbatim
*>
*> \param[out] SNL
*> \verbatim
*> SNL is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[out] CSL
*> \verbatim
*> CSL is DOUBLE PRECISION
*> The vector (CSL, SNL) is a unit left singular vector for the
*> singular value abs(SSMAX).
*> \endverbatim
*>
*> \param[out] SNR
*> \verbatim
*> SNR is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[out] CSR
*> \verbatim
*> CSR is DOUBLE PRECISION
*> The vector (CSR, SNR) is a unit right singular vector for the
*> singular value abs(SSMAX).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup lasv2
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Any input parameter may be aliased with any output parameter.
*>
*> Barring over/underflow and assuming a guard digit in subtraction, all
*> output quantities are correct to within a few units in the last
*> place (ulps).
*>
*> In IEEE arithmetic, the code works correctly if one matrix element is
*> infinite.
*>
*> Overflow will not occur unless the largest singular value itself
*> overflows or is within a few ulps of overflow.
*>
*> Underflow is harmless if underflow is gradual. Otherwise, results
*> may correspond to a matrix modified by perturbations of size near
*> the underflow threshold.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DLASV2( F, G, H, SSMIN, SSMAX, SNR, CSR, SNL, CSL )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
DOUBLE PRECISION CSL, CSR, F, G, H, SNL, SNR, SSMAX, SSMIN
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D0 )
DOUBLE PRECISION HALF
PARAMETER ( HALF = 0.5D0 )
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D0 )
DOUBLE PRECISION TWO
PARAMETER ( TWO = 2.0D0 )
DOUBLE PRECISION FOUR
PARAMETER ( FOUR = 4.0D0 )
* ..
* .. Local Scalars ..
LOGICAL GASMAL, SWAP
INTEGER PMAX
DOUBLE PRECISION A, CLT, CRT, D, FA, FT, GA, GT, HA, HT, L, M,
$ MM, R, S, SLT, SRT, T, TEMP, TSIGN, TT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SIGN, SQRT
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. Executable Statements ..
*
FT = F
FA = ABS( FT )
HT = H
HA = ABS( H )
*
* PMAX points to the maximum absolute element of matrix
* PMAX = 1 if F largest in absolute values
* PMAX = 2 if G largest in absolute values
* PMAX = 3 if H largest in absolute values
*
PMAX = 1
SWAP = ( HA.GT.FA )
IF( SWAP ) THEN
PMAX = 3
TEMP = FT
FT = HT
HT = TEMP
TEMP = FA
FA = HA
HA = TEMP
*
* Now FA .ge. HA
*
END IF
GT = G
GA = ABS( GT )
IF( GA.EQ.ZERO ) THEN
*
* Diagonal matrix
*
SSMIN = HA
SSMAX = FA
CLT = ONE
CRT = ONE
SLT = ZERO
SRT = ZERO
ELSE
GASMAL = .TRUE.
IF( GA.GT.FA ) THEN
PMAX = 2
IF( ( FA / GA ).LT.DLAMCH( 'EPS' ) ) THEN
*
* Case of very large GA
*
GASMAL = .FALSE.
SSMAX = GA
IF( HA.GT.ONE ) THEN
SSMIN = FA / ( GA / HA )
ELSE
SSMIN = ( FA / GA )*HA
END IF
CLT = ONE
SLT = HT / GT
SRT = ONE
CRT = FT / GT
END IF
END IF
IF( GASMAL ) THEN
*
* Normal case
*
D = FA - HA
IF( D.EQ.FA ) THEN
*
* Copes with infinite F or H
*
L = ONE
ELSE
L = D / FA
END IF
*
* Note that 0 .le. L .le. 1
*
M = GT / FT
*
* Note that abs(M) .le. 1/macheps
*
T = TWO - L
*
* Note that T .ge. 1
*
MM = M*M
TT = T*T
S = SQRT( TT+MM )
*
* Note that 1 .le. S .le. 1 + 1/macheps
*
IF( L.EQ.ZERO ) THEN
R = ABS( M )
ELSE
R = SQRT( L*L+MM )
END IF
*
* Note that 0 .le. R .le. 1 + 1/macheps
*
A = HALF*( S+R )
*
* Note that 1 .le. A .le. 1 + abs(M)
*
SSMIN = HA / A
SSMAX = FA*A
IF( MM.EQ.ZERO ) THEN
*
* Note that M is very tiny
*
IF( L.EQ.ZERO ) THEN
T = SIGN( TWO, FT )*SIGN( ONE, GT )
ELSE
T = GT / SIGN( D, FT ) + M / T
END IF
ELSE
T = ( M / ( S+T )+M / ( R+L ) )*( ONE+A )
END IF
L = SQRT( T*T+FOUR )
CRT = TWO / L
SRT = T / L
CLT = ( CRT+SRT*M ) / A
SLT = ( HT / FT )*SRT / A
END IF
END IF
IF( SWAP ) THEN
CSL = SRT
SNL = CRT
CSR = SLT
SNR = CLT
ELSE
CSL = CLT
SNL = SLT
CSR = CRT
SNR = SRT
END IF
*
* Correct signs of SSMAX and SSMIN
*
IF( PMAX.EQ.1 )
$ TSIGN = SIGN( ONE, CSR )*SIGN( ONE, CSL )*SIGN( ONE, F )
IF( PMAX.EQ.2 )
$ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, CSL )*SIGN( ONE, G )
IF( PMAX.EQ.3 )
$ TSIGN = SIGN( ONE, SNR )*SIGN( ONE, SNL )*SIGN( ONE, H )
SSMAX = SIGN( SSMAX, TSIGN )
SSMIN = SIGN( SSMIN, TSIGN*SIGN( ONE, F )*SIGN( ONE, H ) )
RETURN
*
* End of DLASV2
*
END
*> \brief \b DLASWP performs a series of row interchanges on a general rectangular matrix.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLASWP + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
*
* .. Scalar Arguments ..
* INTEGER INCX, K1, K2, LDA, N
* ..
* .. Array Arguments ..
* INTEGER IPIV( * )
* DOUBLE PRECISION A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLASWP performs a series of row interchanges on the matrix A.
*> One row interchange is initiated for each of rows K1 through K2 of A.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the matrix of column dimension N to which the row
*> interchanges will be applied.
*> On exit, the permuted matrix.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A.
*> \endverbatim
*>
*> \param[in] K1
*> \verbatim
*> K1 is INTEGER
*> The first element of IPIV for which a row interchange will
*> be done.
*> \endverbatim
*>
*> \param[in] K2
*> \verbatim
*> K2 is INTEGER
*> (K2-K1+1) is the number of elements of IPIV for which a row
*> interchange will be done.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (K1+(K2-K1)*abs(INCX))
*> The vector of pivot indices. Only the elements in positions
*> K1 through K1+(K2-K1)*abs(INCX) of IPIV are accessed.
*> IPIV(K1+(K-K1)*abs(INCX)) = L implies rows K and L are to be
*> interchanged.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between successive values of IPIV. If INCX
*> is negative, the pivots are applied in reverse order.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup laswp
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> Modified by
*> R. C. Whaley, Computer Science Dept., Univ. of Tenn., Knoxville, USA
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DLASWP( N, A, LDA, K1, K2, IPIV, INCX )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INCX, K1, K2, LDA, N
* ..
* .. Array Arguments ..
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * )
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I, I1, I2, INC, IP, IX, IX0, J, K, N32
DOUBLE PRECISION TEMP
* ..
* .. Executable Statements ..
*
* Interchange row I with row IPIV(K1+(I-K1)*abs(INCX)) for each of rows
* K1 through K2.
*
IF( INCX.GT.0 ) THEN
IX0 = K1
I1 = K1
I2 = K2
INC = 1
ELSE IF( INCX.LT.0 ) THEN
IX0 = K1 + ( K1-K2 )*INCX
I1 = K2
I2 = K1
INC = -1
ELSE
RETURN
END IF
*
N32 = ( N / 32 )*32
IF( N32.NE.0 ) THEN
DO 30 J = 1, N32, 32
IX = IX0
DO 20 I = I1, I2, INC
IP = IPIV( IX )
IF( IP.NE.I ) THEN
DO 10 K = J, J + 31
TEMP = A( I, K )
A( I, K ) = A( IP, K )
A( IP, K ) = TEMP
10 CONTINUE
END IF
IX = IX + INCX
20 CONTINUE
30 CONTINUE
END IF
IF( N32.NE.N ) THEN
N32 = N32 + 1
IX = IX0
DO 50 I = I1, I2, INC
IP = IPIV( IX )
IF( IP.NE.I ) THEN
DO 40 K = N32, N
TEMP = A( I, K )
A( I, K ) = A( IP, K )
A( IP, K ) = TEMP
40 CONTINUE
END IF
IX = IX + INCX
50 CONTINUE
END IF
*
RETURN
*
* End of DLASWP
*
END
*> \brief \b DLATDF uses the LU factorization of the n-by-n matrix computed by sgetc2 and computes a contribution to the reciprocal Dif-estimate.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLATDF + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV,
* JPIV )
*
* .. Scalar Arguments ..
* INTEGER IJOB, LDZ, N
* DOUBLE PRECISION RDSCAL, RDSUM
* ..
* .. Array Arguments ..
* INTEGER IPIV( * ), JPIV( * )
* DOUBLE PRECISION RHS( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLATDF uses the LU factorization of the n-by-n matrix Z computed by
*> DGETC2 and computes a contribution to the reciprocal Dif-estimate
*> by solving Z * x = b for x, and choosing the r.h.s. b such that
*> the norm of x is as large as possible. On entry RHS = b holds the
*> contribution from earlier solved sub-systems, and on return RHS = x.
*>
*> The factorization of Z returned by DGETC2 has the form Z = P*L*U*Q,
*> where P and Q are permutation matrices. L is lower triangular with
*> unit diagonal elements and U is upper triangular.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] IJOB
*> \verbatim
*> IJOB is INTEGER
*> IJOB = 2: First compute an approximative null-vector e
*> of Z using DGECON, e is normalized and solve for
*> Zx = +-e - f with the sign giving the greater value
*> of 2-norm(x). About 5 times as expensive as Default.
*> IJOB .ne. 2: Local look ahead strategy where all entries of
*> the r.h.s. b is chosen as either +1 or -1 (Default).
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Z.
*> \endverbatim
*>
*> \param[in] Z
*> \verbatim
*> Z is DOUBLE PRECISION array, dimension (LDZ, N)
*> On entry, the LU part of the factorization of the n-by-n
*> matrix Z computed by DGETC2: Z = P * L * U * Q
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDA >= max(1, N).
*> \endverbatim
*>
*> \param[in,out] RHS
*> \verbatim
*> RHS is DOUBLE PRECISION array, dimension (N)
*> On entry, RHS contains contributions from other subsystems.
*> On exit, RHS contains the solution of the subsystem with
*> entries according to the value of IJOB (see above).
*> \endverbatim
*>
*> \param[in,out] RDSUM
*> \verbatim
*> RDSUM is DOUBLE PRECISION
*> On entry, the sum of squares of computed contributions to
*> the Dif-estimate under computation by DTGSYL, where the
*> scaling factor RDSCAL (see below) has been factored out.
*> On exit, the corresponding sum of squares updated with the
*> contributions from the current sub-system.
*> If TRANS = 'T' RDSUM is not touched.
*> NOTE: RDSUM only makes sense when DTGSY2 is called by STGSYL.
*> \endverbatim
*>
*> \param[in,out] RDSCAL
*> \verbatim
*> RDSCAL is DOUBLE PRECISION
*> On entry, scaling factor used to prevent overflow in RDSUM.
*> On exit, RDSCAL is updated w.r.t. the current contributions
*> in RDSUM.
*> If TRANS = 'T', RDSCAL is not touched.
*> NOTE: RDSCAL only makes sense when DTGSY2 is called by
*> DTGSYL.
*> \endverbatim
*>
*> \param[in] IPIV
*> \verbatim
*> IPIV is INTEGER array, dimension (N).
*> The pivot indices; for 1 <= i <= N, row i of the
*> matrix has been interchanged with row IPIV(i).
*> \endverbatim
*>
*> \param[in] JPIV
*> \verbatim
*> JPIV is INTEGER array, dimension (N).
*> The pivot indices; for 1 <= j <= N, column j of the
*> matrix has been interchanged with column JPIV(j).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup latdf
*
*> \par Further Details:
* =====================
*>
*> This routine is a further developed implementation of algorithm
*> BSOLVE in [1] using complete pivoting in the LU factorization.
*
*> \par Contributors:
* ==================
*>
*> Bo Kagstrom and Peter Poromaa, Department of Computing Science,
*> Umea University, S-901 87 Umea, Sweden.
*
*> \par References:
* ================
*>
*> \verbatim
*>
*>
*> [1] Bo Kagstrom and Lars Westin,
*> Generalized Schur Methods with Condition Estimators for
*> Solving the Generalized Sylvester Equation, IEEE Transactions
*> on Automatic Control, Vol. 34, No. 7, July 1989, pp 745-751.
*>
*> [2] Peter Poromaa,
*> On Efficient and Robust Estimators for the Separation
*> between two Regular Matrix Pairs with Applications in
*> Condition Estimation. Report IMINF-95.05, Departement of
*> Computing Science, Umea University, S-901 87 Umea, Sweden, 1995.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DLATDF( IJOB, N, Z, LDZ, RHS, RDSUM, RDSCAL, IPIV,
$ JPIV )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER IJOB, LDZ, N
DOUBLE PRECISION RDSCAL, RDSUM
* ..
* .. Array Arguments ..
INTEGER IPIV( * ), JPIV( * )
DOUBLE PRECISION RHS( * ), Z( LDZ, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
INTEGER MAXDIM
PARAMETER ( MAXDIM = 8 )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, INFO, J, K
DOUBLE PRECISION BM, BP, PMONE, SMINU, SPLUS, TEMP
* ..
* .. Local Arrays ..
INTEGER IWORK( MAXDIM )
DOUBLE PRECISION WORK( 4*MAXDIM ), XM( MAXDIM ), XP( MAXDIM )
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DGECON, DGESC2, DLASSQ,
$ DLASWP,
$ DSCAL
* ..
* .. External Functions ..
DOUBLE PRECISION DASUM, DDOT
EXTERNAL DASUM, DDOT
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, SQRT
* ..
* .. Executable Statements ..
*
IF( IJOB.NE.2 ) THEN
*
* Apply permutations IPIV to RHS
*
CALL DLASWP( 1, RHS, LDZ, 1, N-1, IPIV, 1 )
*
* Solve for L-part choosing RHS either to +1 or -1.
*
PMONE = -ONE
*
DO 10 J = 1, N - 1
BP = RHS( J ) + ONE
BM = RHS( J ) - ONE
SPLUS = ONE
*
* Look-ahead for L-part RHS(1:N-1) = + or -1, SPLUS and
* SMIN computed more efficiently than in BSOLVE [1].
*
SPLUS = SPLUS + DDOT( N-J, Z( J+1, J ), 1, Z( J+1, J ),
$ 1 )
SMINU = DDOT( N-J, Z( J+1, J ), 1, RHS( J+1 ), 1 )
SPLUS = SPLUS*RHS( J )
IF( SPLUS.GT.SMINU ) THEN
RHS( J ) = BP
ELSE IF( SMINU.GT.SPLUS ) THEN
RHS( J ) = BM
ELSE
*
* In this case the updating sums are equal and we can
* choose RHS(J) +1 or -1. The first time this happens
* we choose -1, thereafter +1. This is a simple way to
* get good estimates of matrices like Byers well-known
* example (see [1]). (Not done in BSOLVE.)
*
RHS( J ) = RHS( J ) + PMONE
PMONE = ONE
END IF
*
* Compute the remaining r.h.s.
*
TEMP = -RHS( J )
CALL DAXPY( N-J, TEMP, Z( J+1, J ), 1, RHS( J+1 ), 1 )
*
10 CONTINUE
*
* Solve for U-part, look-ahead for RHS(N) = +-1. This is not done
* in BSOLVE and will hopefully give us a better estimate because
* any ill-conditioning of the original matrix is transferred to U
* and not to L. U(N, N) is an approximation to sigma_min(LU).
*
CALL DCOPY( N-1, RHS, 1, XP, 1 )
XP( N ) = RHS( N ) + ONE
RHS( N ) = RHS( N ) - ONE
SPLUS = ZERO
SMINU = ZERO
DO 30 I = N, 1, -1
TEMP = ONE / Z( I, I )
XP( I ) = XP( I )*TEMP
RHS( I ) = RHS( I )*TEMP
DO 20 K = I + 1, N
XP( I ) = XP( I ) - XP( K )*( Z( I, K )*TEMP )
RHS( I ) = RHS( I ) - RHS( K )*( Z( I, K )*TEMP )
20 CONTINUE
SPLUS = SPLUS + ABS( XP( I ) )
SMINU = SMINU + ABS( RHS( I ) )
30 CONTINUE
IF( SPLUS.GT.SMINU )
$ CALL DCOPY( N, XP, 1, RHS, 1 )
*
* Apply the permutations JPIV to the computed solution (RHS)
*
CALL DLASWP( 1, RHS, LDZ, 1, N-1, JPIV, -1 )
*
* Compute the sum of squares
*
CALL DLASSQ( N, RHS, 1, RDSCAL, RDSUM )
*
ELSE
*
* IJOB = 2, Compute approximate nullvector XM of Z
*
CALL DGECON( 'I', N, Z, LDZ, ONE, TEMP, WORK, IWORK, INFO )
CALL DCOPY( N, WORK( N+1 ), 1, XM, 1 )
*
* Compute RHS
*
CALL DLASWP( 1, XM, LDZ, 1, N-1, IPIV, -1 )
TEMP = ONE / SQRT( DDOT( N, XM, 1, XM, 1 ) )
CALL DSCAL( N, TEMP, XM, 1 )
CALL DCOPY( N, XM, 1, XP, 1 )
CALL DAXPY( N, ONE, RHS, 1, XP, 1 )
CALL DAXPY( N, -ONE, XM, 1, RHS, 1 )
CALL DGESC2( N, Z, LDZ, RHS, IPIV, JPIV, TEMP )
CALL DGESC2( N, Z, LDZ, XP, IPIV, JPIV, TEMP )
IF( DASUM( N, XP, 1 ).GT.DASUM( N, RHS, 1 ) )
$ CALL DCOPY( N, XP, 1, RHS, 1 )
*
* Compute the sum of squares
*
CALL DLASSQ( N, RHS, 1, RDSCAL, RDSUM )
*
END IF
*
RETURN
*
* End of DLATDF
*
END
*> \brief \b DLATRS solves a triangular system of equations with the scale factor set to prevent overflow.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DLATRS + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X, SCALE,
* CNORM, INFO )
*
* .. Scalar Arguments ..
* CHARACTER DIAG, NORMIN, TRANS, UPLO
* INTEGER INFO, LDA, N
* DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), CNORM( * ), X( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLATRS solves one of the triangular systems
*>
*> A *x = s*b or A**T *x = s*b
*>
*> with scaling to prevent overflow. Here A is an upper or lower
*> triangular matrix, A**T denotes the transpose of A, x and b are
*> n-element vectors, and s is a scaling factor, usually less than
*> or equal to 1, chosen so that the components of x will be less than
*> the overflow threshold. If the unscaled problem will not cause
*> overflow, the Level 2 BLAS routine DTRSV is called. If the matrix A
*> is singular (A(j,j) = 0 for some j), then s is set to 0 and a
*> non-trivial solution to A*x = 0 is returned.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> Specifies whether the matrix A is upper or lower triangular.
*> = 'U': Upper triangular
*> = 'L': Lower triangular
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> Specifies the operation applied to A.
*> = 'N': Solve A * x = s*b (No transpose)
*> = 'T': Solve A**T* x = s*b (Transpose)
*> = 'C': Solve A**T* x = s*b (Conjugate transpose = Transpose)
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> Specifies whether or not the matrix A is unit triangular.
*> = 'N': Non-unit triangular
*> = 'U': Unit triangular
*> \endverbatim
*>
*> \param[in] NORMIN
*> \verbatim
*> NORMIN is CHARACTER*1
*> Specifies whether CNORM has been set or not.
*> = 'Y': CNORM contains the column norms on entry
*> = 'N': CNORM is not set on entry. On exit, the norms will
*> be computed and stored in CNORM.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrix A. N >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> The triangular matrix A. If UPLO = 'U', the leading n by n
*> upper triangular part of the array A contains the upper
*> triangular matrix, and the strictly lower triangular part of
*> A is not referenced. If UPLO = 'L', the leading n by n lower
*> triangular part of the array A contains the lower triangular
*> matrix, and the strictly upper triangular part of A is not
*> referenced. If DIAG = 'U', the diagonal elements of A are
*> also not referenced and are assumed to be 1.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max (1,N).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is DOUBLE PRECISION array, dimension (N)
*> On entry, the right hand side b of the triangular system.
*> On exit, X is overwritten by the solution vector x.
*> \endverbatim
*>
*> \param[out] SCALE
*> \verbatim
*> SCALE is DOUBLE PRECISION
*> The scaling factor s for the triangular system
*> A * x = s*b or A**T* x = s*b.
*> If SCALE = 0, the matrix A is singular or badly scaled, and
*> the vector x is an exact or approximate solution to A*x = 0.
*> \endverbatim
*>
*> \param[in,out] CNORM
*> \verbatim
*> CNORM is DOUBLE PRECISION array, dimension (N)
*>
*> If NORMIN = 'Y', CNORM is an input argument and CNORM(j)
*> contains the norm of the off-diagonal part of the j-th column
*> of A. If TRANS = 'N', CNORM(j) must be greater than or equal
*> to the infinity-norm, and if TRANS = 'T' or 'C', CNORM(j)
*> must be greater than or equal to the 1-norm.
*>
*> If NORMIN = 'N', CNORM is an output argument and CNORM(j)
*> returns the 1-norm of the offdiagonal part of the j-th column
*> of A.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -k, the k-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup latrs
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> A rough bound on x is computed; if that is less than overflow, DTRSV
*> is called, otherwise, specific code is used which checks for possible
*> overflow or divide-by-zero at every operation.
*>
*> A columnwise scheme is used for solving A*x = b. The basic algorithm
*> if A is lower triangular is
*>
*> x[1:n] := b[1:n]
*> for j = 1, ..., n
*> x(j) := x(j) / A(j,j)
*> x[j+1:n] := x[j+1:n] - x(j) * A[j+1:n,j]
*> end
*>
*> Define bounds on the components of x after j iterations of the loop:
*> M(j) = bound on x[1:j]
*> G(j) = bound on x[j+1:n]
*> Initially, let M(0) = 0 and G(0) = max{x(i), i=1,...,n}.
*>
*> Then for iteration j+1 we have
*> M(j+1) <= G(j) / | A(j+1,j+1) |
*> G(j+1) <= G(j) + M(j+1) * | A[j+2:n,j+1] |
*> <= G(j) ( 1 + CNORM(j+1) / | A(j+1,j+1) | )
*>
*> where CNORM(j+1) is greater than or equal to the infinity-norm of
*> column j+1 of A, not counting the diagonal. Hence
*>
*> G(j) <= G(0) product ( 1 + CNORM(i) / | A(i,i) | )
*> 1<=i<=j
*> and
*>
*> |x(j)| <= ( G(0) / |A(j,j)| ) product ( 1 + CNORM(i) / |A(i,i)| )
*> 1<=i< j
*>
*> Since |x(j)| <= M(j), we use the Level 2 BLAS routine DTRSV if the
*> reciprocal of the largest M(j), j=1,..,n, is larger than
*> max(underflow, 1/overflow).
*>
*> The bound on x(j) is also used to determine when a step in the
*> columnwise method can be performed without fear of overflow. If
*> the computed bound is greater than a large constant, x is scaled to
*> prevent overflow, but if the bound overflows, x is set to 0, x(j) to
*> 1, and scale to 0, and a non-trivial solution to A*x = 0 is found.
*>
*> Similarly, a row-wise scheme is used to solve A**T*x = b. The basic
*> algorithm for A upper triangular is
*>
*> for j = 1, ..., n
*> x(j) := ( b(j) - A[1:j-1,j]**T * x[1:j-1] ) / A(j,j)
*> end
*>
*> We simultaneously compute two bounds
*> G(j) = bound on ( b(i) - A[1:i-1,i]**T * x[1:i-1] ), 1<=i<=j
*> M(j) = bound on x(i), 1<=i<=j
*>
*> The initial values are G(0) = 0, M(0) = max{b(i), i=1,..,n}, and we
*> add the constraint G(j) >= G(j-1) and M(j) >= M(j-1) for j >= 1.
*> Then the bound on x(j) is
*>
*> M(j) <= M(j-1) * ( 1 + CNORM(j) ) / | A(j,j) |
*>
*> <= M(0) * product ( ( 1 + CNORM(i) ) / |A(i,i)| )
*> 1<=i<=j
*>
*> and we can safely call DTRSV if 1/M(n) and 1/G(n) are both greater
*> than max(underflow, 1/overflow).
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DLATRS( UPLO, TRANS, DIAG, NORMIN, N, A, LDA, X,
$ SCALE,
$ CNORM, INFO )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER DIAG, NORMIN, TRANS, UPLO
INTEGER INFO, LDA, N
DOUBLE PRECISION SCALE
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), CNORM( * ), X( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO, HALF, ONE
PARAMETER ( ZERO = 0.0D+0, HALF = 0.5D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN, NOUNIT, UPPER
INTEGER I, IMAX, J, JFIRST, JINC, JLAST
DOUBLE PRECISION BIGNUM, GROW, REC, SMLNUM, SUMJ, TJJ, TJJS,
$ TMAX, TSCAL, USCAL, XBND, XJ, XMAX
* ..
* .. Local Arrays ..
DOUBLE PRECISION WORK(1)
* ..
* .. External Functions ..
LOGICAL LSAME
INTEGER IDAMAX
DOUBLE PRECISION DASUM, DDOT, DLAMCH, DLANGE
EXTERNAL LSAME, IDAMAX, DASUM, DDOT, DLAMCH,
$ DLANGE
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DSCAL, DTRSV, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, MIN
* ..
* .. Executable Statements ..
*
INFO = 0
UPPER = LSAME( UPLO, 'U' )
NOTRAN = LSAME( TRANS, 'N' )
NOUNIT = LSAME( DIAG, 'N' )
*
* Test the input parameters.
*
IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) .AND. .NOT.
$ LSAME( TRANS, 'C' ) ) THEN
INFO = -2
ELSE IF( .NOT.NOUNIT .AND. .NOT.LSAME( DIAG, 'U' ) ) THEN
INFO = -3
ELSE IF( .NOT.LSAME( NORMIN, 'Y' ) .AND. .NOT.
$ LSAME( NORMIN, 'N' ) ) THEN
INFO = -4
ELSE IF( N.LT.0 ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
INFO = -7
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DLATRS', -INFO )
RETURN
END IF
*
* Quick return if possible
*
SCALE = ONE
IF( N.EQ.0 )
$ RETURN
*
* Determine machine dependent parameters to control overflow.
*
SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
BIGNUM = ONE / SMLNUM
*
IF( LSAME( NORMIN, 'N' ) ) THEN
*
* Compute the 1-norm of each column, not including the diagonal.
*
IF( UPPER ) THEN
*
* A is upper triangular.
*
DO 10 J = 1, N
CNORM( J ) = DASUM( J-1, A( 1, J ), 1 )
10 CONTINUE
ELSE
*
* A is lower triangular.
*
DO 20 J = 1, N - 1
CNORM( J ) = DASUM( N-J, A( J+1, J ), 1 )
20 CONTINUE
CNORM( N ) = ZERO
END IF
END IF
*
* Scale the column norms by TSCAL if the maximum element in CNORM is
* greater than BIGNUM.
*
IMAX = IDAMAX( N, CNORM, 1 )
TMAX = CNORM( IMAX )
IF( TMAX.LE.BIGNUM ) THEN
TSCAL = ONE
ELSE
*
* Avoid NaN generation if entries in CNORM exceed the
* overflow threshold
*
IF( TMAX.LE.DLAMCH('Overflow') ) THEN
* Case 1: All entries in CNORM are valid floating-point numbers
TSCAL = ONE / ( SMLNUM*TMAX )
CALL DSCAL( N, TSCAL, CNORM, 1 )
ELSE
* Case 2: At least one column norm of A cannot be represented
* as floating-point number. Find the offdiagonal entry A( I, J )
* with the largest absolute value. If this entry is not +/- Infinity,
* use this value as TSCAL.
TMAX = ZERO
IF( UPPER ) THEN
*
* A is upper triangular.
*
DO J = 2, N
TMAX = MAX( DLANGE( 'M', J-1, 1, A( 1, J ), 1,
$ WORK ), TMAX )
END DO
ELSE
*
* A is lower triangular.
*
DO J = 1, N - 1
TMAX = MAX( DLANGE( 'M', N-J, 1, A( J+1, J ), 1,
$ WORK ), TMAX )
END DO
END IF
*
IF( TMAX.LE.DLAMCH('Overflow') ) THEN
TSCAL = ONE / ( SMLNUM*TMAX )
DO J = 1, N
IF( CNORM( J ).LE.DLAMCH('Overflow') ) THEN
CNORM( J ) = CNORM( J )*TSCAL
ELSE
* Recompute the 1-norm without introducing Infinity
* in the summation
CNORM( J ) = ZERO
IF( UPPER ) THEN
DO I = 1, J - 1
CNORM( J ) = CNORM( J ) +
$ TSCAL * ABS( A( I, J ) )
END DO
ELSE
DO I = J + 1, N
CNORM( J ) = CNORM( J ) +
$ TSCAL * ABS( A( I, J ) )
END DO
END IF
END IF
END DO
ELSE
* At least one entry of A is not a valid floating-point entry.
* Rely on TRSV to propagate Inf and NaN.
CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 )
RETURN
END IF
END IF
END IF
*
* Compute a bound on the computed solution vector to see if the
* Level 2 BLAS routine DTRSV can be used.
*
J = IDAMAX( N, X, 1 )
XMAX = ABS( X( J ) )
XBND = XMAX
IF( NOTRAN ) THEN
*
* Compute the growth in A * x = b.
*
IF( UPPER ) THEN
JFIRST = N
JLAST = 1
JINC = -1
ELSE
JFIRST = 1
JLAST = N
JINC = 1
END IF
*
IF( TSCAL.NE.ONE ) THEN
GROW = ZERO
GO TO 50
END IF
*
IF( NOUNIT ) THEN
*
* A is non-unit triangular.
*
* Compute GROW = 1/G(j) and XBND = 1/M(j).
* Initially, G(0) = max{x(i), i=1,...,n}.
*
GROW = ONE / MAX( XBND, SMLNUM )
XBND = GROW
DO 30 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 50
*
* M(j) = G(j-1) / abs(A(j,j))
*
TJJ = ABS( A( J, J ) )
XBND = MIN( XBND, MIN( ONE, TJJ )*GROW )
IF( TJJ+CNORM( J ).GE.SMLNUM ) THEN
*
* G(j) = G(j-1)*( 1 + CNORM(j) / abs(A(j,j)) )
*
GROW = GROW*( TJJ / ( TJJ+CNORM( J ) ) )
ELSE
*
* G(j) could overflow, set GROW to 0.
*
GROW = ZERO
END IF
30 CONTINUE
GROW = XBND
ELSE
*
* A is unit triangular.
*
* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
DO 40 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 50
*
* G(j) = G(j-1)*( 1 + CNORM(j) )
*
GROW = GROW*( ONE / ( ONE+CNORM( J ) ) )
40 CONTINUE
END IF
50 CONTINUE
*
ELSE
*
* Compute the growth in A**T * x = b.
*
IF( UPPER ) THEN
JFIRST = 1
JLAST = N
JINC = 1
ELSE
JFIRST = N
JLAST = 1
JINC = -1
END IF
*
IF( TSCAL.NE.ONE ) THEN
GROW = ZERO
GO TO 80
END IF
*
IF( NOUNIT ) THEN
*
* A is non-unit triangular.
*
* Compute GROW = 1/G(j) and XBND = 1/M(j).
* Initially, M(0) = max{x(i), i=1,...,n}.
*
GROW = ONE / MAX( XBND, SMLNUM )
XBND = GROW
DO 60 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 80
*
* G(j) = max( G(j-1), M(j-1)*( 1 + CNORM(j) ) )
*
XJ = ONE + CNORM( J )
GROW = MIN( GROW, XBND / XJ )
*
* M(j) = M(j-1)*( 1 + CNORM(j) ) / abs(A(j,j))
*
TJJ = ABS( A( J, J ) )
IF( XJ.GT.TJJ )
$ XBND = XBND*( TJJ / XJ )
60 CONTINUE
GROW = MIN( GROW, XBND )
ELSE
*
* A is unit triangular.
*
* Compute GROW = 1/G(j), where G(0) = max{x(i), i=1,...,n}.
*
GROW = MIN( ONE, ONE / MAX( XBND, SMLNUM ) )
DO 70 J = JFIRST, JLAST, JINC
*
* Exit the loop if the growth factor is too small.
*
IF( GROW.LE.SMLNUM )
$ GO TO 80
*
* G(j) = ( 1 + CNORM(j) )*G(j-1)
*
XJ = ONE + CNORM( J )
GROW = GROW / XJ
70 CONTINUE
END IF
80 CONTINUE
END IF
*
IF( ( GROW*TSCAL ).GT.SMLNUM ) THEN
*
* Use the Level 2 BLAS solve if the reciprocal of the bound on
* elements of X is not too small.
*
CALL DTRSV( UPLO, TRANS, DIAG, N, A, LDA, X, 1 )
ELSE
*
* Use a Level 1 BLAS solve, scaling intermediate results.
*
IF( XMAX.GT.BIGNUM ) THEN
*
* Scale X so that its components are less than or equal to
* BIGNUM in absolute value.
*
SCALE = BIGNUM / XMAX
CALL DSCAL( N, SCALE, X, 1 )
XMAX = BIGNUM
END IF
*
IF( NOTRAN ) THEN
*
* Solve A * x = b
*
DO 110 J = JFIRST, JLAST, JINC
*
* Compute x(j) = b(j) / A(j,j), scaling x if necessary.
*
XJ = ABS( X( J ) )
IF( NOUNIT ) THEN
TJJS = A( J, J )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 100
END IF
TJJ = ABS( TJJS )
IF( TJJ.GT.SMLNUM ) THEN
*
* abs(A(j,j)) > SMLNUM:
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by 1/b(j).
*
REC = ONE / XJ
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J ) = X( J ) / TJJS
XJ = ABS( X( J ) )
ELSE IF( TJJ.GT.ZERO ) THEN
*
* 0 < abs(A(j,j)) <= SMLNUM:
*
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM
* to avoid overflow when dividing by A(j,j).
*
REC = ( TJJ*BIGNUM ) / XJ
IF( CNORM( J ).GT.ONE ) THEN
*
* Scale by 1/CNORM(j) to avoid overflow when
* multiplying x(j) times column j.
*
REC = REC / CNORM( J )
END IF
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
X( J ) = X( J ) / TJJS
XJ = ABS( X( J ) )
ELSE
*
* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
* scale = 0, and compute a solution to A*x = 0.
*
DO 90 I = 1, N
X( I ) = ZERO
90 CONTINUE
X( J ) = ONE
XJ = ONE
SCALE = ZERO
XMAX = ZERO
END IF
100 CONTINUE
*
* Scale x if necessary to avoid overflow when adding a
* multiple of column j of A.
*
IF( XJ.GT.ONE ) THEN
REC = ONE / XJ
IF( CNORM( J ).GT.( BIGNUM-XMAX )*REC ) THEN
*
* Scale x by 1/(2*abs(x(j))).
*
REC = REC*HALF
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
END IF
ELSE IF( XJ*CNORM( J ).GT.( BIGNUM-XMAX ) ) THEN
*
* Scale x by 1/2.
*
CALL DSCAL( N, HALF, X, 1 )
SCALE = SCALE*HALF
END IF
*
IF( UPPER ) THEN
IF( J.GT.1 ) THEN
*
* Compute the update
* x(1:j-1) := x(1:j-1) - x(j) * A(1:j-1,j)
*
CALL DAXPY( J-1, -X( J )*TSCAL, A( 1, J ), 1, X,
$ 1 )
I = IDAMAX( J-1, X, 1 )
XMAX = ABS( X( I ) )
END IF
ELSE
IF( J.LT.N ) THEN
*
* Compute the update
* x(j+1:n) := x(j+1:n) - x(j) * A(j+1:n,j)
*
CALL DAXPY( N-J, -X( J )*TSCAL, A( J+1, J ), 1,
$ X( J+1 ), 1 )
I = J + IDAMAX( N-J, X( J+1 ), 1 )
XMAX = ABS( X( I ) )
END IF
END IF
110 CONTINUE
*
ELSE
*
* Solve A**T * x = b
*
DO 160 J = JFIRST, JLAST, JINC
*
* Compute x(j) = b(j) - sum A(k,j)*x(k).
* k<>j
*
XJ = ABS( X( J ) )
USCAL = TSCAL
REC = ONE / MAX( XMAX, ONE )
IF( CNORM( J ).GT.( BIGNUM-XJ )*REC ) THEN
*
* If x(j) could overflow, scale x by 1/(2*XMAX).
*
REC = REC*HALF
IF( NOUNIT ) THEN
TJJS = A( J, J )*TSCAL
ELSE
TJJS = TSCAL
END IF
TJJ = ABS( TJJS )
IF( TJJ.GT.ONE ) THEN
*
* Divide by A(j,j) when scaling x if A(j,j) > 1.
*
REC = MIN( ONE, REC*TJJ )
USCAL = USCAL / TJJS
END IF
IF( REC.LT.ONE ) THEN
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
*
SUMJ = ZERO
IF( USCAL.EQ.ONE ) THEN
*
* If the scaling needed for A in the dot product is 1,
* call DDOT to perform the dot product.
*
IF( UPPER ) THEN
SUMJ = DDOT( J-1, A( 1, J ), 1, X, 1 )
ELSE IF( J.LT.N ) THEN
SUMJ = DDOT( N-J, A( J+1, J ), 1, X( J+1 ), 1 )
END IF
ELSE
*
* Otherwise, use in-line code for the dot product.
*
IF( UPPER ) THEN
DO 120 I = 1, J - 1
SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I )
120 CONTINUE
ELSE IF( J.LT.N ) THEN
DO 130 I = J + 1, N
SUMJ = SUMJ + ( A( I, J )*USCAL )*X( I )
130 CONTINUE
END IF
END IF
*
IF( USCAL.EQ.TSCAL ) THEN
*
* Compute x(j) := ( x(j) - sumj ) / A(j,j) if 1/A(j,j)
* was not used to scale the dotproduct.
*
X( J ) = X( J ) - SUMJ
XJ = ABS( X( J ) )
IF( NOUNIT ) THEN
TJJS = A( J, J )*TSCAL
ELSE
TJJS = TSCAL
IF( TSCAL.EQ.ONE )
$ GO TO 150
END IF
*
* Compute x(j) = x(j) / A(j,j), scaling if necessary.
*
TJJ = ABS( TJJS )
IF( TJJ.GT.SMLNUM ) THEN
*
* abs(A(j,j)) > SMLNUM:
*
IF( TJJ.LT.ONE ) THEN
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale X by 1/abs(x(j)).
*
REC = ONE / XJ
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
END IF
X( J ) = X( J ) / TJJS
ELSE IF( TJJ.GT.ZERO ) THEN
*
* 0 < abs(A(j,j)) <= SMLNUM:
*
IF( XJ.GT.TJJ*BIGNUM ) THEN
*
* Scale x by (1/abs(x(j)))*abs(A(j,j))*BIGNUM.
*
REC = ( TJJ*BIGNUM ) / XJ
CALL DSCAL( N, REC, X, 1 )
SCALE = SCALE*REC
XMAX = XMAX*REC
END IF
X( J ) = X( J ) / TJJS
ELSE
*
* A(j,j) = 0: Set x(1:n) = 0, x(j) = 1, and
* scale = 0, and compute a solution to A**T*x = 0.
*
DO 140 I = 1, N
X( I ) = ZERO
140 CONTINUE
X( J ) = ONE
SCALE = ZERO
XMAX = ZERO
END IF
150 CONTINUE
ELSE
*
* Compute x(j) := x(j) / A(j,j) - sumj if the dot
* product has already been divided by 1/A(j,j).
*
X( J ) = X( J ) / TJJS - SUMJ
END IF
XMAX = MAX( XMAX, ABS( X( J ) ) )
160 CONTINUE
END IF
SCALE = SCALE / TSCAL
END IF
*
* Scale the column norms by 1/TSCAL for return.
*
IF( TSCAL.NE.ONE ) THEN
CALL DSCAL( N, ONE / TSCAL, CNORM, 1 )
END IF
*
RETURN
*
* End of DLATRS
*
END
!> \brief \b DNRM2
!
! =========== DOCUMENTATION ===========
!
! Online html documentation available at
! http://www.netlib.org/lapack/explore-html/
!
! Definition:
! ===========
!
! DOUBLE PRECISION FUNCTION DNRM2(N,X,INCX)
!
! .. Scalar Arguments ..
! INTEGER INCX,N
! ..
! .. Array Arguments ..
! DOUBLE PRECISION X(*)
! ..
!
!
!> \par Purpose:
! =============
!>
!> \verbatim
!>
!> DNRM2 returns the euclidean norm of a vector via the function
!> name, so that
!>
!> DNRM2 := sqrt( x'*x )
!> \endverbatim
!
! Arguments:
! ==========
!
!> \param[in] N
!> \verbatim
!> N is INTEGER
!> number of elements in input vector(s)
!> \endverbatim
!>
!> \param[in] X
!> \verbatim
!> X is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
!> \endverbatim
!>
!> \param[in] INCX
!> \verbatim
!> INCX is INTEGER, storage spacing between elements of X
!> If INCX > 0, X(1+(i-1)*INCX) = x(i) for 1 <= i <= n
!> If INCX < 0, X(1-(n-i)*INCX) = x(i) for 1 <= i <= n
!> If INCX = 0, x isn't a vector so there is no need to call
!> this subroutine. If you call it anyway, it will count x(1)
!> in the vector norm N times.
!> \endverbatim
!
! Authors:
! ========
!
!> \author Edward Anderson, Lockheed Martin
!
!> \date August 2016
!
!> \ingroup nrm2
!
!> \par Contributors:
! ==================
!>
!> Weslley Pereira, University of Colorado Denver, USA
!
!> \par Further Details:
! =====================
!>
!> \verbatim
!>
!> Anderson E. (2017)
!> Algorithm 978: Safe Scaling in the Level 1 BLAS
!> ACM Trans Math Softw 44:1--28
!> https://doi.org/10.1145/3061665
!>
!> Blue, James L. (1978)
!> A Portable Fortran Program to Find the Euclidean Norm of a Vector
!> ACM Trans Math Softw 4:15--23
!> https://doi.org/10.1145/355769.355771
!>
!> \endverbatim
!>
! =====================================================================
function DNRM2( n, x, incx )
integer, parameter :: wp = kind(1.d0)
real(wp) :: DNRM2
!
! -- Reference BLAS level1 routine (version 3.9.1) --
! -- Reference BLAS is a software package provided by Univ. of Tennessee, --
! -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
! March 2021
!
! .. Constants ..
real(wp), parameter :: zero = 0.0_wp
real(wp), parameter :: one = 1.0_wp
real(wp), parameter :: maxN = huge(0.0_wp)
! ..
! .. Blue's scaling constants ..
real(wp), parameter :: tsml = real(radix(0._wp), wp)**ceiling( &
(minexponent(0._wp) - 1) * 0.5_wp)
real(wp), parameter :: tbig = real(radix(0._wp), wp)**floor( &
(maxexponent(0._wp) - digits(0._wp) + 1) * 0.5_wp)
real(wp), parameter :: ssml = real(radix(0._wp), wp)**( - floor( &
(minexponent(0._wp) - digits(0._wp)) * 0.5_wp))
real(wp), parameter :: sbig = real(radix(0._wp), wp)**( - ceiling( &
(maxexponent(0._wp) + digits(0._wp) - 1) * 0.5_wp))
! ..
! .. Scalar Arguments ..
integer :: incx, n
! ..
! .. Array Arguments ..
real(wp) :: x(*)
! ..
! .. Local Scalars ..
integer :: i, ix
logical :: notbig
real(wp) :: abig, amed, asml, ax, scl, sumsq, ymax, ymin
!
! Quick return if possible
!
DNRM2 = zero
if( n <= 0 ) return
!
scl = one
sumsq = zero
!
! Compute the sum of squares in 3 accumulators:
! abig -- sums of squares scaled down to avoid overflow
! asml -- sums of squares scaled up to avoid underflow
! amed -- sums of squares that do not require scaling
! The thresholds and multipliers are
! tbig -- values bigger than this are scaled down by sbig
! tsml -- values smaller than this are scaled up by ssml
!
notbig = .true.
asml = zero
amed = zero
abig = zero
ix = 1
if( incx < 0 ) ix = 1 - (n-1)*incx
do i = 1, n
ax = abs(x(ix))
if (ax > tbig) then
abig = abig + (ax*sbig)**2
notbig = .false.
else if (ax < tsml) then
if (notbig) asml = asml + (ax*ssml)**2
else
amed = amed + ax**2
end if
ix = ix + incx
end do
!
! Combine abig and amed or amed and asml if more than one
! accumulator was used.
!
if (abig > zero) then
!
! Combine abig and amed if abig > 0.
!
if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then
abig = abig + (amed*sbig)*sbig
end if
scl = one / sbig
sumsq = abig
else if (asml > zero) then
!
! Combine amed and asml if asml > 0.
!
if ( (amed > zero) .or. (amed > maxN) .or. (amed /= amed) ) then
amed = sqrt(amed)
asml = sqrt(asml) / ssml
if (asml > amed) then
ymin = amed
ymax = asml
else
ymin = asml
ymax = amed
end if
scl = one
sumsq = ymax**2*( one + (ymin/ymax)**2 )
else
scl = one / ssml
sumsq = asml
end if
else
!
! Otherwise all values are mid-range
!
scl = one
sumsq = amed
end if
DNRM2 = scl*sqrt( sumsq )
return
end function
*> \brief \b DORG2R generates all or part of the orthogonal matrix Q from a QR factorization determined by sgeqrf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORG2R + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DORG2R generates an m by n real matrix Q with orthonormal columns,
*> which is defined as the first n columns of a product of k elementary
*> reflectors of order m
*>
*> Q = H(1) H(2) . . . H(k)
*>
*> as returned by DGEQRF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q. M >= N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines the
*> matrix Q. N >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the i-th column must contain the vector which
*> defines the elementary reflector H(i), for i = 1,2,...,k, as
*> returned by DGEQRF in the first k columns of its array
*> argument A.
*> On exit, the m-by-n matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by DGEQRF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (N)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument has an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup ung2r
*
* =====================================================================
SUBROUTINE DORG2R( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J, L
* ..
* .. External Subroutines ..
EXTERNAL DLARF1F, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.0 .OR. N.GT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.N ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORG2R', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
* Initialise columns k+1:n to columns of the unit matrix
*
DO 20 J = K + 1, N
DO 10 L = 1, M
A( L, J ) = ZERO
10 CONTINUE
A( J, J ) = ONE
20 CONTINUE
*
DO 40 I = K, 1, -1
*
* Apply H(i) to A(i:m,i:n) from the left
*
IF( I.LT.N ) THEN
CALL DLARF1F( 'Left', M-I+1, N-I, A( I, I ), 1, TAU( I ),
$ A( I, I+1 ), LDA, WORK )
END IF
IF( I.LT.M )
$ CALL DSCAL( M-I, -TAU( I ), A( I+1, I ), 1 )
A( I, I ) = ONE - TAU( I )
*
* Set A(1:i-1,i) to zero
*
DO 30 L = 1, I - 1
A( L, I ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of DORG2R
*
END
*> \brief \b DORGR2 generates all or part of the orthogonal matrix Q from an RQ factorization determined by sgerqf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORGR2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORGR2( M, N, K, A, LDA, TAU, WORK, INFO )
*
* .. Scalar Arguments ..
* INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DORGR2 generates an m by n real matrix Q with orthonormal rows,
*> which is defined as the last m rows of a product of k elementary
*> reflectors of order n
*>
*> Q = H(1) H(2) . . . H(k)
*>
*> as returned by DGERQF.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix Q. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix Q. N >= M.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines the
*> matrix Q. M >= K >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> On entry, the (m-k+i)-th row must contain the vector which
*> defines the elementary reflector H(i), for i = 1,2,...,k, as
*> returned by DGERQF in the last k rows of its array argument
*> A.
*> On exit, the m by n matrix Q.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The first dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by DGERQF.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (M)
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument has an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup ungr2
*
* =====================================================================
SUBROUTINE DORGR2( M, N, K, A, LDA, TAU, WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INFO, K, LDA, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, II, J, L
* ..
* .. External Subroutines ..
EXTERNAL DLARF, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
IF( M.LT.0 ) THEN
INFO = -1
ELSE IF( N.LT.M ) THEN
INFO = -2
ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
INFO = -3
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -5
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORGR2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.LE.0 )
$ RETURN
*
IF( K.LT.M ) THEN
*
* Initialise rows 1:m-k to rows of the unit matrix
*
DO 20 J = 1, N
DO 10 L = 1, M - K
A( L, J ) = ZERO
10 CONTINUE
IF( J.GT.N-M .AND. J.LE.N-K )
$ A( M-N+J, J ) = ONE
20 CONTINUE
END IF
*
DO 40 I = 1, K
II = M - K + I
*
* Apply H(i) to A(1:m-k+i,1:n-k+i) from the right
*
!A( II, N-M+II ) = ONE
CALL DLARF1L( 'Right', II-1, N-M+II, A( II, 1 ), LDA,
$ TAU( I ),
$ A, LDA, WORK )
CALL DSCAL( N-M+II-1, -TAU( I ), A( II, 1 ), LDA )
A( II, N-M+II ) = ONE - TAU( I )
*
* Set A(m-k+i,n-k+i+1:n) to zero
*
DO 30 L = N - M + II + 1, N
A( II, L ) = ZERO
30 CONTINUE
40 CONTINUE
RETURN
*
* End of DORGR2
*
END
*> \brief \b DORM2R multiplies a general matrix by the orthogonal matrix from a QR factorization determined by sgeqrf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORM2R + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
* WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DORM2R overwrites the general real m by n matrix C with
*>
*> Q * C if SIDE = 'L' and TRANS = 'N', or
*>
*> Q**T* C if SIDE = 'L' and TRANS = 'T', or
*>
*> C * Q if SIDE = 'R' and TRANS = 'N', or
*>
*> C * Q**T if SIDE = 'R' and TRANS = 'T',
*>
*> where Q is a real orthogonal matrix defined as the product of k
*> elementary reflectors
*>
*> Q = H(1) H(2) . . . H(k)
*>
*> as returned by DGEQRF. Q is of order m if SIDE = 'L' and of order n
*> if SIDE = 'R'.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply Q or Q**T from the Left
*> = 'R': apply Q or Q**T from the Right
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': apply Q (No transpose)
*> = 'T': apply Q**T (Transpose)
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C. N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> If SIDE = 'L', M >= K >= 0;
*> if SIDE = 'R', N >= K >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,K)
*> The i-th column must contain the vector which defines the
*> elementary reflector H(i), for i = 1,2,...,k, as returned by
*> DGEQRF in the first k columns of its array argument A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A.
*> If SIDE = 'L', LDA >= max(1,M);
*> if SIDE = 'R', LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by DGEQRF.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (LDC,N)
*> On entry, the m by n matrix C.
*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension
*> (N) if SIDE = 'L',
*> (M) if SIDE = 'R'
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup unm2r
*
* =====================================================================
SUBROUTINE DORM2R( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, IC, JC, MI, NI, NQ
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA, DLARF1F
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
*
* NQ is the order of Q
*
IF( LEFT ) THEN
NQ = M
ELSE
NQ = N
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORM2R', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
$ RETURN
*
IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) )
$ THEN
I1 = 1
I2 = K
I3 = 1
ELSE
I1 = K
I2 = 1
I3 = -1
END IF
*
IF( LEFT ) THEN
NI = N
JC = 1
ELSE
MI = M
IC = 1
END IF
*
DO 10 I = I1, I2, I3
IF( LEFT ) THEN
*
* H(i) is applied to C(i:m,1:n)
*
MI = M - I + 1
IC = I
ELSE
*
* H(i) is applied to C(1:m,i:n)
*
NI = N - I + 1
JC = I
END IF
*
* Apply H(i)
*
CALL DLARF1F( SIDE, MI, NI, A( I, I ), 1, TAU( I ), C( IC,
$ JC ),
$ LDC, WORK )
10 CONTINUE
RETURN
*
* End of DORM2R
*
END
*> \brief \b DORMR2 multiplies a general matrix by the orthogonal matrix from a RQ factorization determined by sgerqf (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DORMR2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
* WORK, INFO )
*
* .. Scalar Arguments ..
* CHARACTER SIDE, TRANS
* INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DORMR2 overwrites the general real m by n matrix C with
*>
*> Q * C if SIDE = 'L' and TRANS = 'N', or
*>
*> Q**T* C if SIDE = 'L' and TRANS = 'T', or
*>
*> C * Q if SIDE = 'R' and TRANS = 'N', or
*>
*> C * Q**T if SIDE = 'R' and TRANS = 'T',
*>
*> where Q is a real orthogonal matrix defined as the product of k
*> elementary reflectors
*>
*> Q = H(1) H(2) . . . H(k)
*>
*> as returned by DGERQF. Q is of order m if SIDE = 'L' and of order n
*> if SIDE = 'R'.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SIDE
*> \verbatim
*> SIDE is CHARACTER*1
*> = 'L': apply Q or Q**T from the Left
*> = 'R': apply Q or Q**T from the Right
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': apply Q (No transpose)
*> = 'T': apply Q' (Transpose)
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix C. M >= 0.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix C. N >= 0.
*> \endverbatim
*>
*> \param[in] K
*> \verbatim
*> K is INTEGER
*> The number of elementary reflectors whose product defines
*> the matrix Q.
*> If SIDE = 'L', M >= K >= 0;
*> if SIDE = 'R', N >= K >= 0.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension
*> (LDA,M) if SIDE = 'L',
*> (LDA,N) if SIDE = 'R'
*> The i-th row must contain the vector which defines the
*> elementary reflector H(i), for i = 1,2,...,k, as returned by
*> DGERQF in the last k rows of its array argument A.
*> A is modified by the routine but restored on exit.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,K).
*> \endverbatim
*>
*> \param[in] TAU
*> \verbatim
*> TAU is DOUBLE PRECISION array, dimension (K)
*> TAU(i) must contain the scalar factor of the elementary
*> reflector H(i), as returned by DGERQF.
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (LDC,N)
*> On entry, the m by n matrix C.
*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the array C. LDC >= max(1,M).
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension
*> (N) if SIDE = 'L',
*> (M) if SIDE = 'R'
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> = 0: successful exit
*> < 0: if INFO = -i, the i-th argument had an illegal value
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup unmr2
*
* =====================================================================
SUBROUTINE DORMR2( SIDE, TRANS, M, N, K, A, LDA, TAU, C, LDC,
$ WORK, INFO )
*
* -- LAPACK computational routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER SIDE, TRANS
INTEGER INFO, K, LDA, LDC, M, N
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER ( ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL LEFT, NOTRAN
INTEGER I, I1, I2, I3, MI, NI, NQ
DOUBLE PRECISION AII
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DLARF, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Test the input arguments
*
INFO = 0
LEFT = LSAME( SIDE, 'L' )
NOTRAN = LSAME( TRANS, 'N' )
*
* NQ is the order of Q
*
IF( LEFT ) THEN
NQ = M
ELSE
NQ = N
END IF
IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN
INFO = -1
ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
INFO = -2
ELSE IF( M.LT.0 ) THEN
INFO = -3
ELSE IF( N.LT.0 ) THEN
INFO = -4
ELSE IF( K.LT.0 .OR. K.GT.NQ ) THEN
INFO = -5
ELSE IF( LDA.LT.MAX( 1, K ) ) THEN
INFO = -7
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DORMR2', -INFO )
RETURN
END IF
*
* Quick return if possible
*
IF( M.EQ.0 .OR. N.EQ.0 .OR. K.EQ.0 )
$ RETURN
*
IF( ( LEFT .AND. .NOT.NOTRAN ) .OR. ( .NOT.LEFT .AND. NOTRAN ) )
$ THEN
I1 = 1
I2 = K
I3 = 1
ELSE
I1 = K
I2 = 1
I3 = -1
END IF
*
IF( LEFT ) THEN
NI = N
ELSE
MI = M
END IF
*
DO 10 I = I1, I2, I3
IF( LEFT ) THEN
*
* H(i) is applied to C(1:m-k+i,1:n)
*
MI = M - K + I
ELSE
*
* H(i) is applied to C(1:m,1:n-k+i)
*
NI = N - K + I
END IF
*
* Apply H(i)
*
AII = A( I, NQ-K+I )
A( I, NQ-K+I ) = ONE
CALL DLARF( SIDE, MI, NI, A( I, 1 ), LDA, TAU( I ), C, LDC,
$ WORK )
A( I, NQ-K+I ) = AII
10 CONTINUE
RETURN
*
* End of DORMR2
*
END
*> \brief \b DROT
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION C,S
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION DX(*),DY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DROT applies a plane rotation.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in,out] DX
*> \verbatim
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of DX
*> \endverbatim
*>
*> \param[in,out] DY
*> \verbatim
*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of DY
*> \endverbatim
*>
*> \param[in] C
*> \verbatim
*> C is DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] S
*> \verbatim
*> S is DOUBLE PRECISION
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup rot
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DROT(N,DX,INCX,DY,INCY,C,S)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
DOUBLE PRECISION C,S
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*),DY(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION DTEMP
INTEGER I,IX,IY
* ..
IF (N.LE.0) RETURN
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
*
* code for both increments equal to 1
*
DO I = 1,N
DTEMP = C*DX(I) + S*DY(I)
DY(I) = C*DY(I) - S*DX(I)
DX(I) = DTEMP
END DO
ELSE
*
* code for unequal increments or equal increments not equal
* to 1
*
IX = 1
IY = 1
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
DO I = 1,N
DTEMP = C*DX(IX) + S*DY(IY)
DY(IY) = C*DY(IY) - S*DX(IX)
DX(IX) = DTEMP
IX = IX + INCX
IY = IY + INCY
END DO
END IF
RETURN
*
* End of DROT
*
END
*> \brief \b DRSCL multiplies a vector by the reciprocal of a real scalar.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DRSCL + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DRSCL( N, SA, SX, INCX )
*
* .. Scalar Arguments ..
* INTEGER INCX, N
* DOUBLE PRECISION SA
* ..
* .. Array Arguments ..
* DOUBLE PRECISION SX( * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DRSCL multiplies an n-element real vector x by the real scalar 1/a.
*> This is done without overflow or underflow as long as
*> the final result x/a does not overflow or underflow.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of components of the vector x.
*> \endverbatim
*>
*> \param[in] SA
*> \verbatim
*> SA is DOUBLE PRECISION
*> The scalar a which is used to divide each component of x.
*> SA must be >= 0, or the subroutine will divide by zero.
*> \endverbatim
*>
*> \param[in,out] SX
*> \verbatim
*> SX is DOUBLE PRECISION array, dimension
*> (1+(N-1)*abs(INCX))
*> The n-element vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> The increment between successive values of the vector SX.
*> > 0: SX(1) = X(1) and SX(1+(i-1)*INCX) = x(i), 1< i<= n
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup rscl
*
* =====================================================================
SUBROUTINE DRSCL( N, SA, SX, INCX )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INCX, N
DOUBLE PRECISION SA
* ..
* .. Array Arguments ..
DOUBLE PRECISION SX( * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL DONE
DOUBLE PRECISION BIGNUM, CDEN, CDEN1, CNUM, CNUM1, MUL, SMLNUM
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DSCAL
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS
* ..
* .. Executable Statements ..
*
* Quick return if possible
*
IF( N.LE.0 )
$ RETURN
*
* Get machine parameters
*
SMLNUM = DLAMCH( 'S' )
BIGNUM = ONE / SMLNUM
*
* Initialize the denominator to SA and the numerator to 1.
*
CDEN = SA
CNUM = ONE
*
10 CONTINUE
CDEN1 = CDEN*SMLNUM
CNUM1 = CNUM / BIGNUM
IF( ABS( CDEN1 ).GT.ABS( CNUM ) .AND. CNUM.NE.ZERO ) THEN
*
* Pre-multiply X by SMLNUM if CDEN is large compared to CNUM.
*
MUL = SMLNUM
DONE = .FALSE.
CDEN = CDEN1
ELSE IF( ABS( CNUM1 ).GT.ABS( CDEN ) ) THEN
*
* Pre-multiply X by BIGNUM if CDEN is small compared to CNUM.
*
MUL = BIGNUM
DONE = .FALSE.
CNUM = CNUM1
ELSE
*
* Multiply X by CNUM / CDEN and return.
*
MUL = CNUM / CDEN
DONE = .TRUE.
END IF
*
* Scale the vector X by MUL
*
CALL DSCAL( N, MUL, SX, INCX )
*
IF( .NOT.DONE )
$ GO TO 10
*
RETURN
*
* End of DRSCL
*
END
*> \brief \b DSCAL
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DSCAL(N,DA,DX,INCX)
*
* .. Scalar Arguments ..
* DOUBLE PRECISION DA
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION DX(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSCAL scales a vector by a constant.
*> uses unrolled loops for increment equal to 1.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] DA
*> \verbatim
*> DA is DOUBLE PRECISION
*> On entry, DA specifies the scalar alpha.
*> \endverbatim
*>
*> \param[in,out] DX
*> \verbatim
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of DX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup scal
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 3/93 to return if incx .le. 0.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DSCAL(N,DA,DX,INCX)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
DOUBLE PRECISION DA
INTEGER INCX,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
INTEGER I,M,MP1,NINCX
* .. Parameters ..
DOUBLE PRECISION ONE
PARAMETER (ONE=1.0D+0)
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
IF (N.LE.0 .OR. INCX.LE.0 .OR. DA.EQ.ONE) RETURN
IF (INCX.EQ.1) THEN
*
* code for increment equal to 1
*
*
* clean-up loop
*
M = MOD(N,5)
IF (M.NE.0) THEN
DO I = 1,M
DX(I) = DA*DX(I)
END DO
IF (N.LT.5) RETURN
END IF
MP1 = M + 1
DO I = MP1,N,5
DX(I) = DA*DX(I)
DX(I+1) = DA*DX(I+1)
DX(I+2) = DA*DX(I+2)
DX(I+3) = DA*DX(I+3)
DX(I+4) = DA*DX(I+4)
END DO
ELSE
*
* code for increment not equal to 1
*
NINCX = N*INCX
DO I = 1,NINCX,INCX
DX(I) = DA*DX(I)
END DO
END IF
RETURN
*
* End of DSCAL
*
END
*> \brief \b DSWAP
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DSWAP(N,DX,INCX,DY,INCY)
*
* .. Scalar Arguments ..
* INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION DX(*),DY(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DSWAP interchanges two vectors.
*> uses unrolled loops for increments equal to 1.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in,out] DX
*> \verbatim
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of DX
*> \endverbatim
*>
*> \param[in,out] DY
*> \verbatim
*> DY is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCY ) )
*> \endverbatim
*>
*> \param[in] INCY
*> \verbatim
*> INCY is INTEGER
*> storage spacing between elements of DY
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup swap
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DSWAP(N,DX,INCX,DY,INCY)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INCX,INCY,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*),DY(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION DTEMP
INTEGER I,IX,IY,M,MP1
* ..
* .. Intrinsic Functions ..
INTRINSIC MOD
* ..
IF (N.LE.0) RETURN
IF (INCX.EQ.1 .AND. INCY.EQ.1) THEN
*
* code for both increments equal to 1
*
*
* clean-up loop
*
M = MOD(N,3)
IF (M.NE.0) THEN
DO I = 1,M
DTEMP = DX(I)
DX(I) = DY(I)
DY(I) = DTEMP
END DO
IF (N.LT.3) RETURN
END IF
MP1 = M + 1
DO I = MP1,N,3
DTEMP = DX(I)
DX(I) = DY(I)
DY(I) = DTEMP
DTEMP = DX(I+1)
DX(I+1) = DY(I+1)
DY(I+1) = DTEMP
DTEMP = DX(I+2)
DX(I+2) = DY(I+2)
DY(I+2) = DTEMP
END DO
ELSE
*
* code for unequal increments or equal increments not equal
* to 1
*
IX = 1
IY = 1
IF (INCX.LT.0) IX = (-N+1)*INCX + 1
IF (INCY.LT.0) IY = (-N+1)*INCY + 1
DO I = 1,N
DTEMP = DX(IX)
DX(IX) = DY(IY)
DY(IY) = DTEMP
IX = IX + INCX
IY = IY + INCY
END DO
END IF
RETURN
*
* End of DSWAP
*
END
*> \brief \b DTGEX2 swaps adjacent diagonal blocks in an upper (quasi) triangular matrix pair by an orthogonal equivalence transformation.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DTGEX2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
* LDZ, J1, N1, N2, WORK, LWORK, INFO )
*
* .. Scalar Arguments ..
* LOGICAL WANTQ, WANTZ
* INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, LWORK, N, N1, N2
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
* $ WORK( * ), Z( LDZ, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DTGEX2 swaps adjacent diagonal blocks (A11, B11) and (A22, B22)
*> of size 1-by-1 or 2-by-2 in an upper (quasi) triangular matrix pair
*> (A, B) by an orthogonal equivalence transformation.
*>
*> (A, B) must be in generalized real Schur canonical form (as returned
*> by DGGES), i.e. A is block upper triangular with 1-by-1 and 2-by-2
*> diagonal blocks. B is upper triangular.
*>
*> Optionally, the matrices Q and Z of generalized Schur vectors are
*> updated.
*>
*> Q(in) * A(in) * Z(in)**T = Q(out) * A(out) * Z(out)**T
*> Q(in) * B(in) * Z(in)**T = Q(out) * B(out) * Z(out)**T
*>
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] WANTQ
*> \verbatim
*> WANTQ is LOGICAL
*> .TRUE. : update the left transformation matrix Q;
*> .FALSE.: do not update Q.
*> \endverbatim
*>
*> \param[in] WANTZ
*> \verbatim
*> WANTZ is LOGICAL
*> .TRUE. : update the right transformation matrix Z;
*> .FALSE.: do not update Z.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The order of the matrices A and B. N >= 0.
*> \endverbatim
*>
*> \param[in,out] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimensions (LDA,N)
*> On entry, the matrix A in the pair (A, B).
*> On exit, the updated matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimensions (LDB,N)
*> On entry, the matrix B in the pair (A, B).
*> On exit, the updated matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the array B. LDB >= max(1,N).
*> \endverbatim
*>
*> \param[in,out] Q
*> \verbatim
*> Q is DOUBLE PRECISION array, dimension (LDQ,N)
*> On entry, if WANTQ = .TRUE., the orthogonal matrix Q.
*> On exit, the updated matrix Q.
*> Not referenced if WANTQ = .FALSE..
*> \endverbatim
*>
*> \param[in] LDQ
*> \verbatim
*> LDQ is INTEGER
*> The leading dimension of the array Q. LDQ >= 1.
*> If WANTQ = .TRUE., LDQ >= N.
*> \endverbatim
*>
*> \param[in,out] Z
*> \verbatim
*> Z is DOUBLE PRECISION array, dimension (LDZ,N)
*> On entry, if WANTZ =.TRUE., the orthogonal matrix Z.
*> On exit, the updated matrix Z.
*> Not referenced if WANTZ = .FALSE..
*> \endverbatim
*>
*> \param[in] LDZ
*> \verbatim
*> LDZ is INTEGER
*> The leading dimension of the array Z. LDZ >= 1.
*> If WANTZ = .TRUE., LDZ >= N.
*> \endverbatim
*>
*> \param[in] J1
*> \verbatim
*> J1 is INTEGER
*> The index to the first block (A11, B11). 1 <= J1 <= N.
*> \endverbatim
*>
*> \param[in] N1
*> \verbatim
*> N1 is INTEGER
*> The order of the first block (A11, B11). N1 = 0, 1 or 2.
*> \endverbatim
*>
*> \param[in] N2
*> \verbatim
*> N2 is INTEGER
*> The order of the second block (A22, B22). N2 = 0, 1 or 2.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*> WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)).
*> \endverbatim
*>
*> \param[in] LWORK
*> \verbatim
*> LWORK is INTEGER
*> The dimension of the array WORK.
*> LWORK >= MAX( 1, N*(N2+N1), (N2+N1)*(N2+N1)*2 )
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> =0: Successful exit
*> >0: If INFO = 1, the transformed matrix (A, B) would be
*> too far from generalized Schur form; the blocks are
*> not swapped and (A, B) and (Q, Z) are unchanged.
*> The problem of swapping is too ill-conditioned.
*> <0: If INFO = -16: LWORK is too small. Appropriate value
*> for LWORK is returned in WORK(1).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup tgex2
*
*> \par Further Details:
* =====================
*>
*> In the current code both weak and strong stability tests are
*> performed. The user can omit the strong stability test by changing
*> the internal logical parameter WANDS to .FALSE.. See ref. [2] for
*> details.
*
*> \par Contributors:
* ==================
*>
*> Bo Kagstrom and Peter Poromaa, Department of Computing Science,
*> Umea University, S-901 87 Umea, Sweden.
*
*> \par References:
* ================
*>
*> \verbatim
*>
*> [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
*> Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
*> M.S. Moonen et al (eds), Linear Algebra for Large Scale and
*> Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
*>
*> [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
*> Eigenvalues of a Regular Matrix Pair (A, B) and Condition
*> Estimation: Theory, Algorithms and Software,
*> Report UMINF - 94.04, Department of Computing Science, Umea
*> University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
*> Note 87. To appear in Numerical Algorithms, 1996.
*> \endverbatim
*>
* =====================================================================
SUBROUTINE DTGEX2( WANTQ, WANTZ, N, A, LDA, B, LDB, Q, LDQ, Z,
$ LDZ, J1, N1, N2, WORK, LWORK, INFO )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
LOGICAL WANTQ, WANTZ
INTEGER INFO, J1, LDA, LDB, LDQ, LDZ, LWORK, N, N1, N2
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), Q( LDQ, * ),
$ WORK( * ), Z( LDZ, * )
* ..
*
* =====================================================================
* Replaced various illegal calls to DCOPY by calls to DLASET, or by DO
* loops. Sven Hammarling, 1/5/02.
*
* .. Parameters ..
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
DOUBLE PRECISION TWENTY
PARAMETER ( TWENTY = 2.0D+01 )
INTEGER LDST
PARAMETER ( LDST = 4 )
LOGICAL WANDS
PARAMETER ( WANDS = .TRUE. )
* ..
* .. Local Scalars ..
LOGICAL STRONG, WEAK
INTEGER I, IDUM, LINFO, M
DOUBLE PRECISION BQRA21, BRQA21, DDUM, DNORMA, DNORMB, DSCALE,
$ DSUM, EPS, F, G, SA, SB, SCALE, SMLNUM,
$ THRESHA, THRESHB
* ..
* .. Local Arrays ..
INTEGER IWORK( LDST + 2 )
DOUBLE PRECISION AI( 2 ), AR( 2 ), BE( 2 ), IR( LDST, LDST ),
$ IRCOP( LDST, LDST ), LI( LDST, LDST ),
$ LICOP( LDST, LDST ), S( LDST, LDST ),
$ SCPY( LDST, LDST ), T( LDST, LDST ),
$ TAUL( LDST ), TAUR( LDST ), TCPY( LDST, LDST )
* ..
* .. External Functions ..
DOUBLE PRECISION DLAMCH
EXTERNAL DLAMCH
* ..
* .. External Subroutines ..
EXTERNAL DGEMM, DGEQR2, DGERQ2, DLACPY, DLAGV2,
$ DLARTG,
$ DLASET, DLASSQ, DORG2R, DORGR2, DORM2R, DORMR2,
$ DROT, DSCAL, DTGSY2
* ..
* .. Intrinsic Functions ..
INTRINSIC ABS, MAX, SQRT
* ..
* .. Executable Statements ..
*
INFO = 0
*
* Quick return if possible
*
IF( N.LE.1 .OR. N1.LE.0 .OR. N2.LE.0 )
$ RETURN
IF( N1.GT.N .OR. ( J1+N1 ).GT.N )
$ RETURN
M = N1 + N2
IF( LWORK.LT.MAX( 1, N*M, M*M*2 ) ) THEN
INFO = -16
WORK( 1 ) = MAX( 1, N*M, M*M*2 )
RETURN
END IF
*
WEAK = .FALSE.
STRONG = .FALSE.
*
* Make a local copy of selected block
*
CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, LI, LDST )
CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, IR, LDST )
CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA, S, LDST )
CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB, T, LDST )
*
* Compute threshold for testing acceptance of swapping.
*
EPS = DLAMCH( 'P' )
SMLNUM = DLAMCH( 'S' ) / EPS
DSCALE = ZERO
DSUM = ONE
CALL DLACPY( 'Full', M, M, S, LDST, WORK, M )
CALL DLASSQ( M*M, WORK, 1, DSCALE, DSUM )
DNORMA = DSCALE*SQRT( DSUM )
DSCALE = ZERO
DSUM = ONE
CALL DLACPY( 'Full', M, M, T, LDST, WORK, M )
CALL DLASSQ( M*M, WORK, 1, DSCALE, DSUM )
DNORMB = DSCALE*SQRT( DSUM )
*
* THRES has been changed from
* THRESH = MAX( TEN*EPS*SA, SMLNUM )
* to
* THRESH = MAX( TWENTY*EPS*SA, SMLNUM )
* on 04/01/10.
* "Bug" reported by Ondra Kamenik, confirmed by Julie Langou, fixed by
* Jim Demmel and Guillaume Revy. See forum post 1783.
*
THRESHA = MAX( TWENTY*EPS*DNORMA, SMLNUM )
THRESHB = MAX( TWENTY*EPS*DNORMB, SMLNUM )
*
IF( M.EQ.2 ) THEN
*
* CASE 1: Swap 1-by-1 and 1-by-1 blocks.
*
* Compute orthogonal QL and RQ that swap 1-by-1 and 1-by-1 blocks
* using Givens rotations and perform the swap tentatively.
*
F = S( 2, 2 )*T( 1, 1 ) - T( 2, 2 )*S( 1, 1 )
G = S( 2, 2 )*T( 1, 2 ) - T( 2, 2 )*S( 1, 2 )
SA = ABS( S( 2, 2 ) ) * ABS( T( 1, 1 ) )
SB = ABS( S( 1, 1 ) ) * ABS( T( 2, 2 ) )
CALL DLARTG( F, G, IR( 1, 2 ), IR( 1, 1 ), DDUM )
IR( 2, 1 ) = -IR( 1, 2 )
IR( 2, 2 ) = IR( 1, 1 )
CALL DROT( 2, S( 1, 1 ), 1, S( 1, 2 ), 1, IR( 1, 1 ),
$ IR( 2, 1 ) )
CALL DROT( 2, T( 1, 1 ), 1, T( 1, 2 ), 1, IR( 1, 1 ),
$ IR( 2, 1 ) )
IF( SA.GE.SB ) THEN
CALL DLARTG( S( 1, 1 ), S( 2, 1 ), LI( 1, 1 ), LI( 2,
$ 1 ),
$ DDUM )
ELSE
CALL DLARTG( T( 1, 1 ), T( 2, 1 ), LI( 1, 1 ), LI( 2,
$ 1 ),
$ DDUM )
END IF
CALL DROT( 2, S( 1, 1 ), LDST, S( 2, 1 ), LDST, LI( 1, 1 ),
$ LI( 2, 1 ) )
CALL DROT( 2, T( 1, 1 ), LDST, T( 2, 1 ), LDST, LI( 1, 1 ),
$ LI( 2, 1 ) )
LI( 2, 2 ) = LI( 1, 1 )
LI( 1, 2 ) = -LI( 2, 1 )
*
* Weak stability test: |S21| <= O(EPS F-norm((A)))
* and |T21| <= O(EPS F-norm((B)))
*
WEAK = ABS( S( 2, 1 ) ) .LE. THRESHA .AND.
$ ABS( T( 2, 1 ) ) .LE. THRESHB
IF( .NOT.WEAK )
$ GO TO 70
*
IF( WANDS ) THEN
*
* Strong stability test:
* F-norm((A-QL**H*S*QR)) <= O(EPS*F-norm((A)))
* and
* F-norm((B-QL**H*T*QR)) <= O(EPS*F-norm((B)))
*
CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA,
$ WORK( M*M+1 ),
$ M )
CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST,
$ ZERO,
$ WORK, M )
CALL DGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST,
$ ONE,
$ WORK( M*M+1 ), M )
DSCALE = ZERO
DSUM = ONE
CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
SA = DSCALE*SQRT( DSUM )
*
CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB,
$ WORK( M*M+1 ),
$ M )
CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST,
$ ZERO,
$ WORK, M )
CALL DGEMM( 'N', 'T', M, M, M, -ONE, WORK, M, IR, LDST,
$ ONE,
$ WORK( M*M+1 ), M )
DSCALE = ZERO
DSUM = ONE
CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
SB = DSCALE*SQRT( DSUM )
STRONG = SA.LE.THRESHA .AND. SB.LE.THRESHB
IF( .NOT.STRONG )
$ GO TO 70
END IF
*
* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and
* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)).
*
CALL DROT( J1+1, A( 1, J1 ), 1, A( 1, J1+1 ), 1, IR( 1, 1 ),
$ IR( 2, 1 ) )
CALL DROT( J1+1, B( 1, J1 ), 1, B( 1, J1+1 ), 1, IR( 1, 1 ),
$ IR( 2, 1 ) )
CALL DROT( N-J1+1, A( J1, J1 ), LDA, A( J1+1, J1 ), LDA,
$ LI( 1, 1 ), LI( 2, 1 ) )
CALL DROT( N-J1+1, B( J1, J1 ), LDB, B( J1+1, J1 ), LDB,
$ LI( 1, 1 ), LI( 2, 1 ) )
*
* Set N1-by-N2 (2,1) - blocks to ZERO.
*
A( J1+1, J1 ) = ZERO
B( J1+1, J1 ) = ZERO
*
* Accumulate transformations into Q and Z if requested.
*
IF( WANTZ )
$ CALL DROT( N, Z( 1, J1 ), 1, Z( 1, J1+1 ), 1, IR( 1, 1 ),
$ IR( 2, 1 ) )
IF( WANTQ )
$ CALL DROT( N, Q( 1, J1 ), 1, Q( 1, J1+1 ), 1, LI( 1, 1 ),
$ LI( 2, 1 ) )
*
* Exit with INFO = 0 if swap was successfully performed.
*
RETURN
*
ELSE
*
* CASE 2: Swap 1-by-1 and 2-by-2 blocks, or 2-by-2
* and 2-by-2 blocks.
*
* Solve the generalized Sylvester equation
* S11 * R - L * S22 = SCALE * S12
* T11 * R - L * T22 = SCALE * T12
* for R and L. Solutions in LI and IR.
*
CALL DLACPY( 'Full', N1, N2, T( 1, N1+1 ), LDST, LI, LDST )
CALL DLACPY( 'Full', N1, N2, S( 1, N1+1 ), LDST,
$ IR( N2+1, N1+1 ), LDST )
CALL DTGSY2( 'N', 0, N1, N2, S, LDST, S( N1+1, N1+1 ), LDST,
$ IR( N2+1, N1+1 ), LDST, T, LDST, T( N1+1, N1+1 ),
$ LDST, LI, LDST, SCALE, DSUM, DSCALE, IWORK, IDUM,
$ LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
*
* Compute orthogonal matrix QL:
*
* QL**T * LI = [ TL ]
* [ 0 ]
* where
* LI = [ -L ]
* [ SCALE * identity(N2) ]
*
DO 10 I = 1, N2
CALL DSCAL( N1, -ONE, LI( 1, I ), 1 )
LI( N1+I, I ) = SCALE
10 CONTINUE
CALL DGEQR2( M, N2, LI, LDST, TAUL, WORK, LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
CALL DORG2R( M, M, N2, LI, LDST, TAUL, WORK, LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
*
* Compute orthogonal matrix RQ:
*
* IR * RQ**T = [ 0 TR],
*
* where IR = [ SCALE * identity(N1), R ]
*
DO 20 I = 1, N1
IR( N2+I, I ) = SCALE
20 CONTINUE
CALL DGERQ2( N1, M, IR( N2+1, 1 ), LDST, TAUR, WORK, LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
CALL DORGR2( M, M, N1, IR, LDST, TAUR, WORK, LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
*
* Perform the swapping tentatively:
*
CALL DGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, S, LDST, ZERO,
$ WORK, M )
CALL DGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO,
$ S,
$ LDST )
CALL DGEMM( 'T', 'N', M, M, M, ONE, LI, LDST, T, LDST, ZERO,
$ WORK, M )
CALL DGEMM( 'N', 'T', M, M, M, ONE, WORK, M, IR, LDST, ZERO,
$ T,
$ LDST )
CALL DLACPY( 'F', M, M, S, LDST, SCPY, LDST )
CALL DLACPY( 'F', M, M, T, LDST, TCPY, LDST )
CALL DLACPY( 'F', M, M, IR, LDST, IRCOP, LDST )
CALL DLACPY( 'F', M, M, LI, LDST, LICOP, LDST )
*
* Triangularize the B-part by an RQ factorization.
* Apply transformation (from left) to A-part, giving S.
*
CALL DGERQ2( M, M, T, LDST, TAUR, WORK, LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
CALL DORMR2( 'R', 'T', M, M, M, T, LDST, TAUR, S, LDST,
$ WORK,
$ LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
CALL DORMR2( 'L', 'N', M, M, M, T, LDST, TAUR, IR, LDST,
$ WORK,
$ LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
*
* Compute F-norm(S21) in BRQA21. (T21 is 0.)
*
DSCALE = ZERO
DSUM = ONE
DO 30 I = 1, N2
CALL DLASSQ( N1, S( N2+1, I ), 1, DSCALE, DSUM )
30 CONTINUE
BRQA21 = DSCALE*SQRT( DSUM )
*
* Triangularize the B-part by a QR factorization.
* Apply transformation (from right) to A-part, giving S.
*
CALL DGEQR2( M, M, TCPY, LDST, TAUL, WORK, LINFO )
IF( LINFO.NE.0 )
$ GO TO 70
CALL DORM2R( 'L', 'T', M, M, M, TCPY, LDST, TAUL, SCPY,
$ LDST,
$ WORK, INFO )
CALL DORM2R( 'R', 'N', M, M, M, TCPY, LDST, TAUL, LICOP,
$ LDST,
$ WORK, INFO )
IF( LINFO.NE.0 )
$ GO TO 70
*
* Compute F-norm(S21) in BQRA21. (T21 is 0.)
*
DSCALE = ZERO
DSUM = ONE
DO 40 I = 1, N2
CALL DLASSQ( N1, SCPY( N2+1, I ), 1, DSCALE, DSUM )
40 CONTINUE
BQRA21 = DSCALE*SQRT( DSUM )
*
* Decide which method to use.
* Weak stability test:
* F-norm(S21) <= O(EPS * F-norm((S)))
*
IF( BQRA21.LE.BRQA21 .AND. BQRA21.LE.THRESHA ) THEN
CALL DLACPY( 'F', M, M, SCPY, LDST, S, LDST )
CALL DLACPY( 'F', M, M, TCPY, LDST, T, LDST )
CALL DLACPY( 'F', M, M, IRCOP, LDST, IR, LDST )
CALL DLACPY( 'F', M, M, LICOP, LDST, LI, LDST )
ELSE IF( BRQA21.GE.THRESHA ) THEN
GO TO 70
END IF
*
* Set lower triangle of B-part to zero
*
CALL DLASET( 'Lower', M-1, M-1, ZERO, ZERO, T(2,1), LDST )
*
IF( WANDS ) THEN
*
* Strong stability test:
* F-norm((A-QL**H*S*QR)) <= O(EPS*F-norm((A)))
* and
* F-norm((B-QL**H*T*QR)) <= O(EPS*F-norm((B)))
*
CALL DLACPY( 'Full', M, M, A( J1, J1 ), LDA,
$ WORK( M*M+1 ),
$ M )
CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, S, LDST,
$ ZERO,
$ WORK, M )
CALL DGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST,
$ ONE,
$ WORK( M*M+1 ), M )
DSCALE = ZERO
DSUM = ONE
CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
SA = DSCALE*SQRT( DSUM )
*
CALL DLACPY( 'Full', M, M, B( J1, J1 ), LDB,
$ WORK( M*M+1 ),
$ M )
CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, T, LDST,
$ ZERO,
$ WORK, M )
CALL DGEMM( 'N', 'N', M, M, M, -ONE, WORK, M, IR, LDST,
$ ONE,
$ WORK( M*M+1 ), M )
DSCALE = ZERO
DSUM = ONE
CALL DLASSQ( M*M, WORK( M*M+1 ), 1, DSCALE, DSUM )
SB = DSCALE*SQRT( DSUM )
STRONG = SA.LE.THRESHA .AND. SB.LE.THRESHB
IF( .NOT.STRONG )
$ GO TO 70
*
END IF
*
* If the swap is accepted ("weakly" and "strongly"), apply the
* transformations and set N1-by-N2 (2,1)-block to zero.
*
CALL DLASET( 'Full', N1, N2, ZERO, ZERO, S(N2+1,1), LDST )
*
* copy back M-by-M diagonal block starting at index J1 of (A, B)
*
CALL DLACPY( 'F', M, M, S, LDST, A( J1, J1 ), LDA )
CALL DLACPY( 'F', M, M, T, LDST, B( J1, J1 ), LDB )
CALL DLASET( 'Full', LDST, LDST, ZERO, ZERO, T, LDST )
*
* Standardize existing 2-by-2 blocks.
*
CALL DLASET( 'Full', M, M, ZERO, ZERO, WORK, M )
WORK( 1 ) = ONE
T( 1, 1 ) = ONE
IDUM = LWORK - M*M - 2
IF( N2.GT.1 ) THEN
CALL DLAGV2( A( J1, J1 ), LDA, B( J1, J1 ), LDB, AR, AI,
$ BE,
$ WORK( 1 ), WORK( 2 ), T( 1, 1 ), T( 2, 1 ) )
WORK( M+1 ) = -WORK( 2 )
WORK( M+2 ) = WORK( 1 )
T( N2, N2 ) = T( 1, 1 )
T( 1, 2 ) = -T( 2, 1 )
END IF
WORK( M*M ) = ONE
T( M, M ) = ONE
*
IF( N1.GT.1 ) THEN
CALL DLAGV2( A( J1+N2, J1+N2 ), LDA, B( J1+N2, J1+N2 ),
$ LDB,
$ TAUR, TAUL, WORK( M*M+1 ), WORK( N2*M+N2+1 ),
$ WORK( N2*M+N2+2 ), T( N2+1, N2+1 ),
$ T( M, M-1 ) )
WORK( M*M ) = WORK( N2*M+N2+1 )
WORK( M*M-1 ) = -WORK( N2*M+N2+2 )
T( M, M ) = T( N2+1, N2+1 )
T( M-1, M ) = -T( M, M-1 )
END IF
CALL DGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, A( J1,
$ J1+N2 ),
$ LDA, ZERO, WORK( M*M+1 ), N2 )
CALL DLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, A( J1,
$ J1+N2 ),
$ LDA )
CALL DGEMM( 'T', 'N', N2, N1, N2, ONE, WORK, M, B( J1,
$ J1+N2 ),
$ LDB, ZERO, WORK( M*M+1 ), N2 )
CALL DLACPY( 'Full', N2, N1, WORK( M*M+1 ), N2, B( J1,
$ J1+N2 ),
$ LDB )
CALL DGEMM( 'N', 'N', M, M, M, ONE, LI, LDST, WORK, M, ZERO,
$ WORK( M*M+1 ), M )
CALL DLACPY( 'Full', M, M, WORK( M*M+1 ), M, LI, LDST )
CALL DGEMM( 'N', 'N', N2, N1, N1, ONE, A( J1, J1+N2 ), LDA,
$ T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 )
CALL DLACPY( 'Full', N2, N1, WORK, N2, A( J1, J1+N2 ), LDA )
CALL DGEMM( 'N', 'N', N2, N1, N1, ONE, B( J1, J1+N2 ), LDB,
$ T( N2+1, N2+1 ), LDST, ZERO, WORK, N2 )
CALL DLACPY( 'Full', N2, N1, WORK, N2, B( J1, J1+N2 ), LDB )
CALL DGEMM( 'T', 'N', M, M, M, ONE, IR, LDST, T, LDST, ZERO,
$ WORK, M )
CALL DLACPY( 'Full', M, M, WORK, M, IR, LDST )
*
* Accumulate transformations into Q and Z if requested.
*
IF( WANTQ ) THEN
CALL DGEMM( 'N', 'N', N, M, M, ONE, Q( 1, J1 ), LDQ, LI,
$ LDST, ZERO, WORK, N )
CALL DLACPY( 'Full', N, M, WORK, N, Q( 1, J1 ), LDQ )
*
END IF
*
IF( WANTZ ) THEN
CALL DGEMM( 'N', 'N', N, M, M, ONE, Z( 1, J1 ), LDZ, IR,
$ LDST, ZERO, WORK, N )
CALL DLACPY( 'Full', N, M, WORK, N, Z( 1, J1 ), LDZ )
*
END IF
*
* Update (A(J1:J1+M-1, M+J1:N), B(J1:J1+M-1, M+J1:N)) and
* (A(1:J1-1, J1:J1+M), B(1:J1-1, J1:J1+M)).
*
I = J1 + M
IF( I.LE.N ) THEN
CALL DGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST,
$ A( J1, I ), LDA, ZERO, WORK, M )
CALL DLACPY( 'Full', M, N-I+1, WORK, M, A( J1, I ), LDA )
CALL DGEMM( 'T', 'N', M, N-I+1, M, ONE, LI, LDST,
$ B( J1, I ), LDB, ZERO, WORK, M )
CALL DLACPY( 'Full', M, N-I+1, WORK, M, B( J1, I ), LDB )
END IF
I = J1 - 1
IF( I.GT.0 ) THEN
CALL DGEMM( 'N', 'N', I, M, M, ONE, A( 1, J1 ), LDA, IR,
$ LDST, ZERO, WORK, I )
CALL DLACPY( 'Full', I, M, WORK, I, A( 1, J1 ), LDA )
CALL DGEMM( 'N', 'N', I, M, M, ONE, B( 1, J1 ), LDB, IR,
$ LDST, ZERO, WORK, I )
CALL DLACPY( 'Full', I, M, WORK, I, B( 1, J1 ), LDB )
END IF
*
* Exit with INFO = 0 if swap was successfully performed.
*
RETURN
*
END IF
*
* Exit with INFO = 1 if swap was rejected.
*
70 CONTINUE
*
INFO = 1
RETURN
*
* End of DTGEX2
*
END
*> \brief \b DTGSY2 solves the generalized Sylvester equation (unblocked algorithm).
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download DTGSY2 + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC, D,
* LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL,
* IWORK, PQ, INFO )
*
* .. Scalar Arguments ..
* CHARACTER TRANS
* INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N,
* $ PQ
* DOUBLE PRECISION RDSCAL, RDSUM, SCALE
* ..
* .. Array Arguments ..
* INTEGER IWORK( * )
* DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ),
* $ D( LDD, * ), E( LDE, * ), F( LDF, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DTGSY2 solves the generalized Sylvester equation:
*>
*> A * R - L * B = scale * C (1)
*> D * R - L * E = scale * F,
*>
*> using Level 1 and 2 BLAS. where R and L are unknown M-by-N matrices,
*> (A, D), (B, E) and (C, F) are given matrix pairs of size M-by-M,
*> N-by-N and M-by-N, respectively, with real entries. (A, D) and (B, E)
*> must be in generalized Schur canonical form, i.e. A, B are upper
*> quasi triangular and D, E are upper triangular. The solution (R, L)
*> overwrites (C, F). 0 <= SCALE <= 1 is an output scaling factor
*> chosen to avoid overflow.
*>
*> In matrix notation solving equation (1) corresponds to solve
*> Z*x = scale*b, where Z is defined as
*>
*> Z = [ kron(In, A) -kron(B**T, Im) ] (2)
*> [ kron(In, D) -kron(E**T, Im) ],
*>
*> Ik is the identity matrix of size k and X**T is the transpose of X.
*> kron(X, Y) is the Kronecker product between the matrices X and Y.
*> In the process of solving (1), we solve a number of such systems
*> where Dim(In), Dim(In) = 1 or 2.
*>
*> If TRANS = 'T', solve the transposed system Z**T*y = scale*b for y,
*> which is equivalent to solve for R and L in
*>
*> A**T * R + D**T * L = scale * C (3)
*> R * B**T + L * E**T = scale * -F
*>
*> This case is used to compute an estimate of Dif[(A, D), (B, E)] =
*> sigma_min(Z) using reverse communication with DLACON.
*>
*> DTGSY2 also (IJOB >= 1) contributes to the computation in DTGSYL
*> of an upper bound on the separation between to matrix pairs. Then
*> the input (A, D), (B, E) are sub-pencils of the matrix pair in
*> DTGSYL. See DTGSYL for details.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> = 'N': solve the generalized Sylvester equation (1).
*> = 'T': solve the 'transposed' system (3).
*> \endverbatim
*>
*> \param[in] IJOB
*> \verbatim
*> IJOB is INTEGER
*> Specifies what kind of functionality to be performed.
*> = 0: solve (1) only.
*> = 1: A contribution from this subsystem to a Frobenius
*> norm-based estimate of the separation between two matrix
*> pairs is computed. (look ahead strategy is used).
*> = 2: A contribution from this subsystem to a Frobenius
*> norm-based estimate of the separation between two matrix
*> pairs is computed. (DGECON on sub-systems is used.)
*> Not referenced if TRANS = 'T'.
*> \endverbatim
*>
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> On entry, M specifies the order of A and D, and the row
*> dimension of C, F, R and L.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of B and E, and the column
*> dimension of C, F, R and L.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA, M)
*> On entry, A contains an upper quasi triangular matrix.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the matrix A. LDA >= max(1, M).
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is DOUBLE PRECISION array, dimension (LDB, N)
*> On entry, B contains an upper quasi triangular matrix.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*> LDB is INTEGER
*> The leading dimension of the matrix B. LDB >= max(1, N).
*> \endverbatim
*>
*> \param[in,out] C
*> \verbatim
*> C is DOUBLE PRECISION array, dimension (LDC, N)
*> On entry, C contains the right-hand-side of the first matrix
*> equation in (1).
*> On exit, if IJOB = 0, C has been overwritten by the
*> solution R.
*> \endverbatim
*>
*> \param[in] LDC
*> \verbatim
*> LDC is INTEGER
*> The leading dimension of the matrix C. LDC >= max(1, M).
*> \endverbatim
*>
*> \param[in] D
*> \verbatim
*> D is DOUBLE PRECISION array, dimension (LDD, M)
*> On entry, D contains an upper triangular matrix.
*> \endverbatim
*>
*> \param[in] LDD
*> \verbatim
*> LDD is INTEGER
*> The leading dimension of the matrix D. LDD >= max(1, M).
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*> E is DOUBLE PRECISION array, dimension (LDE, N)
*> On entry, E contains an upper triangular matrix.
*> \endverbatim
*>
*> \param[in] LDE
*> \verbatim
*> LDE is INTEGER
*> The leading dimension of the matrix E. LDE >= max(1, N).
*> \endverbatim
*>
*> \param[in,out] F
*> \verbatim
*> F is DOUBLE PRECISION array, dimension (LDF, N)
*> On entry, F contains the right-hand-side of the second matrix
*> equation in (1).
*> On exit, if IJOB = 0, F has been overwritten by the
*> solution L.
*> \endverbatim
*>
*> \param[in] LDF
*> \verbatim
*> LDF is INTEGER
*> The leading dimension of the matrix F. LDF >= max(1, M).
*> \endverbatim
*>
*> \param[out] SCALE
*> \verbatim
*> SCALE is DOUBLE PRECISION
*> On exit, 0 <= SCALE <= 1. If 0 < SCALE < 1, the solutions
*> R and L (C and F on entry) will hold the solutions to a
*> slightly perturbed system but the input matrices A, B, D and
*> E have not been changed. If SCALE = 0, R and L will hold the
*> solutions to the homogeneous system with C = F = 0. Normally,
*> SCALE = 1.
*> \endverbatim
*>
*> \param[in,out] RDSUM
*> \verbatim
*> RDSUM is DOUBLE PRECISION
*> On entry, the sum of squares of computed contributions to
*> the Dif-estimate under computation by DTGSYL, where the
*> scaling factor RDSCAL (see below) has been factored out.
*> On exit, the corresponding sum of squares updated with the
*> contributions from the current sub-system.
*> If TRANS = 'T' RDSUM is not touched.
*> NOTE: RDSUM only makes sense when DTGSY2 is called by DTGSYL.
*> \endverbatim
*>
*> \param[in,out] RDSCAL
*> \verbatim
*> RDSCAL is DOUBLE PRECISION
*> On entry, scaling factor used to prevent overflow in RDSUM.
*> On exit, RDSCAL is updated w.r.t. the current contributions
*> in RDSUM.
*> If TRANS = 'T', RDSCAL is not touched.
*> NOTE: RDSCAL only makes sense when DTGSY2 is called by
*> DTGSYL.
*> \endverbatim
*>
*> \param[out] IWORK
*> \verbatim
*> IWORK is INTEGER array, dimension (M+N+2)
*> \endverbatim
*>
*> \param[out] PQ
*> \verbatim
*> PQ is INTEGER
*> On exit, the number of subsystems (of size 2-by-2, 4-by-4 and
*> 8-by-8) solved by this routine.
*> \endverbatim
*>
*> \param[out] INFO
*> \verbatim
*> INFO is INTEGER
*> On exit, if INFO is set to
*> =0: Successful exit
*> <0: If INFO = -i, the i-th argument had an illegal value.
*> >0: The matrix pairs (A, D) and (B, E) have common or very
*> close eigenvalues.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup tgsy2
*
*> \par Contributors:
* ==================
*>
*> Bo Kagstrom and Peter Poromaa, Department of Computing Science,
*> Umea University, S-901 87 Umea, Sweden.
*
* =====================================================================
SUBROUTINE DTGSY2( TRANS, IJOB, M, N, A, LDA, B, LDB, C, LDC,
$ D,
$ LDD, E, LDE, F, LDF, SCALE, RDSUM, RDSCAL,
$ IWORK, PQ, INFO )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER TRANS
INTEGER IJOB, INFO, LDA, LDB, LDC, LDD, LDE, LDF, M, N,
$ PQ
DOUBLE PRECISION RDSCAL, RDSUM, SCALE
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
DOUBLE PRECISION A( LDA, * ), B( LDB, * ), C( LDC, * ),
$ D( LDD, * ), E( LDE, * ), F( LDF, * )
* ..
*
* =====================================================================
* Replaced various illegal calls to DCOPY by calls to DLASET.
* Sven Hammarling, 27/5/02.
*
* .. Parameters ..
INTEGER LDZ
PARAMETER ( LDZ = 8 )
DOUBLE PRECISION ZERO, ONE
PARAMETER ( ZERO = 0.0D+0, ONE = 1.0D+0 )
* ..
* .. Local Scalars ..
LOGICAL NOTRAN
INTEGER I, IE, IERR, II, IS, ISP1, J, JE, JJ, JS, JSP1,
$ K, MB, NB, P, Q, ZDIM
DOUBLE PRECISION ALPHA, SCALOC
* ..
* .. Local Arrays ..
INTEGER IPIV( LDZ ), JPIV( LDZ )
DOUBLE PRECISION RHS( LDZ ), Z( LDZ, LDZ )
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL DAXPY, DCOPY, DGEMM, DGEMV, DGER,
$ DGESC2,
$ DGETC2, DLASET, DLATDF, DSCAL, XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
* .. Executable Statements ..
*
* Decode and test input parameters
*
INFO = 0
IERR = 0
NOTRAN = LSAME( TRANS, 'N' )
IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN
INFO = -1
ELSE IF( NOTRAN ) THEN
IF( ( IJOB.LT.0 ) .OR. ( IJOB.GT.2 ) ) THEN
INFO = -2
END IF
END IF
IF( INFO.EQ.0 ) THEN
IF( M.LE.0 ) THEN
INFO = -3
ELSE IF( N.LE.0 ) THEN
INFO = -4
ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
INFO = -6
ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
INFO = -8
ELSE IF( LDC.LT.MAX( 1, M ) ) THEN
INFO = -10
ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
INFO = -12
ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
INFO = -14
ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
INFO = -16
END IF
END IF
IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DTGSY2', -INFO )
RETURN
END IF
*
* Determine block structure of A
*
PQ = 0
P = 0
I = 1
10 CONTINUE
IF( I.GT.M )
$ GO TO 20
P = P + 1
IWORK( P ) = I
IF( I.EQ.M )
$ GO TO 20
IF( A( I+1, I ).NE.ZERO ) THEN
I = I + 2
ELSE
I = I + 1
END IF
GO TO 10
20 CONTINUE
IWORK( P+1 ) = M + 1
*
* Determine block structure of B
*
Q = P + 1
J = 1
30 CONTINUE
IF( J.GT.N )
$ GO TO 40
Q = Q + 1
IWORK( Q ) = J
IF( J.EQ.N )
$ GO TO 40
IF( B( J+1, J ).NE.ZERO ) THEN
J = J + 2
ELSE
J = J + 1
END IF
GO TO 30
40 CONTINUE
IWORK( Q+1 ) = N + 1
PQ = P*( Q-P-1 )
*
IF( NOTRAN ) THEN
*
* Solve (I, J) - subsystem
* A(I, I) * R(I, J) - L(I, J) * B(J, J) = C(I, J)
* D(I, I) * R(I, J) - L(I, J) * E(J, J) = F(I, J)
* for I = P, P - 1, ..., 1; J = 1, 2, ..., Q
*
SCALE = ONE
SCALOC = ONE
DO 120 J = P + 2, Q
JS = IWORK( J )
JSP1 = JS + 1
JE = IWORK( J+1 ) - 1
NB = JE - JS + 1
DO 110 I = P, 1, -1
*
IS = IWORK( I )
ISP1 = IS + 1
IE = IWORK( I+1 ) - 1
MB = IE - IS + 1
ZDIM = MB*NB*2
*
IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN
*
* Build a 2-by-2 system Z * x = RHS
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = D( IS, IS )
Z( 1, 2 ) = -B( JS, JS )
Z( 2, 2 ) = -E( JS, JS )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( IS, JS )
RHS( 2 ) = F( IS, JS )
*
* Solve Z * x = RHS
*
CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
*
IF( IJOB.EQ.0 ) THEN
CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
$ SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 50 K = 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
50 CONTINUE
SCALE = SCALE*SCALOC
END IF
ELSE
CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
$ RDSCAL, IPIV, JPIV )
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
F( IS, JS ) = RHS( 2 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( I.GT.1 ) THEN
ALPHA = -RHS( 1 )
CALL DAXPY( IS-1, ALPHA, A( 1, IS ), 1, C( 1,
$ JS ),
$ 1 )
CALL DAXPY( IS-1, ALPHA, D( 1, IS ), 1, F( 1,
$ JS ),
$ 1 )
END IF
IF( J.LT.Q ) THEN
CALL DAXPY( N-JE, RHS( 2 ), B( JS, JE+1 ), LDB,
$ C( IS, JE+1 ), LDC )
CALL DAXPY( N-JE, RHS( 2 ), E( JS, JE+1 ), LDE,
$ F( IS, JE+1 ), LDF )
END IF
*
ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN
*
* Build a 4-by-4 system Z * x = RHS
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = ZERO
Z( 3, 1 ) = D( IS, IS )
Z( 4, 1 ) = ZERO
*
Z( 1, 2 ) = ZERO
Z( 2, 2 ) = A( IS, IS )
Z( 3, 2 ) = ZERO
Z( 4, 2 ) = D( IS, IS )
*
Z( 1, 3 ) = -B( JS, JS )
Z( 2, 3 ) = -B( JS, JSP1 )
Z( 3, 3 ) = -E( JS, JS )
Z( 4, 3 ) = -E( JS, JSP1 )
*
Z( 1, 4 ) = -B( JSP1, JS )
Z( 2, 4 ) = -B( JSP1, JSP1 )
Z( 3, 4 ) = ZERO
Z( 4, 4 ) = -E( JSP1, JSP1 )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( IS, JS )
RHS( 2 ) = C( IS, JSP1 )
RHS( 3 ) = F( IS, JS )
RHS( 4 ) = F( IS, JSP1 )
*
* Solve Z * x = RHS
*
CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
*
IF( IJOB.EQ.0 ) THEN
CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
$ SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 60 K = 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
60 CONTINUE
SCALE = SCALE*SCALOC
END IF
ELSE
CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
$ RDSCAL, IPIV, JPIV )
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
C( IS, JSP1 ) = RHS( 2 )
F( IS, JS ) = RHS( 3 )
F( IS, JSP1 ) = RHS( 4 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( I.GT.1 ) THEN
CALL DGER( IS-1, NB, -ONE, A( 1, IS ), 1,
$ RHS( 1 ),
$ 1, C( 1, JS ), LDC )
CALL DGER( IS-1, NB, -ONE, D( 1, IS ), 1,
$ RHS( 1 ),
$ 1, F( 1, JS ), LDF )
END IF
IF( J.LT.Q ) THEN
CALL DAXPY( N-JE, RHS( 3 ), B( JS, JE+1 ), LDB,
$ C( IS, JE+1 ), LDC )
CALL DAXPY( N-JE, RHS( 3 ), E( JS, JE+1 ), LDE,
$ F( IS, JE+1 ), LDF )
CALL DAXPY( N-JE, RHS( 4 ), B( JSP1, JE+1 ),
$ LDB,
$ C( IS, JE+1 ), LDC )
CALL DAXPY( N-JE, RHS( 4 ), E( JSP1, JE+1 ),
$ LDE,
$ F( IS, JE+1 ), LDF )
END IF
*
ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN
*
* Build a 4-by-4 system Z * x = RHS
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = A( ISP1, IS )
Z( 3, 1 ) = D( IS, IS )
Z( 4, 1 ) = ZERO
*
Z( 1, 2 ) = A( IS, ISP1 )
Z( 2, 2 ) = A( ISP1, ISP1 )
Z( 3, 2 ) = D( IS, ISP1 )
Z( 4, 2 ) = D( ISP1, ISP1 )
*
Z( 1, 3 ) = -B( JS, JS )
Z( 2, 3 ) = ZERO
Z( 3, 3 ) = -E( JS, JS )
Z( 4, 3 ) = ZERO
*
Z( 1, 4 ) = ZERO
Z( 2, 4 ) = -B( JS, JS )
Z( 3, 4 ) = ZERO
Z( 4, 4 ) = -E( JS, JS )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( IS, JS )
RHS( 2 ) = C( ISP1, JS )
RHS( 3 ) = F( IS, JS )
RHS( 4 ) = F( ISP1, JS )
*
* Solve Z * x = RHS
*
CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
IF( IJOB.EQ.0 ) THEN
CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
$ SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 70 K = 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
70 CONTINUE
SCALE = SCALE*SCALOC
END IF
ELSE
CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
$ RDSCAL, IPIV, JPIV )
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
C( ISP1, JS ) = RHS( 2 )
F( IS, JS ) = RHS( 3 )
F( ISP1, JS ) = RHS( 4 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( I.GT.1 ) THEN
CALL DGEMV( 'N', IS-1, MB, -ONE, A( 1, IS ),
$ LDA,
$ RHS( 1 ), 1, ONE, C( 1, JS ), 1 )
CALL DGEMV( 'N', IS-1, MB, -ONE, D( 1, IS ),
$ LDD,
$ RHS( 1 ), 1, ONE, F( 1, JS ), 1 )
END IF
IF( J.LT.Q ) THEN
CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1,
$ B( JS, JE+1 ), LDB, C( IS, JE+1 ), LDC )
CALL DGER( MB, N-JE, ONE, RHS( 3 ), 1,
$ E( JS, JE+1 ), LDE, F( IS, JE+1 ), LDF )
END IF
*
ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN
*
* Build an 8-by-8 system Z * x = RHS
*
CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ )
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = A( ISP1, IS )
Z( 5, 1 ) = D( IS, IS )
*
Z( 1, 2 ) = A( IS, ISP1 )
Z( 2, 2 ) = A( ISP1, ISP1 )
Z( 5, 2 ) = D( IS, ISP1 )
Z( 6, 2 ) = D( ISP1, ISP1 )
*
Z( 3, 3 ) = A( IS, IS )
Z( 4, 3 ) = A( ISP1, IS )
Z( 7, 3 ) = D( IS, IS )
*
Z( 3, 4 ) = A( IS, ISP1 )
Z( 4, 4 ) = A( ISP1, ISP1 )
Z( 7, 4 ) = D( IS, ISP1 )
Z( 8, 4 ) = D( ISP1, ISP1 )
*
Z( 1, 5 ) = -B( JS, JS )
Z( 3, 5 ) = -B( JS, JSP1 )
Z( 5, 5 ) = -E( JS, JS )
Z( 7, 5 ) = -E( JS, JSP1 )
*
Z( 2, 6 ) = -B( JS, JS )
Z( 4, 6 ) = -B( JS, JSP1 )
Z( 6, 6 ) = -E( JS, JS )
Z( 8, 6 ) = -E( JS, JSP1 )
*
Z( 1, 7 ) = -B( JSP1, JS )
Z( 3, 7 ) = -B( JSP1, JSP1 )
Z( 7, 7 ) = -E( JSP1, JSP1 )
*
Z( 2, 8 ) = -B( JSP1, JS )
Z( 4, 8 ) = -B( JSP1, JSP1 )
Z( 8, 8 ) = -E( JSP1, JSP1 )
*
* Set up right hand side(s)
*
K = 1
II = MB*NB + 1
DO 80 JJ = 0, NB - 1
CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 )
CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ),
$ 1 )
K = K + MB
II = II + MB
80 CONTINUE
*
* Solve Z * x = RHS
*
CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
IF( IJOB.EQ.0 ) THEN
CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
$ SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 90 K = 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
90 CONTINUE
SCALE = SCALE*SCALOC
END IF
ELSE
CALL DLATDF( IJOB, ZDIM, Z, LDZ, RHS, RDSUM,
$ RDSCAL, IPIV, JPIV )
END IF
*
* Unpack solution vector(s)
*
K = 1
II = MB*NB + 1
DO 100 JJ = 0, NB - 1
CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 )
CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ),
$ 1 )
K = K + MB
II = II + MB
100 CONTINUE
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( I.GT.1 ) THEN
CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
$ A( 1, IS ), LDA, RHS( 1 ), MB, ONE,
$ C( 1, JS ), LDC )
CALL DGEMM( 'N', 'N', IS-1, NB, MB, -ONE,
$ D( 1, IS ), LDD, RHS( 1 ), MB, ONE,
$ F( 1, JS ), LDF )
END IF
IF( J.LT.Q ) THEN
K = MB*NB + 1
CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE,
$ RHS( K ),
$ MB, B( JS, JE+1 ), LDB, ONE,
$ C( IS, JE+1 ), LDC )
CALL DGEMM( 'N', 'N', MB, N-JE, NB, ONE,
$ RHS( K ),
$ MB, E( JS, JE+1 ), LDE, ONE,
$ F( IS, JE+1 ), LDF )
END IF
*
END IF
*
110 CONTINUE
120 CONTINUE
ELSE
*
* Solve (I, J) - subsystem
* A(I, I)**T * R(I, J) + D(I, I)**T * L(J, J) = C(I, J)
* R(I, I) * B(J, J) + L(I, J) * E(J, J) = -F(I, J)
* for I = 1, 2, ..., P, J = Q, Q - 1, ..., 1
*
SCALE = ONE
SCALOC = ONE
DO 200 I = 1, P
*
IS = IWORK( I )
ISP1 = IS + 1
IE = IWORK ( I+1 ) - 1
MB = IE - IS + 1
DO 190 J = Q, P + 2, -1
*
JS = IWORK( J )
JSP1 = JS + 1
JE = IWORK( J+1 ) - 1
NB = JE - JS + 1
ZDIM = MB*NB*2
IF( ( MB.EQ.1 ) .AND. ( NB.EQ.1 ) ) THEN
*
* Build a 2-by-2 system Z**T * x = RHS
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = -B( JS, JS )
Z( 1, 2 ) = D( IS, IS )
Z( 2, 2 ) = -E( JS, JS )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( IS, JS )
RHS( 2 ) = F( IS, JS )
*
* Solve Z**T * x = RHS
*
CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
*
CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
$ SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 130 K = 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
130 CONTINUE
SCALE = SCALE*SCALOC
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
F( IS, JS ) = RHS( 2 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( J.GT.P+2 ) THEN
ALPHA = RHS( 1 )
CALL DAXPY( JS-1, ALPHA, B( 1, JS ), 1, F( IS,
$ 1 ),
$ LDF )
ALPHA = RHS( 2 )
CALL DAXPY( JS-1, ALPHA, E( 1, JS ), 1, F( IS,
$ 1 ),
$ LDF )
END IF
IF( I.LT.P ) THEN
ALPHA = -RHS( 1 )
CALL DAXPY( M-IE, ALPHA, A( IS, IE+1 ), LDA,
$ C( IE+1, JS ), 1 )
ALPHA = -RHS( 2 )
CALL DAXPY( M-IE, ALPHA, D( IS, IE+1 ), LDD,
$ C( IE+1, JS ), 1 )
END IF
*
ELSE IF( ( MB.EQ.1 ) .AND. ( NB.EQ.2 ) ) THEN
*
* Build a 4-by-4 system Z**T * x = RHS
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = ZERO
Z( 3, 1 ) = -B( JS, JS )
Z( 4, 1 ) = -B( JSP1, JS )
*
Z( 1, 2 ) = ZERO
Z( 2, 2 ) = A( IS, IS )
Z( 3, 2 ) = -B( JS, JSP1 )
Z( 4, 2 ) = -B( JSP1, JSP1 )
*
Z( 1, 3 ) = D( IS, IS )
Z( 2, 3 ) = ZERO
Z( 3, 3 ) = -E( JS, JS )
Z( 4, 3 ) = ZERO
*
Z( 1, 4 ) = ZERO
Z( 2, 4 ) = D( IS, IS )
Z( 3, 4 ) = -E( JS, JSP1 )
Z( 4, 4 ) = -E( JSP1, JSP1 )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( IS, JS )
RHS( 2 ) = C( IS, JSP1 )
RHS( 3 ) = F( IS, JS )
RHS( 4 ) = F( IS, JSP1 )
*
* Solve Z**T * x = RHS
*
CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
$ SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 140 K = 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
140 CONTINUE
SCALE = SCALE*SCALOC
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
C( IS, JSP1 ) = RHS( 2 )
F( IS, JS ) = RHS( 3 )
F( IS, JSP1 ) = RHS( 4 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( J.GT.P+2 ) THEN
CALL DAXPY( JS-1, RHS( 1 ), B( 1, JS ), 1,
$ F( IS, 1 ), LDF )
CALL DAXPY( JS-1, RHS( 2 ), B( 1, JSP1 ), 1,
$ F( IS, 1 ), LDF )
CALL DAXPY( JS-1, RHS( 3 ), E( 1, JS ), 1,
$ F( IS, 1 ), LDF )
CALL DAXPY( JS-1, RHS( 4 ), E( 1, JSP1 ), 1,
$ F( IS, 1 ), LDF )
END IF
IF( I.LT.P ) THEN
CALL DGER( M-IE, NB, -ONE, A( IS, IE+1 ), LDA,
$ RHS( 1 ), 1, C( IE+1, JS ), LDC )
CALL DGER( M-IE, NB, -ONE, D( IS, IE+1 ), LDD,
$ RHS( 3 ), 1, C( IE+1, JS ), LDC )
END IF
*
ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.1 ) ) THEN
*
* Build a 4-by-4 system Z**T * x = RHS
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = A( IS, ISP1 )
Z( 3, 1 ) = -B( JS, JS )
Z( 4, 1 ) = ZERO
*
Z( 1, 2 ) = A( ISP1, IS )
Z( 2, 2 ) = A( ISP1, ISP1 )
Z( 3, 2 ) = ZERO
Z( 4, 2 ) = -B( JS, JS )
*
Z( 1, 3 ) = D( IS, IS )
Z( 2, 3 ) = D( IS, ISP1 )
Z( 3, 3 ) = -E( JS, JS )
Z( 4, 3 ) = ZERO
*
Z( 1, 4 ) = ZERO
Z( 2, 4 ) = D( ISP1, ISP1 )
Z( 3, 4 ) = ZERO
Z( 4, 4 ) = -E( JS, JS )
*
* Set up right hand side(s)
*
RHS( 1 ) = C( IS, JS )
RHS( 2 ) = C( ISP1, JS )
RHS( 3 ) = F( IS, JS )
RHS( 4 ) = F( ISP1, JS )
*
* Solve Z**T * x = RHS
*
CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
*
CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
$ SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 150 K = 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
150 CONTINUE
SCALE = SCALE*SCALOC
END IF
*
* Unpack solution vector(s)
*
C( IS, JS ) = RHS( 1 )
C( ISP1, JS ) = RHS( 2 )
F( IS, JS ) = RHS( 3 )
F( ISP1, JS ) = RHS( 4 )
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( J.GT.P+2 ) THEN
CALL DGER( MB, JS-1, ONE, RHS( 1 ), 1, B( 1,
$ JS ),
$ 1, F( IS, 1 ), LDF )
CALL DGER( MB, JS-1, ONE, RHS( 3 ), 1, E( 1,
$ JS ),
$ 1, F( IS, 1 ), LDF )
END IF
IF( I.LT.P ) THEN
CALL DGEMV( 'T', MB, M-IE, -ONE, A( IS, IE+1 ),
$ LDA, RHS( 1 ), 1, ONE, C( IE+1, JS ),
$ 1 )
CALL DGEMV( 'T', MB, M-IE, -ONE, D( IS, IE+1 ),
$ LDD, RHS( 3 ), 1, ONE, C( IE+1, JS ),
$ 1 )
END IF
*
ELSE IF( ( MB.EQ.2 ) .AND. ( NB.EQ.2 ) ) THEN
*
* Build an 8-by-8 system Z**T * x = RHS
*
CALL DLASET( 'F', LDZ, LDZ, ZERO, ZERO, Z, LDZ )
*
Z( 1, 1 ) = A( IS, IS )
Z( 2, 1 ) = A( IS, ISP1 )
Z( 5, 1 ) = -B( JS, JS )
Z( 7, 1 ) = -B( JSP1, JS )
*
Z( 1, 2 ) = A( ISP1, IS )
Z( 2, 2 ) = A( ISP1, ISP1 )
Z( 6, 2 ) = -B( JS, JS )
Z( 8, 2 ) = -B( JSP1, JS )
*
Z( 3, 3 ) = A( IS, IS )
Z( 4, 3 ) = A( IS, ISP1 )
Z( 5, 3 ) = -B( JS, JSP1 )
Z( 7, 3 ) = -B( JSP1, JSP1 )
*
Z( 3, 4 ) = A( ISP1, IS )
Z( 4, 4 ) = A( ISP1, ISP1 )
Z( 6, 4 ) = -B( JS, JSP1 )
Z( 8, 4 ) = -B( JSP1, JSP1 )
*
Z( 1, 5 ) = D( IS, IS )
Z( 2, 5 ) = D( IS, ISP1 )
Z( 5, 5 ) = -E( JS, JS )
*
Z( 2, 6 ) = D( ISP1, ISP1 )
Z( 6, 6 ) = -E( JS, JS )
*
Z( 3, 7 ) = D( IS, IS )
Z( 4, 7 ) = D( IS, ISP1 )
Z( 5, 7 ) = -E( JS, JSP1 )
Z( 7, 7 ) = -E( JSP1, JSP1 )
*
Z( 4, 8 ) = D( ISP1, ISP1 )
Z( 6, 8 ) = -E( JS, JSP1 )
Z( 8, 8 ) = -E( JSP1, JSP1 )
*
* Set up right hand side(s)
*
K = 1
II = MB*NB + 1
DO 160 JJ = 0, NB - 1
CALL DCOPY( MB, C( IS, JS+JJ ), 1, RHS( K ), 1 )
CALL DCOPY( MB, F( IS, JS+JJ ), 1, RHS( II ),
$ 1 )
K = K + MB
II = II + MB
160 CONTINUE
*
*
* Solve Z**T * x = RHS
*
CALL DGETC2( ZDIM, Z, LDZ, IPIV, JPIV, IERR )
IF( IERR.GT.0 )
$ INFO = IERR
*
CALL DGESC2( ZDIM, Z, LDZ, RHS, IPIV, JPIV,
$ SCALOC )
IF( SCALOC.NE.ONE ) THEN
DO 170 K = 1, N
CALL DSCAL( M, SCALOC, C( 1, K ), 1 )
CALL DSCAL( M, SCALOC, F( 1, K ), 1 )
170 CONTINUE
SCALE = SCALE*SCALOC
END IF
*
* Unpack solution vector(s)
*
K = 1
II = MB*NB + 1
DO 180 JJ = 0, NB - 1
CALL DCOPY( MB, RHS( K ), 1, C( IS, JS+JJ ), 1 )
CALL DCOPY( MB, RHS( II ), 1, F( IS, JS+JJ ),
$ 1 )
K = K + MB
II = II + MB
180 CONTINUE
*
* Substitute R(I, J) and L(I, J) into remaining
* equation.
*
IF( J.GT.P+2 ) THEN
CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE,
$ C( IS, JS ), LDC, B( 1, JS ), LDB, ONE,
$ F( IS, 1 ), LDF )
CALL DGEMM( 'N', 'T', MB, JS-1, NB, ONE,
$ F( IS, JS ), LDF, E( 1, JS ), LDE, ONE,
$ F( IS, 1 ), LDF )
END IF
IF( I.LT.P ) THEN
CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
$ A( IS, IE+1 ), LDA, C( IS, JS ), LDC,
$ ONE, C( IE+1, JS ), LDC )
CALL DGEMM( 'T', 'N', M-IE, NB, MB, -ONE,
$ D( IS, IE+1 ), LDD, F( IS, JS ), LDF,
$ ONE, C( IE+1, JS ), LDC )
END IF
*
END IF
*
190 CONTINUE
200 CONTINUE
*
END IF
RETURN
*
* End of DTGSY2
*
END
*> \brief \b DTRSV
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,LDA,N
* CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A(LDA,*),X(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DTRSV solves one of the systems of equations
*>
*> A*x = b, or A**T*x = b,
*>
*> where b and x are n element vectors and A is an n by n unit, or
*> non-unit, upper or lower triangular matrix.
*>
*> No test for singularity or near-singularity is included in this
*> routine. Such tests must be performed before calling this routine.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] UPLO
*> \verbatim
*> UPLO is CHARACTER*1
*> On entry, UPLO specifies whether the matrix is an upper or
*> lower triangular matrix as follows:
*>
*> UPLO = 'U' or 'u' A is an upper triangular matrix.
*>
*> UPLO = 'L' or 'l' A is a lower triangular matrix.
*> \endverbatim
*>
*> \param[in] TRANS
*> \verbatim
*> TRANS is CHARACTER*1
*> On entry, TRANS specifies the equations to be solved as
*> follows:
*>
*> TRANS = 'N' or 'n' A*x = b.
*>
*> TRANS = 'T' or 't' A**T*x = b.
*>
*> TRANS = 'C' or 'c' A**T*x = b.
*> \endverbatim
*>
*> \param[in] DIAG
*> \verbatim
*> DIAG is CHARACTER*1
*> On entry, DIAG specifies whether or not A is unit
*> triangular as follows:
*>
*> DIAG = 'U' or 'u' A is assumed to be unit triangular.
*>
*> DIAG = 'N' or 'n' A is not assumed to be unit
*> triangular.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> On entry, N specifies the order of the matrix A.
*> N must be at least zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension ( LDA, N )
*> Before entry with UPLO = 'U' or 'u', the leading n by n
*> upper triangular part of the array A must contain the upper
*> triangular matrix and the strictly lower triangular part of
*> A is not referenced.
*> Before entry with UPLO = 'L' or 'l', the leading n by n
*> lower triangular part of the array A must contain the lower
*> triangular matrix and the strictly upper triangular part of
*> A is not referenced.
*> Note that when DIAG = 'U' or 'u', the diagonal elements of
*> A are not referenced either, but are assumed to be unity.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> On entry, LDA specifies the first dimension of A as declared
*> in the calling (sub) program. LDA must be at least
*> max( 1, n ).
*> \endverbatim
*>
*> \param[in,out] X
*> \verbatim
*> X is DOUBLE PRECISION array, dimension at least
*> ( 1 + ( n - 1 )*abs( INCX ) ).
*> Before entry, the incremented array X must contain the n
*> element right-hand side vector b. On exit, X is overwritten
*> with the solution vector x.
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> On entry, INCX specifies the increment for the elements of
*> X. INCX must not be zero.
*>
*> Level 2 Blas routine.
*>
*> -- Written on 22-October-1986.
*> Jack Dongarra, Argonne National Lab.
*> Jeremy Du Croz, Nag Central Office.
*> Sven Hammarling, Nag Central Office.
*> Richard Hanson, Sandia National Labs.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup trsv
*
* =====================================================================
SUBROUTINE DTRSV(UPLO,TRANS,DIAG,N,A,LDA,X,INCX)
*
* -- Reference BLAS level2 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INCX,LDA,N
CHARACTER DIAG,TRANS,UPLO
* ..
* .. Array Arguments ..
DOUBLE PRECISION A(LDA,*),X(*)
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER (ZERO=0.0D+0)
* ..
* .. Local Scalars ..
DOUBLE PRECISION TEMP
INTEGER I,INFO,IX,J,JX,KX
LOGICAL NOUNIT
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. External Subroutines ..
EXTERNAL XERBLA
* ..
* .. Intrinsic Functions ..
INTRINSIC MAX
* ..
*
* Test the input parameters.
*
INFO = 0
IF (.NOT.LSAME(UPLO,'U') .AND. .NOT.LSAME(UPLO,'L')) THEN
INFO = 1
ELSE IF (.NOT.LSAME(TRANS,'N') .AND.
+ .NOT.LSAME(TRANS,'T') .AND.
+ .NOT.LSAME(TRANS,'C')) THEN
INFO = 2
ELSE IF (.NOT.LSAME(DIAG,'U') .AND.
+ .NOT.LSAME(DIAG,'N')) THEN
INFO = 3
ELSE IF (N.LT.0) THEN
INFO = 4
ELSE IF (LDA.LT.MAX(1,N)) THEN
INFO = 6
ELSE IF (INCX.EQ.0) THEN
INFO = 8
END IF
IF (INFO.NE.0) THEN
CALL XERBLA('DTRSV ',INFO)
RETURN
END IF
*
* Quick return if possible.
*
IF (N.EQ.0) RETURN
*
NOUNIT = LSAME(DIAG,'N')
*
* Set up the start point in X if the increment is not unity. This
* will be ( N - 1 )*INCX too small for descending loops.
*
IF (INCX.LE.0) THEN
KX = 1 - (N-1)*INCX
ELSE IF (INCX.NE.1) THEN
KX = 1
END IF
*
* Start the operations. In this version the elements of A are
* accessed sequentially with one pass through A.
*
IF (LSAME(TRANS,'N')) THEN
*
* Form x := inv( A )*x.
*
IF (LSAME(UPLO,'U')) THEN
IF (INCX.EQ.1) THEN
DO 20 J = N,1,-1
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/A(J,J)
TEMP = X(J)
DO 10 I = J - 1,1,-1
X(I) = X(I) - TEMP*A(I,J)
10 CONTINUE
END IF
20 CONTINUE
ELSE
JX = KX + (N-1)*INCX
DO 40 J = N,1,-1
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/A(J,J)
TEMP = X(JX)
IX = JX
DO 30 I = J - 1,1,-1
IX = IX - INCX
X(IX) = X(IX) - TEMP*A(I,J)
30 CONTINUE
END IF
JX = JX - INCX
40 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 60 J = 1,N
IF (X(J).NE.ZERO) THEN
IF (NOUNIT) X(J) = X(J)/A(J,J)
TEMP = X(J)
DO 50 I = J + 1,N
X(I) = X(I) - TEMP*A(I,J)
50 CONTINUE
END IF
60 CONTINUE
ELSE
JX = KX
DO 80 J = 1,N
IF (X(JX).NE.ZERO) THEN
IF (NOUNIT) X(JX) = X(JX)/A(J,J)
TEMP = X(JX)
IX = JX
DO 70 I = J + 1,N
IX = IX + INCX
X(IX) = X(IX) - TEMP*A(I,J)
70 CONTINUE
END IF
JX = JX + INCX
80 CONTINUE
END IF
END IF
ELSE
*
* Form x := inv( A**T )*x.
*
IF (LSAME(UPLO,'U')) THEN
IF (INCX.EQ.1) THEN
DO 100 J = 1,N
TEMP = X(J)
DO 90 I = 1,J - 1
TEMP = TEMP - A(I,J)*X(I)
90 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
X(J) = TEMP
100 CONTINUE
ELSE
JX = KX
DO 120 J = 1,N
TEMP = X(JX)
IX = KX
DO 110 I = 1,J - 1
TEMP = TEMP - A(I,J)*X(IX)
IX = IX + INCX
110 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
X(JX) = TEMP
JX = JX + INCX
120 CONTINUE
END IF
ELSE
IF (INCX.EQ.1) THEN
DO 140 J = N,1,-1
TEMP = X(J)
DO 130 I = N,J + 1,-1
TEMP = TEMP - A(I,J)*X(I)
130 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
X(J) = TEMP
140 CONTINUE
ELSE
KX = KX + (N-1)*INCX
JX = KX
DO 160 J = N,1,-1
TEMP = X(JX)
IX = KX
DO 150 I = N,J + 1,-1
TEMP = TEMP - A(I,J)*X(IX)
IX = IX - INCX
150 CONTINUE
IF (NOUNIT) TEMP = TEMP/A(J,J)
X(JX) = TEMP
JX = JX - INCX
160 CONTINUE
END IF
END IF
END IF
*
RETURN
*
* End of DTRSV
*
END
*> \brief \b IDAMAX
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* INTEGER FUNCTION IDAMAX(N,DX,INCX)
*
* .. Scalar Arguments ..
* INTEGER INCX,N
* ..
* .. Array Arguments ..
* DOUBLE PRECISION DX(*)
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> IDAMAX finds the index of the first element having maximum absolute value.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> number of elements in input vector(s)
*> \endverbatim
*>
*> \param[in] DX
*> \verbatim
*> DX is DOUBLE PRECISION array, dimension ( 1 + ( N - 1 )*abs( INCX ) )
*> \endverbatim
*>
*> \param[in] INCX
*> \verbatim
*> INCX is INTEGER
*> storage spacing between elements of DX
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup iamax
*
*> \par Further Details:
* =====================
*>
*> \verbatim
*>
*> jack dongarra, linpack, 3/11/78.
*> modified 3/93 to return if incx .le. 0.
*> modified 12/3/93, array(1) declarations changed to array(*)
*> \endverbatim
*>
* =====================================================================
INTEGER FUNCTION IDAMAX(N,DX,INCX)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER INCX,N
* ..
* .. Array Arguments ..
DOUBLE PRECISION DX(*)
* ..
*
* =====================================================================
*
* .. Local Scalars ..
DOUBLE PRECISION DMAX
INTEGER I,IX
* ..
* .. Intrinsic Functions ..
INTRINSIC DABS
* ..
IDAMAX = 0
IF (N.LT.1 .OR. INCX.LE.0) RETURN
IDAMAX = 1
IF (N.EQ.1) RETURN
IF (INCX.EQ.1) THEN
*
* code for increment equal to 1
*
DMAX = DABS(DX(1))
DO I = 2,N
IF (DABS(DX(I)).GT.DMAX) THEN
IDAMAX = I
DMAX = DABS(DX(I))
END IF
END DO
ELSE
*
* code for increment not equal to 1
*
IX = 1
DMAX = DABS(DX(1))
IX = IX + INCX
DO I = 2,N
IF (DABS(DX(IX)).GT.DMAX) THEN
IDAMAX = I
DMAX = DABS(DX(IX))
END IF
IX = IX + INCX
END DO
END IF
RETURN
*
* End of IDAMAX
*
END
*> \brief \b ILADLC scans a matrix for its last non-zero column.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILADLC + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION ILADLC( M, N, A, LDA )
*
* .. Scalar Arguments ..
* INTEGER M, N, LDA
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ILADLC scans A for its last non-zero column.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup ilalc
*
* =====================================================================
INTEGER FUNCTION ILADLC( M, N, A, LDA )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER M, N, LDA
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( N.EQ.0 ) THEN
ILADLC = N
ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILADLC = N
ELSE
* Now scan each column from the end, returning with the first non-zero.
DO ILADLC = N, 1, -1
DO I = 1, M
IF( A(I, ILADLC).NE.ZERO ) RETURN
END DO
END DO
END IF
RETURN
END
*> \brief \b ILADLR scans a matrix for its last non-zero row.
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
*> \htmlonly
*> Download ILADLR + dependencies
*>
*> [TGZ]
*>
*> [ZIP]
*>
*> [TXT]
*> \endhtmlonly
*
* Definition:
* ===========
*
* INTEGER FUNCTION ILADLR( M, N, A, LDA )
*
* .. Scalar Arguments ..
* INTEGER M, N, LDA
* ..
* .. Array Arguments ..
* DOUBLE PRECISION A( LDA, * )
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> ILADLR scans A for its last non-zero row.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] M
*> \verbatim
*> M is INTEGER
*> The number of rows of the matrix A.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*> N is INTEGER
*> The number of columns of the matrix A.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*> A is DOUBLE PRECISION array, dimension (LDA,N)
*> The m by n matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*> LDA is INTEGER
*> The leading dimension of the array A. LDA >= max(1,M).
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup ilalr
*
* =====================================================================
INTEGER FUNCTION ILADLR( M, N, A, LDA )
*
* -- LAPACK auxiliary routine --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
INTEGER M, N, LDA
* ..
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
INTEGER I, J
* ..
* .. Executable Statements ..
*
* Quick test for the common case where one corner is non-zero.
IF( M.EQ.0 ) THEN
ILADLR = M
ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILADLR = M
ELSE
* Scan up each column tracking the last zero row seen.
ILADLR = 0
DO J = 1, N
I=M
DO WHILE((A(MAX(I,1),J).EQ.ZERO).AND.(I.GE.1))
I=I-1
ENDDO
ILADLR = MAX( ILADLR, I )
END DO
END IF
RETURN
END
*> \brief \b LSAME
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* LOGICAL FUNCTION LSAME(CA,CB)
*
* .. Scalar Arguments ..
* CHARACTER CA,CB
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> LSAME returns .TRUE. if CA is the same letter as CB regardless of
*> case.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] CA
*> \verbatim
*> CA is CHARACTER*1
*> \endverbatim
*>
*> \param[in] CB
*> \verbatim
*> CB is CHARACTER*1
*> CA and CB specify the single characters to be compared.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup lsame
*
* =====================================================================
LOGICAL FUNCTION LSAME(CA,CB)
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER CA,CB
* ..
*
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC ICHAR
* ..
* .. Local Scalars ..
INTEGER INTA,INTB,ZCODE
* ..
*
* Test if the characters are equal
*
LSAME = CA .EQ. CB
IF (LSAME) RETURN
*
* Now test for equivalence if both characters are alphabetic.
*
ZCODE = ICHAR('Z')
*
* Use 'Z' rather than 'A' so that ASCII can be detected on Prime
* machines, on which ICHAR returns a value with bit 8 set.
* ICHAR('A') on Prime machines returns 193 which is the same as
* ICHAR('A') on an EBCDIC machine.
*
INTA = ICHAR(CA)
INTB = ICHAR(CB)
*
IF (ZCODE.EQ.90 .OR. ZCODE.EQ.122) THEN
*
* ASCII is assumed - ZCODE is the ASCII code of either lower or
* upper case 'Z'.
*
IF (INTA.GE.97 .AND. INTA.LE.122) INTA = INTA - 32
IF (INTB.GE.97 .AND. INTB.LE.122) INTB = INTB - 32
*
ELSE IF (ZCODE.EQ.233 .OR. ZCODE.EQ.169) THEN
*
* EBCDIC is assumed - ZCODE is the EBCDIC code of either lower or
* upper case 'Z'.
*
IF (INTA.GE.129 .AND. INTA.LE.137 .OR.
+ INTA.GE.145 .AND. INTA.LE.153 .OR.
+ INTA.GE.162 .AND. INTA.LE.169) INTA = INTA + 64
IF (INTB.GE.129 .AND. INTB.LE.137 .OR.
+ INTB.GE.145 .AND. INTB.LE.153 .OR.
+ INTB.GE.162 .AND. INTB.LE.169) INTB = INTB + 64
*
ELSE IF (ZCODE.EQ.218 .OR. ZCODE.EQ.250) THEN
*
* ASCII is assumed, on Prime machines - ZCODE is the ASCII code
* plus 128 of either lower or upper case 'Z'.
*
IF (INTA.GE.225 .AND. INTA.LE.250) INTA = INTA - 32
IF (INTB.GE.225 .AND. INTB.LE.250) INTB = INTB - 32
END IF
LSAME = INTA .EQ. INTB
*
* RETURN
*
* End of LSAME
*
END
*> \brief \b XERBLA
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* SUBROUTINE XERBLA( SRNAME, INFO )
*
* .. Scalar Arguments ..
* CHARACTER*(*) SRNAME
* INTEGER INFO
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> XERBLA is an error handler for the LAPACK routines.
*> It is called by an LAPACK routine if an input parameter has an
*> invalid value. A message is printed and execution stops.
*>
*> Installers may consider modifying the STOP statement in order to
*> call system-specific exception-handling facilities.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] SRNAME
*> \verbatim
*> SRNAME is CHARACTER*(*)
*> The name of the routine which called XERBLA.
*> \endverbatim
*>
*> \param[in] INFO
*> \verbatim
*> INFO is INTEGER
*> The position of the invalid parameter in the parameter list
*> of the calling routine.
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \ingroup xerbla
*
* =====================================================================
SUBROUTINE XERBLA( SRNAME, INFO )
*
* -- Reference BLAS level1 routine --
* -- Reference BLAS is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*
* .. Scalar Arguments ..
CHARACTER*(*) SRNAME
INTEGER INFO
* ..
*
* =====================================================================
*
* .. Intrinsic Functions ..
INTRINSIC LEN_TRIM
* ..
* .. Executable Statements ..
*
WRITE( *, FMT = 9999 )SRNAME( 1:LEN_TRIM( SRNAME ) ), INFO
*
STOP
*
9999 FORMAT( ' ** On entry to ', A, ' parameter number ', I2, ' had ',
$ 'an illegal value' )
*
* End of XERBLA
*
END
*> \brief \b DLAMCH
*
* =========== DOCUMENTATION ===========
*
* Online html documentation available at
* http://www.netlib.org/lapack/explore-html/
*
* Definition:
* ===========
*
* DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
*
* .. Scalar Arguments ..
* CHARACTER CMACH
* ..
*
*
*> \par Purpose:
* =============
*>
*> \verbatim
*>
*> DLAMCH determines double precision machine parameters.
*> \endverbatim
*
* Arguments:
* ==========
*
*> \param[in] CMACH
*> \verbatim
*> CMACH is CHARACTER*1
*> Specifies the value to be returned by DLAMCH:
*> = 'E' or 'e', DLAMCH := eps
*> = 'S' or 's , DLAMCH := sfmin
*> = 'B' or 'b', DLAMCH := base
*> = 'P' or 'p', DLAMCH := eps*base
*> = 'N' or 'n', DLAMCH := t
*> = 'R' or 'r', DLAMCH := rnd
*> = 'M' or 'm', DLAMCH := emin
*> = 'U' or 'u', DLAMCH := rmin
*> = 'L' or 'l', DLAMCH := emax
*> = 'O' or 'o', DLAMCH := rmax
*> where
*> eps = relative machine precision
*> sfmin = safe minimum, such that 1/sfmin does not overflow
*> base = base of the machine
*> prec = eps*base
*> t = number of (base) digits in the mantissa
*> rnd = 1.0 when rounding occurs in addition, 0.0 otherwise
*> emin = minimum exponent before (gradual) underflow
*> rmin = underflow threshold - base**(emin-1)
*> emax = largest exponent before overflow
*> rmax = overflow threshold - (base**emax)*(1-eps)
*> \endverbatim
*
* Authors:
* ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date December 2016
*
*> \ingroup auxOTHERauxiliary
*
* =====================================================================
DOUBLE PRECISION FUNCTION DLAMCH( CMACH )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* -- LAPACK is a software package provided by Univ. of Tennessee, --
* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
* December 2016
*
* .. Scalar Arguments ..
CHARACTER CMACH
* ..
*
* =====================================================================
*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* ..
* .. Local Scalars ..
DOUBLE PRECISION RND, EPS, SFMIN, SMALL, RMACH
* ..
* .. External Functions ..
LOGICAL LSAME
EXTERNAL LSAME
* ..
* .. Intrinsic Functions ..
INTRINSIC DIGITS, EPSILON, HUGE, MAXEXPONENT,
$ MINEXPONENT, RADIX, TINY
* ..
* .. Executable Statements ..
*
*
* Assume rounding, not chopping. Always.
*
RND = ONE
*
IF( ONE.EQ.RND ) THEN
EPS = EPSILON(ZERO) * 0.5
ELSE
EPS = EPSILON(ZERO)
END IF
*
IF( LSAME( CMACH, 'E' ) ) THEN
RMACH = EPS
ELSE IF( LSAME( CMACH, 'S' ) ) THEN
SFMIN = TINY(ZERO)
SMALL = ONE / HUGE(ZERO)
IF( SMALL.GE.SFMIN ) THEN
*
* Use SMALL plus a bit, to avoid the possibility of rounding
* causing overflow when computing 1/sfmin.
*
SFMIN = SMALL*( ONE+EPS )
END IF
RMACH = SFMIN
ELSE IF( LSAME( CMACH, 'B' ) ) THEN
RMACH = RADIX(ZERO)
ELSE IF( LSAME( CMACH, 'P' ) ) THEN
RMACH = EPS * RADIX(ZERO)
ELSE IF( LSAME( CMACH, 'N' ) ) THEN
RMACH = DIGITS(ZERO)
ELSE IF( LSAME( CMACH, 'R' ) ) THEN
RMACH = RND
ELSE IF( LSAME( CMACH, 'M' ) ) THEN
RMACH = MINEXPONENT(ZERO)
ELSE IF( LSAME( CMACH, 'U' ) ) THEN
RMACH = tiny(zero)
ELSE IF( LSAME( CMACH, 'L' ) ) THEN
RMACH = MAXEXPONENT(ZERO)
ELSE IF( LSAME( CMACH, 'O' ) ) THEN
RMACH = HUGE(ZERO)
ELSE
RMACH = ZERO
END IF
*
DLAMCH = RMACH
RETURN
*
* End of DLAMCH
*
END
************************************************************************
*> \brief \b DLAMC3
*> \details
*> \b Purpose:
*> \verbatim
*> DLAMC3 is intended to force A and B to be stored prior to doing
*> the addition of A and B , for use in situations where optimizers
*> might hold one of these in a register.
*> \endverbatim
*> \author LAPACK is a software package provided by Univ. of Tennessee, Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..
*> \date December 2016
*> \ingroup auxOTHERauxiliary
*>
*> \param[in] A
*> \verbatim
*> A is a DOUBLE PRECISION
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*> B is a DOUBLE PRECISION
*> The values A and B.
*> \endverbatim
*>
DOUBLE PRECISION FUNCTION DLAMC3( A, B )
*
* -- LAPACK auxiliary routine (version 3.7.0) --
* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
* November 2010
*
* .. Scalar Arguments ..
DOUBLE PRECISION A, B
* ..
* =====================================================================
*
* .. Executable Statements ..
*
DLAMC3 = A + B
*
RETURN
*
* End of DLAMC3
*
END
*
************************************************************************