* entry is considered "symbolic" if all multiplications involved
* in computing that entry have at least one zero multiplicand.
*
-* Parameters
+* Arguments
* ==========
*
* TRANS - INTEGER
*
* Level 2 Blas routine.
*
-* ..
+* =====================================================================
+*
* .. Parameters ..
COMPLEX ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER IPIV( * )
COMPLEX AB( LDAB, * ), AFB( LDAFB, * ), WORK( * )
REAL C( * ), RWORK( * )
+* ..
+*
+* Purpose
+* =======
*
* CLA_GBRCOND_C Computes the infinity norm condition number of
* op(A) * inv(diag(C)) where C is a REAL vector.
-* WORK is a COMPLEX workspace of size 2*N, and
-* RWORK is a REAL workspace of size 3*N.
-* ..
+*
+* Arguments
+* =========
+*
+* C REAL vector.
+*
+* WORK COMPLEX workspace of size 2*N.
+*
+* RWORK REAL workspace of size 3*N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
LOGICAL NOTRANS
INTEGER KASE, I, J
COMPLEX AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ),
$ X( * )
REAL RWORK( * )
+* ..
+*
+* Purpose
+* =======
*
* CLA_GBRCOND_X Computes the infinity norm condition number of
* op(A) * diag(X) where X is a COMPLEX vector.
-* WORK is a COMPLEX workspace of size 2*N, and
-* RWORK is a REAL workspace of size 3*N.
-* ..
+*
+* Arguments
+* =========
+*
+* X COMPLEX vector.
+*
+* WORK COMPLEX workspace of size 2*N.
+*
+* RWORK REAL workspace of size 3*N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
LOGICAL NOTRANS
INTEGER KASE, I, J
REAL C( * ), AYB(*), RCOND, BERR_OUT( * ),
$ ERRS_N( NRHS, * ), ERRS_C( NRHS, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
CHARACTER TRANS
INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE
* .. Array Arguments ..
COMPLEX AB( LDAB, * ), AFB( LDAFB, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER I, J, KD
REAL AMAX, UMAX, RPVGRW
* entry is considered "symbolic" if all multiplications involved
* in computing that entry have at least one zero multiplicand.
*
-* Parameters
+* Arguments
* ==========
*
* TRANS - INTEGER
*
* Level 2 Blas routine.
*
-* ..
+* =====================================================================
+*
* .. Parameters ..
COMPLEX ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER IPIV( * )
COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * )
REAL C( * ), RWORK( * )
+* ..
*
+* Purpose
+* =======
+*
* CLA_GERCOND_C computes the infinity norm condition number of
* op(A) * inv(diag(C)) where C is a REAL vector.
-* WORK is a COMPLEX workspace of size 2*N, and
-* RWORK is a REAL workspace of size 3*N.
-* ..
+*
+* Arguments
+* =========
+*
+* C REAL vector.
+*
+* WORK COMPLEX workspace of size 2*N.
+*
+* RWORK REAL workspace of size 3*N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
LOGICAL NOTRANS
INTEGER KASE, I, J
INTEGER IPIV( * )
COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * )
REAL RWORK( * )
+* ..
*
+* Purpose
+* =======
+*
* CLA_GERCOND_X computes the infinity norm condition number of
* op(A) * diag(X) where X is a COMPLEX vector.
-* WORK is a COMPLEX workspace of size 2*N, and
-* RWORK is a REAL workspace of size 3*N.
-* ..
+*
+* Arguments
+* =========
+*
+* X COMPLEX vector.
+*
+* WORK COMPLEX workspace of size 2*N.
+*
+* RWORK REAL workspace of size 3*N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
LOGICAL NOTRANS
INTEGER KASE
REAL C( * ), AYB( * ), RCOND, BERR_OUT( * ),
$ ERRS_N( NRHS, * ), ERRS_C( NRHS, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
CHARACTER TRANS
INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE
* entry is considered "symbolic" if all multiplications involved
* in computing that entry have at least one zero multiplicand.
*
-* Parameters
+* Arguments
* ==========
*
* UPLO - INTEGER
* Y. INCY must not be zero.
* Unchanged on exit.
*
+* Further Details
+* ===============
*
* Level 2 Blas routine.
*
* -- Modified for the absolute-value product, April 2006
* Jason Riedy, UC Berkeley
*
-* ..
+* =====================================================================
+*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER IPIV( * )
COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * )
REAL C ( * ), RWORK( * )
+* ..
+*
+* Purpose
+* =======
*
* CLA_HERCOND_C computes the infinity norm condition number of
* op(A) * inv(diag(C)) where C is a REAL vector.
-* WORK is a COMPLEX workspace of size 2*N, and
-* RWORK is a REAL workspace of size 3*N.
-* ..
+*
+* Arguments
+* =========
+*
+* C REAL vector.
+*
+* WORK COMPLEX workspace of size 2*N.
+*
+* RWORK REAL workspace of size 3*N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER KASE, I, J
REAL AINVNM, ANORM, TMP
INTEGER IPIV( * )
COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * )
REAL RWORK( * )
+* ..
+*
+* Purpose
+* =======
*
* CLA_HERCOND_X computes the infinity norm condition number of
* op(A) * diag(X) where X is a COMPLEX vector.
-* WORK is a COMPLEX workspace of size 2*N, and
-* RWORK is a REAL workspace of size 3*N.
-* ..
+*
+* Arguments
+* =========
+*
+* X COMPLEX vector.
+*
+* WORK COMPLEX workspace of size 2*N.
+*
+* RWORK REAL workspace of size 3*N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER KASE, I, J
REAL AINVNM, ANORM, TMP
REAL C( * ), AYB( * ), RCOND, BERR_OUT( * ),
$ ERRS_N( NRHS, * ), ERRS_C( NRHS, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,
$ Y_PREC_STATE
COMPLEX A( LDA, * ), AF( LDAF, * )
REAL WORK( * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER NCOLS, I, J, K, KP
REAL AMAX, UMAX, RPVGRW, TMP
* .. Array Arguments ..
REAL AYB( N, NRHS ), BERR( NRHS )
COMPLEX RES( N, NRHS )
+* ..
+*
+* Purpose
+* =======
*
-* CLA_LIN_BERR computes componentwise relative backward error from
+* CLA_LIN_BERR computes component-wise relative backward error from
* the formula
* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )
-* where abs(Z) is the componentwise absolute value of the matrix
+* where abs(Z) is the component-wise absolute value of the matrix
* or vector Z.
-* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
REAL TMP
INTEGER I, J
* .. Array Arguments ..
COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * )
REAL C( * ), RWORK( * )
+* ..
+*
+* Purpose
+* =======
*
* SLA_PORCOND_C Computes the infinity norm condition number of
* op(A) * inv(diag(C)) where C is a REAL vector
* WORK is a COMPLEX workspace of size 2*N, and
* RWORK is a REAL workspace of size 3*N.
-* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER KASE
REAL AINVNM, ANORM, TMP
* .. Array Arguments ..
COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * )
REAL RWORK( * )
+* ..
+*
+* Purpose
+* =======
*
* CLA_PORCOND_X Computes the infinity norm condition number of
* op(A) * diag(X) where X is a COMPLEX vector.
* WORK is a COMPLEX workspace of size 2*N, and
* RWORK is a REAL workspace of size 3*N.
-* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER KASE, I, J
REAL AINVNM, ANORM, TMP
REAL C( * ), AYB( * ), RCOND, BERR_OUT( * ),
$ ERRS_N( NRHS, * ), ERRS_C( NRHS, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,
$ Y_PREC_STATE
COMPLEX A( LDA, * ), AF( LDAF, * )
REAL WORK( * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER I, J
REAL AMAX, UMAX, RPVGRW
* .. Array Arguments ..
COMPLEX A( LDA, * ), AF( LDAF, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER I, J
REAL AMAX, UMAX, RPVGRW
* entry is considered "symbolic" if all multiplications involved
* in computing that entry have at least one zero multiplicand.
*
-* Parameters
+* Arguments
* ==========
*
* UPLO - INTEGER
* Y. INCY must not be zero.
* Unchanged on exit.
*
+* Further Details
+* ===============
*
* Level 2 Blas routine.
*
* -- Modified for the absolute-value product, April 2006
* Jason Riedy, UC Berkeley
*
-* ..
+* =====================================================================
+*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER IPIV( * )
COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * )
REAL C( * ), RWORK( * )
+* ..
+*
+* Purpose
+* =======
*
* CLA_SYRCOND_C Computes the infinity norm condition number of
* op(A) * inv(diag(C)) where C is a REAL vector.
-* WORK is a COMPLEX workspace of size 2*N, and
-* RWORK is a REAL workspace of size 3*N.
-* ..
+*
+* Arguments
+* =========
+*
+* C REAL vector.
+*
+* WORK COMPLEX workspace of size 2*N.
+*
+* RWORK REAL workspace of size 3*N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER KASE
REAL AINVNM, ANORM, TMP
INTEGER IPIV( * )
COMPLEX A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * )
REAL RWORK( * )
+* ..
+*
+* Purpose
+* =======
*
* CLA_SYRCOND_X Computes the infinity norm condition number of
* op(A) * diag(X) where X is a COMPLEX vector.
-* WORK is a COMPLEX workspace of size 2*N, and
-* RWORK is a REAL workspace of size 3*N.
-* ..
+*
+* Arguments
+* =========
+*
+* X COMPLEX vector.
+*
+* WORK COMPLEX workspace of size 2*N.
+*
+* RWORK REAL workspace of size 3*N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER KASE
REAL AINVNM, ANORM, TMP
REAL C( * ), AYB( * ), RCOND, BERR_OUT( * ),
$ ERRS_N( NRHS, * ), ERRS_C( NRHS, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,
$ Y_PREC_STATE
REAL WORK( * )
INTEGER IPIV( * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER NCOLS, I, J, K, KP
REAL AMAX, UMAX, RPVGRW, TMP
*
* W (input) COMPLEX array, length N
* The vector to be added.
-* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
COMPLEX S
INTEGER I
* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
* WORK is not referenced.
*
-* Note:
-* =====
+* Further Details
+* ===============
*
* We first consider Standard Packed Format when N is even.
* We give an example where N = 6.
* > 0: if INFO = i, the (i,i) element of the factor U or L is
* zero, and the inverse could not be computed.
*
-* Note:
-* =====
+* Further Details
+* ===============
*
* We first consider Standard Packed Format when N is even.
* We give an example where N = 6.
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
-* Note:
-* =====
+* Further Details
+* ===============
*
* We first consider Standard Packed Format when N is even.
* We give an example where N = 6.
* Computer Science Division Technical Report No. UCB/CSD-97-971,
* UC Berkeley, May 1997.
*
-* Notes:
+* Further Details
* 1.CSTEMR works only on machines which follow IEEE-754
* floating-point standard in their handling of infinities and NaNs.
* This permits the use of efficient inner loops avoiding a check for
* max( 1, m ).
* Unchanged on exit.
*
-* Notes:
-* ======
+* Further Details
+* ===============
*
* We first consider Standard Packed Format when N is even.
* We give an example where N = 6.
* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
* matrix is singular and its inverse can not be computed.
*
-* Notes:
-* ======
+* Further Details
+* ===============
*
* We first consider Standard Packed Format when N is even.
* We give an example where N = 6.
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
-* Notes:
-* ======
+* Further Details
+* ===============
*
* We first consider Standard Packed Format when N is even.
* We give an example where N = 6.
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
-* Notes:
-* ======
+* Further Details
+* ===============
*
* We first consider Standard Packed Format when N is even.
* We give an example where N = 6.
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
-* Notes:
-* ======
+* Further Details
+* ===============
*
* We first consider Standard Packed Format when N is even.
* We give an example where N = 6.
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Standard Packed Format when N is even.
* We give an example where N = 6.
- SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA,
- & MV, V, LDV, WORK, LWORK, INFO )
+ SUBROUTINE DGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V,
+ + LDV, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.2) --
*
* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the
* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0.
*
-* -#- Scalar Arguments -#-
-*
- IMPLICIT NONE
- INTEGER INFO, LDA, LDV, LWORK, M, MV, N
- CHARACTER*1 JOBA, JOBU, JOBV
-*
-* -#- Array Arguments -#-
-*
- DOUBLE PRECISION A( LDA, * ), SVA( N ), V( LDV, * ), WORK( LWORK )
+ IMPLICIT NONE
+* ..
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDV, LWORK, M, MV, N
+ CHARACTER*1 JOBA, JOBU, JOBV
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), SVA( N ), V( LDV, * ),
+ + WORK( LWORK )
* ..
*
* Purpose
-* ~~~~~~~
+* =======
+*
* DGESVJ computes the singular value decomposition (SVD) of a real
* M-by-N matrix A, where M >= N. The SVD of A is written as
* [++] [xx] [x0] [xx]
* drmac@math.hr. Thank you.
*
* Arguments
-* ~~~~~~~~~
+* =========
*
* JOBA (input) CHARACTER* 1
* Specifies the structure of A.
* JOBU (input) CHARACTER*1
* Specifies whether to compute the left singular vectors
* (columns of U):
-*
* = 'U': The left singular vectors corresponding to the nonzero
* singular values are computed and returned in the leading
* columns of A. See more details in the description of A.
*
* A (input/output) REAL array, dimension (LDA,N)
* On entry, the M-by-N matrix A.
-* On exit,
-* If JOBU .EQ. 'U' .OR. JOBU .EQ. 'C':
-* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* If INFO .EQ. 0,
-* ~~~~~~~~~~~~~~~
+* On exit :
+* If JOBU .EQ. 'U' .OR. JOBU .EQ. 'C' :
+* If INFO .EQ. 0 :
* RANKA orthonormal columns of U are returned in the
* leading RANKA columns of the array A. Here RANKA <= N
* is the number of computed singular values of A that are
* are mutually numerically orthogonal up to approximately
* TOL=DSQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU.EQ.'C'),
* see the description of JOBU.
-* If INFO .GT. 0,
-* ~~~~~~~~~~~~~~~
+* If INFO .GT. 0 :
* the procedure DGESVJ did not converge in the given number
* of iterations (sweeps). In that case, the computed
* columns of U may not be orthogonal up to TOL. The output
* input matrix A in the sense that the residual
* ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small.
*
-* If JOBU .EQ. 'N':
-* ~~~~~~~~~~~~~~~~~
-* If INFO .EQ. 0
-* ~~~~~~~~~~~~~~
+* If JOBU .EQ. 'N' :
+* If INFO .EQ. 0 :
* Note that the left singular vectors are 'for free' in the
* one-sided Jacobi SVD algorithm. However, if only the
* singular values are needed, the level of numerical
* numerically orthogonal up to approximately M*EPS. Thus,
* on exit, A contains the columns of U scaled with the
* corresponding singular values.
-* If INFO .GT. 0,
-* ~~~~~~~~~~~~~~~
+* If INFO .GT. 0 :
* the procedure DGESVJ did not converge in the given number
* of iterations (sweeps).
*
* The leading dimension of the array A. LDA >= max(1,M).
*
* SVA (workspace/output) REAL array, dimension (N)
-* On exit,
-* If INFO .EQ. 0,
-* ~~~~~~~~~~~~~~~
+* On exit :
+* If INFO .EQ. 0 :
* depending on the value SCALE = WORK(1), we have:
-* If SCALE .EQ. ONE:
-* ~~~~~~~~~~~~~~~~~~
+* If SCALE .EQ. ONE :
* SVA(1:N) contains the computed singular values of A.
* During the computation SVA contains the Euclidean column
* norms of the iterated matrices in the array A.
-* If SCALE .NE. ONE:
-* ~~~~~~~~~~~~~~~~~~
+* If SCALE .NE. ONE :
* The singular values of A are SCALE*SVA(1:N), and this
* factored representation is due to the fact that some of the
* singular values of A might underflow or overflow.
-*
-* If INFO .GT. 0,
-* ~~~~~~~~~~~~~~~
+* If INFO .GT. 0 :
* the procedure DGESVJ did not converge in the given number of
* iterations (sweeps) and SCALE*SVA(1:N) may not be accurate.
*
* If JOBV .EQ. 'A', then LDV .GE. max(1,MV) .
*
* WORK (input/workspace/output) REAL array, dimension max(4,M+N).
-* On entry,
-* If JOBU .EQ. 'C',
-* ~~~~~~~~~~~~~~~~~
+* On entry :
+* If JOBU .EQ. 'C' :
* WORK(1) = CTOL, where CTOL defines the threshold for convergence.
* The process stops if all columns of A are mutually
* orthogonal up to CTOL*EPS, EPS=DLAMCH('E').
* It is required that CTOL >= ONE, i.e. it is not
* allowed to force the routine to obtain orthogonality
* below EPSILON.
-* On exit,
+* On exit :
* WORK(1) = SCALE is the scaling factor such that SCALE*SVA(1:N)
-* are the computed singular vcalues of A.
+* are the computed singular values of A.
* (See description of SVA().)
* WORK(2) = NINT(WORK(2)) is the number of the computed nonzero
* singular values.
* of sweeps. The output may still be useful. See the
* description of WORK.
*
-* Local Parameters
-*
- DOUBLE PRECISION ZERO, HALF, ONE, TWO
- PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0 )
- INTEGER NSWEEP
- PARAMETER ( NSWEEP = 30 )
-*
-* Local Scalars
+* =====================================================================
*
- DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP,
- & BIG, BIGTHETA, CS, CTOL, EPSILON, LARGE,
- & MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL,
- & SCALE, SFMIN, SMALL, SN, T, TEMP1,
- & THETA, THSIGN, TOL
- INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl,
- & IJBLSK, ir1, ISWROT, jbc, jgl, KBL,
- & LKAHEAD, MVL, N2, N34, N4, NBL,
- & NOTROT, p, PSKIPPED, q, ROWSKIP, SWBAND
- LOGICAL APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK,
- & RSVEC, UCTOL, UPPER
-*
-* Local Arrays
-*
- DOUBLE PRECISION FASTR(5)
-*
-* Intrinsic Functions
-*
- INTRINSIC DABS, DMAX1, DMIN1, DBLE, MIN0, DSIGN, DSQRT
-*
-* External Functions
-* .. from BLAS
- DOUBLE PRECISION DDOT, DNRM2
- EXTERNAL DDOT, DNRM2
- INTEGER IDAMAX
- EXTERNAL IDAMAX
-* .. from LAPACK
- DOUBLE PRECISION DLAMCH
- EXTERNAL DLAMCH
- LOGICAL LSAME
- EXTERNAL LSAME
-*
-* External Subroutines
-* .. from BLAS
- EXTERNAL DAXPY, DCOPY, DROTM, DSCAL, DSWAP
-* .. from LAPACK
- EXTERNAL DLASCL, DLASET, DLASSQ, XERBLA
+* .. Local Parameters ..
+ DOUBLE PRECISION ZERO, HALF, ONE, TWO
+ PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,
+ + TWO = 2.0D0 )
+ INTEGER NSWEEP
+ PARAMETER ( NSWEEP = 30 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,
+ + BIGTHETA, CS, CTOL, EPSILON, LARGE, MXAAPQ,
+ + MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL,
+ + SCALE, SFMIN, SMALL, SN, T, TEMP1, THETA,
+ + THSIGN, TOL
+ INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,
+ + ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34,
+ + N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP,
+ + SWBAND
+ LOGICAL APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK,
+ + RSVEC, UCTOL, UPPER
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION FASTR( 5 )
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DABS, DMAX1, DMIN1, DBLE, MIN0, DSIGN, DSQRT
+* ..
+* .. External Functions ..
+* ..
+* from BLAS
+ DOUBLE PRECISION DDOT, DNRM2
+ EXTERNAL DDOT, DNRM2
+ INTEGER IDAMAX
+ EXTERNAL IDAMAX
+* from LAPACK
+ DOUBLE PRECISION DLAMCH
+ EXTERNAL DLAMCH
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+* ..
+* from BLAS
+ EXTERNAL DAXPY, DCOPY, DROTM, DSCAL, DSWAP
+* from LAPACK
+ EXTERNAL DLASCL, DLASET, DLASSQ, XERBLA
*
- EXTERNAL DGSVJ0, DGSVJ1
+ EXTERNAL DGSVJ0, DGSVJ1
+* ..
+* .. Executable Statements ..
*
* Test the input arguments
*
UPPER = LSAME( JOBA, 'U' )
LOWER = LSAME( JOBA, 'L' )
*
- IF ( .NOT.( UPPER .OR. LOWER .OR. LSAME(JOBA,'G') ) ) THEN
- INFO = - 1
- ELSE IF ( .NOT.( LSVEC .OR. UCTOL .OR. LSAME(JOBU,'N') ) ) THEN
- INFO = - 2
- ELSE IF ( .NOT.( RSVEC .OR. APPLV .OR. LSAME(JOBV,'N') ) ) THEN
- INFO = - 3
- ELSE IF ( M .LT. 0 ) THEN
- INFO = - 4
- ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M ) ) THEN
- INFO = - 5
- ELSE IF ( LDA .LT. M ) THEN
- INFO = - 7
- ELSE IF ( MV .LT. 0 ) THEN
- INFO = - 9
- ELSE IF ( ( RSVEC .AND. (LDV .LT. N ) ) .OR.
- & ( APPLV .AND. (LDV .LT. MV) ) ) THEN
+ IF( .NOT.( UPPER .OR. LOWER .OR. LSAME( JOBA, 'G' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( LSVEC .OR. UCTOL .OR. LSAME( JOBU, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( RSVEC .OR. APPLV .OR. LSAME( JOBV, 'N' ) ) ) THEN
+ INFO = -3
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( ( N.LT.0 ) .OR. ( N.GT.M ) ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.M ) THEN
+ INFO = -7
+ ELSE IF( MV.LT.0 ) THEN
+ INFO = -9
+ ELSE IF( ( RSVEC .AND. ( LDV.LT.N ) ) .OR.
+ + ( APPLV .AND. ( LDV.LT.MV ) ) ) THEN
INFO = -11
- ELSE IF ( UCTOL .AND. (WORK(1) .LE. ONE) ) THEN
- INFO = - 12
- ELSE IF ( LWORK .LT. MAX0( M + N , 6 ) ) THEN
- INFO = - 13
+ ELSE IF( UCTOL .AND. ( WORK( 1 ).LE.ONE ) ) THEN
+ INFO = -12
+ ELSE IF( LWORK.LT.MAX0( M+N, 6 ) ) THEN
+ INFO = -13
ELSE
- INFO = 0
+ INFO = 0
END IF
*
* #:(
- IF ( INFO .NE. 0 ) THEN
+ IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGESVJ', -INFO )
RETURN
END IF
*
* #:) Quick return for void matrix
*
- IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) RETURN
+ IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )RETURN
*
* Set numerical parameters
* The stopping criterion for Jacobi rotations is
*
* where EPS is the round-off and CTOL is defined as follows:
*
- IF ( UCTOL ) THEN
+ IF( UCTOL ) THEN
* ... user controlled
- CTOL = WORK(1)
+ CTOL = WORK( 1 )
ELSE
* ... default
- IF ( LSVEC .OR. RSVEC .OR. APPLV ) THEN
- CTOL = DSQRT(DBLE(M))
+ IF( LSVEC .OR. RSVEC .OR. APPLV ) THEN
+ CTOL = DSQRT( DBLE( M ) )
ELSE
- CTOL = DBLE(M)
+ CTOL = DBLE( M )
END IF
END IF
* ... and the machine dependent parameters are
*[!] (Make sure that DLAMCH() works properly on the target machine.)
*
- EPSILON = DLAMCH('Epsilon')
- ROOTEPS = DSQRT(EPSILON)
- SFMIN = DLAMCH('SafeMinimum')
- ROOTSFMIN = DSQRT(SFMIN)
- SMALL = SFMIN / EPSILON
- BIG = DLAMCH('Overflow')
+ EPSILON = DLAMCH( 'Epsilon' )
+ ROOTEPS = DSQRT( EPSILON )
+ SFMIN = DLAMCH( 'SafeMinimum' )
+ ROOTSFMIN = DSQRT( SFMIN )
+ SMALL = SFMIN / EPSILON
+ BIG = DLAMCH( 'Overflow' )
* BIG = ONE / SFMIN
- ROOTBIG = ONE / ROOTSFMIN
- LARGE = BIG / DSQRT(DBLE(M*N))
- BIGTHETA = ONE / ROOTEPS
+ ROOTBIG = ONE / ROOTSFMIN
+ LARGE = BIG / DSQRT( DBLE( M*N ) )
+ BIGTHETA = ONE / ROOTEPS
*
- TOL = CTOL * EPSILON
- ROOTTOL = DSQRT(TOL)
+ TOL = CTOL*EPSILON
+ ROOTTOL = DSQRT( TOL )
*
- IF ( DBLE(M)*EPSILON .GE. ONE ) THEN
- INFO = - 5
+ IF( DBLE( M )*EPSILON.GE.ONE ) THEN
+ INFO = -5
CALL XERBLA( 'DGESVJ', -INFO )
RETURN
END IF
*
* Initialize the right singular vector matrix.
*
- IF ( RSVEC ) THEN
+ IF( RSVEC ) THEN
MVL = N
CALL DLASET( 'A', MVL, N, ZERO, ONE, V, LDV )
- ELSE IF ( APPLV ) THEN
+ ELSE IF( APPLV ) THEN
MVL = MV
END IF
RSVEC = RSVEC .OR. APPLV
* DSQRT(N)*max_i SVA(i) does not overflow. If INFinite entries
* in A are detected, the procedure returns with INFO=-6.
*
- SCALE = ONE / DSQRT(DBLE(M)*DBLE(N))
- NOSCALE = .TRUE.
- GOSCALE = .TRUE.
+ SCALE = ONE / DSQRT( DBLE( M )*DBLE( N ) )
+ NOSCALE = .TRUE.
+ GOSCALE = .TRUE.
*
- IF ( LOWER ) THEN
+ IF( LOWER ) THEN
* the input matrix is M-by-N lower triangular (trapezoidal)
DO 1874 p = 1, N
AAPP = ZERO
AAQQ = ZERO
- CALL DLASSQ( M-p+1, A(p,p), 1, AAPP, AAQQ )
- IF ( AAPP .GT. BIG ) THEN
- INFO = - 6
+ CALL DLASSQ( M-p+1, A( p, p ), 1, AAPP, AAQQ )
+ IF( AAPP.GT.BIG ) THEN
+ INFO = -6
CALL XERBLA( 'DGESVJ', -INFO )
RETURN
END IF
- AAQQ = DSQRT(AAQQ)
- IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCALE ) THEN
- SVA(p) = AAPP * AAQQ
+ AAQQ = DSQRT( AAQQ )
+ IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN
+ SVA( p ) = AAPP*AAQQ
ELSE
NOSCALE = .FALSE.
- SVA(p) = AAPP * ( AAQQ * SCALE )
- IF ( GOSCALE ) THEN
+ SVA( p ) = AAPP*( AAQQ*SCALE )
+ IF( GOSCALE ) THEN
GOSCALE = .FALSE.
DO 1873 q = 1, p - 1
- SVA(q) = SVA(q)*SCALE
+ SVA( q ) = SVA( q )*SCALE
1873 CONTINUE
END IF
END IF
1874 CONTINUE
- ELSE IF ( UPPER ) THEN
+ ELSE IF( UPPER ) THEN
* the input matrix is M-by-N upper triangular (trapezoidal)
DO 2874 p = 1, N
AAPP = ZERO
AAQQ = ZERO
- CALL DLASSQ( p, A(1,p), 1, AAPP, AAQQ )
- IF ( AAPP .GT. BIG ) THEN
- INFO = - 6
+ CALL DLASSQ( p, A( 1, p ), 1, AAPP, AAQQ )
+ IF( AAPP.GT.BIG ) THEN
+ INFO = -6
CALL XERBLA( 'DGESVJ', -INFO )
RETURN
END IF
- AAQQ = DSQRT(AAQQ)
- IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCALE ) THEN
- SVA(p) = AAPP * AAQQ
+ AAQQ = DSQRT( AAQQ )
+ IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN
+ SVA( p ) = AAPP*AAQQ
ELSE
NOSCALE = .FALSE.
- SVA(p) = AAPP * ( AAQQ * SCALE )
- IF ( GOSCALE ) THEN
+ SVA( p ) = AAPP*( AAQQ*SCALE )
+ IF( GOSCALE ) THEN
GOSCALE = .FALSE.
DO 2873 q = 1, p - 1
- SVA(q) = SVA(q)*SCALE
+ SVA( q ) = SVA( q )*SCALE
2873 CONTINUE
END IF
END IF
DO 3874 p = 1, N
AAPP = ZERO
AAQQ = ZERO
- CALL DLASSQ( M, A(1,p), 1, AAPP, AAQQ )
- IF ( AAPP .GT. BIG ) THEN
- INFO = - 6
+ CALL DLASSQ( M, A( 1, p ), 1, AAPP, AAQQ )
+ IF( AAPP.GT.BIG ) THEN
+ INFO = -6
CALL XERBLA( 'DGESVJ', -INFO )
RETURN
END IF
- AAQQ = DSQRT(AAQQ)
- IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCALE ) THEN
- SVA(p) = AAPP * AAQQ
+ AAQQ = DSQRT( AAQQ )
+ IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN
+ SVA( p ) = AAPP*AAQQ
ELSE
NOSCALE = .FALSE.
- SVA(p) = AAPP * ( AAQQ * SCALE )
- IF ( GOSCALE ) THEN
+ SVA( p ) = AAPP*( AAQQ*SCALE )
+ IF( GOSCALE ) THEN
GOSCALE = .FALSE.
DO 3873 q = 1, p - 1
- SVA(q) = SVA(q)*SCALE
+ SVA( q ) = SVA( q )*SCALE
3873 CONTINUE
END IF
END IF
3874 CONTINUE
END IF
*
- IF ( NOSCALE ) SCALE = ONE
+ IF( NOSCALE )SCALE = ONE
*
* Move the smaller part of the spectrum from the underflow threshold
*(!) Start by determining the position of the nonzero entries of the
AAPP = ZERO
AAQQ = BIG
DO 4781 p = 1, N
- IF ( SVA(p) .NE. ZERO ) AAQQ = DMIN1( AAQQ, SVA(p) )
- AAPP = DMAX1( AAPP, SVA(p) )
+ IF( SVA( p ).NE.ZERO )AAQQ = DMIN1( AAQQ, SVA( p ) )
+ AAPP = DMAX1( AAPP, SVA( p ) )
4781 CONTINUE
*
* #:) Quick return for zero matrix
*
- IF ( AAPP .EQ. ZERO ) THEN
- IF ( LSVEC ) CALL DLASET( 'G', M, N, ZERO, ONE, A, LDA )
- WORK(1) = ONE
- WORK(2) = ZERO
- WORK(3) = ZERO
- WORK(4) = ZERO
- WORK(5) = ZERO
- WORK(6) = ZERO
+ IF( AAPP.EQ.ZERO ) THEN
+ IF( LSVEC )CALL DLASET( 'G', M, N, ZERO, ONE, A, LDA )
+ WORK( 1 ) = ONE
+ WORK( 2 ) = ZERO
+ WORK( 3 ) = ZERO
+ WORK( 4 ) = ZERO
+ WORK( 5 ) = ZERO
+ WORK( 6 ) = ZERO
RETURN
END IF
*
* #:) Quick return for one-column matrix
*
- IF ( N .EQ. 1 ) THEN
- IF ( LSVEC )
- & CALL DLASCL( 'G',0,0,SVA(1),SCALE,M,1,A(1,1),LDA,IERR )
- WORK(1) = ONE / SCALE
- IF ( SVA(1) .GE. SFMIN ) THEN
- WORK(2) = ONE
+ IF( N.EQ.1 ) THEN
+ IF( LSVEC )CALL DLASCL( 'G', 0, 0, SVA( 1 ), SCALE, M, 1,
+ + A( 1, 1 ), LDA, IERR )
+ WORK( 1 ) = ONE / SCALE
+ IF( SVA( 1 ).GE.SFMIN ) THEN
+ WORK( 2 ) = ONE
ELSE
- WORK(2) = ZERO
+ WORK( 2 ) = ZERO
END IF
- WORK(3) = ZERO
- WORK(4) = ZERO
- WORK(5) = ZERO
- WORK(6) = ZERO
+ WORK( 3 ) = ZERO
+ WORK( 4 ) = ZERO
+ WORK( 5 ) = ZERO
+ WORK( 6 ) = ZERO
RETURN
END IF
*
* Protect small singular values from underflow, and try to
* avoid underflows/overflows in computing Jacobi rotations.
*
- SN = DSQRT( SFMIN / EPSILON )
- TEMP1 = DSQRT( BIG / DBLE(N) )
- IF ( (AAPP.LE.SN).OR.(AAQQ.GE.TEMP1)
- & .OR.((SN.LE.AAQQ).AND.(AAPP.LE.TEMP1)) ) THEN
- TEMP1 = DMIN1(BIG,TEMP1/AAPP)
+ SN = DSQRT( SFMIN / EPSILON )
+ TEMP1 = DSQRT( BIG / DBLE( N ) )
+ IF( ( AAPP.LE.SN ) .OR. ( AAQQ.GE.TEMP1 ) .OR.
+ + ( ( SN.LE.AAQQ ) .AND. ( AAPP.LE.TEMP1 ) ) ) THEN
+ TEMP1 = DMIN1( BIG, TEMP1 / AAPP )
* AAQQ = AAQQ*TEMP1
* AAPP = AAPP*TEMP1
- ELSE IF ( (AAQQ.LE.SN).AND.(AAPP.LE.TEMP1) ) THEN
- TEMP1 = DMIN1( SN / AAQQ, BIG/(AAPP*DSQRT(DBLE(N))) )
+ ELSE IF( ( AAQQ.LE.SN ) .AND. ( AAPP.LE.TEMP1 ) ) THEN
+ TEMP1 = DMIN1( SN / AAQQ, BIG / ( AAPP*DSQRT( DBLE( N ) ) ) )
* AAQQ = AAQQ*TEMP1
* AAPP = AAPP*TEMP1
- ELSE IF ( (AAQQ.GE.SN).AND.(AAPP.GE.TEMP1) ) THEN
+ ELSE IF( ( AAQQ.GE.SN ) .AND. ( AAPP.GE.TEMP1 ) ) THEN
TEMP1 = DMAX1( SN / AAQQ, TEMP1 / AAPP )
* AAQQ = AAQQ*TEMP1
* AAPP = AAPP*TEMP1
- ELSE IF ( (AAQQ.LE.SN).AND.(AAPP.GE.TEMP1) ) THEN
- TEMP1 = DMIN1( SN / AAQQ, BIG / (DSQRT(DBLE(N))*AAPP))
+ ELSE IF( ( AAQQ.LE.SN ) .AND. ( AAPP.GE.TEMP1 ) ) THEN
+ TEMP1 = DMIN1( SN / AAQQ, BIG / ( DSQRT( DBLE( N ) )*AAPP ) )
* AAQQ = AAQQ*TEMP1
* AAPP = AAPP*TEMP1
ELSE
*
* Scale, if necessary
*
- IF ( TEMP1 .NE. ONE ) THEN
+ IF( TEMP1.NE.ONE ) THEN
CALL DLASCL( 'G', 0, 0, ONE, TEMP1, N, 1, SVA, N, IERR )
END IF
- SCALE = TEMP1 * SCALE
- IF ( SCALE .NE. ONE ) THEN
+ SCALE = TEMP1*SCALE
+ IF( SCALE.NE.ONE ) THEN
CALL DLASCL( JOBA, 0, 0, ONE, SCALE, M, N, A, LDA, IERR )
SCALE = ONE / SCALE
END IF
*
* Row-cyclic Jacobi SVD algorithm with column pivoting
*
- EMPTSW = ( N * ( N - 1 ) ) / 2
- NOTROT = 0
- FASTR(1) = ZERO
+ EMPTSW = ( N*( N-1 ) ) / 2
+ NOTROT = 0
+ FASTR( 1 ) = ZERO
*
* A is represented in factored form A = A * diag(WORK), where diag(WORK)
* is initialized to identity. WORK is updated during fast scaled
* rotations.
*
DO 1868 q = 1, N
- WORK(q) = ONE
+ WORK( q ) = ONE
1868 CONTINUE
*
*
* parameters of the computer's memory.
*
NBL = N / KBL
- IF ( ( NBL * KBL ) .NE. N ) NBL = NBL + 1
+ IF( ( NBL*KBL ).NE.N )NBL = NBL + 1
*
BLSKIP = KBL**2
*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL.
* invokes cubic convergence. Big part of this cycle is done inside
* canonical subspaces of dimensions less than M.
*
- IF ( (LOWER .OR. UPPER) .AND. (N .GT. MAX0(64, 4*KBL)) ) THEN
+ IF( ( LOWER .OR. UPPER ) .AND. ( N.GT.MAX0( 64, 4*KBL ) ) ) THEN
*[TP] The number of partition levels and the actual partition are
* tuning parameters.
- N4 = N / 4
- N2 = N / 2
- N34 = 3 * N4
- IF ( APPLV ) THEN
- q = 0
- ELSE
- q = 1
- END IF
+ N4 = N / 4
+ N2 = N / 2
+ N34 = 3*N4
+ IF( APPLV ) THEN
+ q = 0
+ ELSE
+ q = 1
+ END IF
*
- IF ( LOWER ) THEN
+ IF( LOWER ) THEN
*
* This works very well on lower triangular matrices, in particular
* in the framework of the preconditioned Jacobi SVD (xGEJSV).
* [+ + x 0] actually work on [x 0] [x 0]
* [+ + x x] [x x]. [x x]
*
- CALL DGSVJ0(JOBV,M-N34,N-N34,A(N34+1,N34+1),LDA,WORK(N34+1),
- & SVA(N34+1),MVL,V(N34*q+1,N34+1),LDV,EPSILON,SFMIN,TOL,2,
- & WORK(N+1),LWORK-N,IERR )
+ CALL DGSVJ0( JOBV, M-N34, N-N34, A( N34+1, N34+1 ), LDA,
+ + WORK( N34+1 ), SVA( N34+1 ), MVL,
+ + V( N34*q+1, N34+1 ), LDV, EPSILON, SFMIN, TOL,
+ + 2, WORK( N+1 ), LWORK-N, IERR )
*
- CALL DGSVJ0( JOBV,M-N2,N34-N2,A(N2+1,N2+1),LDA,WORK(N2+1),
- & SVA(N2+1),MVL,V(N2*q+1,N2+1),LDV,EPSILON,SFMIN,TOL,2,
- & WORK(N+1),LWORK-N,IERR )
+ CALL DGSVJ0( JOBV, M-N2, N34-N2, A( N2+1, N2+1 ), LDA,
+ + WORK( N2+1 ), SVA( N2+1 ), MVL,
+ + V( N2*q+1, N2+1 ), LDV, EPSILON, SFMIN, TOL, 2,
+ + WORK( N+1 ), LWORK-N, IERR )
*
- CALL DGSVJ1( JOBV,M-N2,N-N2,N4,A(N2+1,N2+1),LDA,WORK(N2+1),
- & SVA(N2+1),MVL,V(N2*q+1,N2+1),LDV,EPSILON,SFMIN,TOL,1,
- & WORK(N+1),LWORK-N,IERR )
+ CALL DGSVJ1( JOBV, M-N2, N-N2, N4, A( N2+1, N2+1 ), LDA,
+ + WORK( N2+1 ), SVA( N2+1 ), MVL,
+ + V( N2*q+1, N2+1 ), LDV, EPSILON, SFMIN, TOL, 1,
+ + WORK( N+1 ), LWORK-N, IERR )
*
- CALL DGSVJ0( JOBV,M-N4,N2-N4,A(N4+1,N4+1),LDA,WORK(N4+1),
- & SVA(N4+1),MVL,V(N4*q+1,N4+1),LDV,EPSILON,SFMIN,TOL,1,
- & WORK(N+1),LWORK-N,IERR )
+ CALL DGSVJ0( JOBV, M-N4, N2-N4, A( N4+1, N4+1 ), LDA,
+ + WORK( N4+1 ), SVA( N4+1 ), MVL,
+ + V( N4*q+1, N4+1 ), LDV, EPSILON, SFMIN, TOL, 1,
+ + WORK( N+1 ), LWORK-N, IERR )
*
- CALL DGSVJ0( JOBV,M,N4,A,LDA,WORK,SVA,MVL,V,LDV,EPSILON,
- & SFMIN,TOL,1,WORK(N+1),LWORK-N,IERR )
+ CALL DGSVJ0( JOBV, M, N4, A, LDA, WORK, SVA, MVL, V, LDV,
+ + EPSILON, SFMIN, TOL, 1, WORK( N+1 ), LWORK-N,
+ + IERR )
*
- CALL DGSVJ1( JOBV,M,N2,N4,A,LDA,WORK,SVA,MVL,V,LDV,EPSILON,
- & SFMIN,TOL,1,WORK(N+1),LWORK-N,IERR )
+ CALL DGSVJ1( JOBV, M, N2, N4, A, LDA, WORK, SVA, MVL, V,
+ + LDV, EPSILON, SFMIN, TOL, 1, WORK( N+1 ),
+ + LWORK-N, IERR )
*
*
- ELSE IF ( UPPER ) THEN
+ ELSE IF( UPPER ) THEN
*
*
- CALL DGSVJ0( JOBV,N4,N4,A,LDA,WORK,SVA,MVL,V,LDV,EPSILON,
- & SFMIN,TOL,2,WORK(N+1),LWORK-N,IERR )
+ CALL DGSVJ0( JOBV, N4, N4, A, LDA, WORK, SVA, MVL, V, LDV,
+ + EPSILON, SFMIN, TOL, 2, WORK( N+1 ), LWORK-N,
+ + IERR )
*
- CALL DGSVJ0(JOBV,N2,N4,A(1,N4+1),LDA,WORK(N4+1),SVA(N4+1),MVL,
- & V(N4*q+1,N4+1),LDV,EPSILON,SFMIN,TOL,1,WORK(N+1),LWORK-N,
- & IERR )
+ CALL DGSVJ0( JOBV, N2, N4, A( 1, N4+1 ), LDA, WORK( N4+1 ),
+ + SVA( N4+1 ), MVL, V( N4*q+1, N4+1 ), LDV,
+ + EPSILON, SFMIN, TOL, 1, WORK( N+1 ), LWORK-N,
+ + IERR )
*
- CALL DGSVJ1( JOBV,N2,N2,N4,A,LDA,WORK,SVA,MVL,V,LDV,EPSILON,
- & SFMIN,TOL,1,WORK(N+1),LWORK-N,IERR )
+ CALL DGSVJ1( JOBV, N2, N2, N4, A, LDA, WORK, SVA, MVL, V,
+ + LDV, EPSILON, SFMIN, TOL, 1, WORK( N+1 ),
+ + LWORK-N, IERR )
*
- CALL DGSVJ0( JOBV,N2+N4,N4,A(1,N2+1),LDA,WORK(N2+1),SVA(N2+1),MVL,
- & V(N2*q+1,N2+1),LDV,EPSILON,SFMIN,TOL,1,
- & WORK(N+1),LWORK-N,IERR )
+ CALL DGSVJ0( JOBV, N2+N4, N4, A( 1, N2+1 ), LDA,
+ + WORK( N2+1 ), SVA( N2+1 ), MVL,
+ + V( N2*q+1, N2+1 ), LDV, EPSILON, SFMIN, TOL, 1,
+ + WORK( N+1 ), LWORK-N, IERR )
- END IF
+ END IF
*
END IF
*
-* -#- Row-cyclic pivot strategy with de Rijk's pivoting -#-
+* .. Row-cyclic pivot strategy with de Rijk's pivoting ..
*
DO 1993 i = 1, NSWEEP
*
* .. go go go ...
*
- MXAAPQ = ZERO
- MXSINJ = ZERO
- ISWROT = 0
+ MXAAPQ = ZERO
+ MXSINJ = ZERO
+ ISWROT = 0
*
- NOTROT = 0
- PSKIPPED = 0
+ NOTROT = 0
+ PSKIPPED = 0
*
* Each sweep is unrolled using KBL-by-KBL tiles over the pivot pairs
* 1 <= p < q <= N. This is the first step toward a blocked implementation
* of the rotations. New implementation, based on block transformations,
* is under development.
*
- DO 2000 ibr = 1, NBL
+ DO 2000 ibr = 1, NBL
*
- igl = ( ibr - 1 ) * KBL + 1
+ igl = ( ibr-1 )*KBL + 1
*
- DO 1002 ir1 = 0, MIN0( LKAHEAD, NBL - ibr )
+ DO 1002 ir1 = 0, MIN0( LKAHEAD, NBL-ibr )
*
- igl = igl + ir1 * KBL
+ igl = igl + ir1*KBL
*
- DO 2001 p = igl, MIN0( igl + KBL - 1, N - 1)
+ DO 2001 p = igl, MIN0( igl+KBL-1, N-1 )
*
* .. de Rijk's pivoting
*
- q = IDAMAX( N-p+1, SVA(p), 1 ) + p - 1
- IF ( p .NE. q ) THEN
- CALL DSWAP( M, A(1,p), 1, A(1,q), 1 )
- IF ( RSVEC ) CALL DSWAP( MVL, V(1,p), 1, V(1,q), 1 )
- TEMP1 = SVA(p)
- SVA(p) = SVA(q)
- SVA(q) = TEMP1
- TEMP1 = WORK(p)
- WORK(p) = WORK(q)
- WORK(q) = TEMP1
- END IF
-*
- IF ( ir1 .EQ. 0 ) THEN
+ q = IDAMAX( N-p+1, SVA( p ), 1 ) + p - 1
+ IF( p.NE.q ) THEN
+ CALL DSWAP( M, A( 1, p ), 1, A( 1, q ), 1 )
+ IF( RSVEC )CALL DSWAP( MVL, V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ TEMP1 = SVA( p )
+ SVA( p ) = SVA( q )
+ SVA( q ) = TEMP1
+ TEMP1 = WORK( p )
+ WORK( p ) = WORK( q )
+ WORK( q ) = TEMP1
+ END IF
+*
+ IF( ir1.EQ.0 ) THEN
*
* Column norms are periodically updated by explicit
* norm computation.
* If properly implemented DNRM2 is available, the IF-THEN-ELSE
* below should read "AAPP = DNRM2( M, A(1,p), 1 ) * WORK(p)".
*
- IF ((SVA(p) .LT. ROOTBIG) .AND. (SVA(p) .GT. ROOTSFMIN)) THEN
- SVA(p) = DNRM2( M, A(1,p), 1 ) * WORK(p)
- ELSE
- TEMP1 = ZERO
- AAPP = ZERO
- CALL DLASSQ( M, A(1,p), 1, TEMP1, AAPP )
- SVA(p) = TEMP1 * DSQRT(AAPP) * WORK(p)
- END IF
- AAPP = SVA(p)
- ELSE
- AAPP = SVA(p)
- END IF
-*
- IF ( AAPP .GT. ZERO ) THEN
-*
- PSKIPPED = 0
-*
- DO 2002 q = p + 1, MIN0( igl + KBL - 1, N )
-*
- AAQQ = SVA(q)
-*
- IF ( AAQQ .GT. ZERO ) THEN
-*
- AAPP0 = AAPP
- IF ( AAQQ .GE. ONE ) THEN
- ROTOK = ( SMALL*AAPP ) .LE. AAQQ
- IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN
- AAPQ = ( DDOT(M, A(1,p), 1, A(1,q), 1 ) *
- & WORK(p) * WORK(q) / AAQQ ) / AAPP
- ELSE
- CALL DCOPY( M, A(1,p), 1, WORK(N+1), 1 )
- CALL DLASCL( 'G', 0, 0, AAPP, WORK(p), M,
- & 1, WORK(N+1), LDA, IERR )
- AAPQ = DDOT( M, WORK(N+1),1, A(1,q),1 )*WORK(q) / AAQQ
- END IF
- ELSE
- ROTOK = AAPP .LE. ( AAQQ / SMALL )
- IF ( AAPP .GT. ( SMALL / AAQQ ) ) THEN
- AAPQ = ( DDOT( M, A(1,p), 1, A(1,q), 1 ) *
- & WORK(p) * WORK(q) / AAQQ ) / AAPP
- ELSE
- CALL DCOPY( M, A(1,q), 1, WORK(N+1), 1 )
- CALL DLASCL( 'G', 0, 0, AAQQ, WORK(q), M,
- & 1, WORK(N+1), LDA, IERR )
- AAPQ = DDOT( M, WORK(N+1),1, A(1,p),1 )*WORK(p) / AAPP
- END IF
- END IF
+ IF( ( SVA( p ).LT.ROOTBIG ) .AND.
+ + ( SVA( p ).GT.ROOTSFMIN ) ) THEN
+ SVA( p ) = DNRM2( M, A( 1, p ), 1 )*WORK( p )
+ ELSE
+ TEMP1 = ZERO
+ AAPP = ZERO
+ CALL DLASSQ( M, A( 1, p ), 1, TEMP1, AAPP )
+ SVA( p ) = TEMP1*DSQRT( AAPP )*WORK( p )
+ END IF
+ AAPP = SVA( p )
+ ELSE
+ AAPP = SVA( p )
+ END IF
+*
+ IF( AAPP.GT.ZERO ) THEN
+*
+ PSKIPPED = 0
+*
+ DO 2002 q = p + 1, MIN0( igl+KBL-1, N )
+*
+ AAQQ = SVA( q )
+*
+ IF( AAQQ.GT.ZERO ) THEN
+*
+ AAPP0 = AAPP
+ IF( AAQQ.GE.ONE ) THEN
+ ROTOK = ( SMALL*AAPP ).LE.AAQQ
+ IF( AAPP.LT.( BIG / AAQQ ) ) THEN
+ AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1,
+ + q ), 1 )*WORK( p )*WORK( q ) /
+ + AAQQ ) / AAPP
+ ELSE
+ CALL DCOPY( M, A( 1, p ), 1,
+ + WORK( N+1 ), 1 )
+ CALL DLASCL( 'G', 0, 0, AAPP,
+ + WORK( p ), M, 1,
+ + WORK( N+1 ), LDA, IERR )
+ AAPQ = DDOT( M, WORK( N+1 ), 1,
+ + A( 1, q ), 1 )*WORK( q ) / AAQQ
+ END IF
+ ELSE
+ ROTOK = AAPP.LE.( AAQQ / SMALL )
+ IF( AAPP.GT.( SMALL / AAQQ ) ) THEN
+ AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1,
+ + q ), 1 )*WORK( p )*WORK( q ) /
+ + AAQQ ) / AAPP
+ ELSE
+ CALL DCOPY( M, A( 1, q ), 1,
+ + WORK( N+1 ), 1 )
+ CALL DLASCL( 'G', 0, 0, AAQQ,
+ + WORK( q ), M, 1,
+ + WORK( N+1 ), LDA, IERR )
+ AAPQ = DDOT( M, WORK( N+1 ), 1,
+ + A( 1, p ), 1 )*WORK( p ) / AAPP
+ END IF
+ END IF
*
- MXAAPQ = DMAX1( MXAAPQ, DABS(AAPQ) )
+ MXAAPQ = DMAX1( MXAAPQ, DABS( AAPQ ) )
*
* TO rotate or NOT to rotate, THAT is the question ...
*
- IF ( DABS( AAPQ ) .GT. TOL ) THEN
+ IF( DABS( AAPQ ).GT.TOL ) THEN
*
* .. rotate
*[RTD] ROTATED = ROTATED + ONE
*
- IF ( ir1 .EQ. 0 ) THEN
- NOTROT = 0
- PSKIPPED = 0
- ISWROT = ISWROT + 1
- END IF
-*
- IF ( ROTOK ) THEN
-*
- AQOAP = AAQQ / AAPP
- APOAQ = AAPP / AAQQ
- THETA = - HALF * DABS( AQOAP - APOAQ ) / AAPQ
-*
- IF ( DABS( THETA ) .GT. BIGTHETA ) THEN
-*
- T = HALF / THETA
- FASTR(3) = T * WORK(p) / WORK(q)
- FASTR(4) = - T * WORK(q) / WORK(p)
- CALL DROTM( M, A(1,p), 1, A(1,q), 1, FASTR )
- IF ( RSVEC )
- & CALL DROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR )
- SVA(q) = AAQQ*DSQRT( DMAX1(ZERO,ONE + T*APOAQ*AAPQ) )
- AAPP = AAPP*DSQRT( ONE - T*AQOAP*AAPQ )
- MXSINJ = DMAX1( MXSINJ, DABS(T) )
-*
- ELSE
+ IF( ir1.EQ.0 ) THEN
+ NOTROT = 0
+ PSKIPPED = 0
+ ISWROT = ISWROT + 1
+ END IF
+*
+ IF( ROTOK ) THEN
+*
+ AQOAP = AAQQ / AAPP
+ APOAQ = AAPP / AAQQ
+ THETA = -HALF*DABS( AQOAP-APOAQ ) /
+ + AAPQ
+*
+ IF( DABS( THETA ).GT.BIGTHETA ) THEN
+*
+ T = HALF / THETA
+ FASTR( 3 ) = T*WORK( p ) / WORK( q )
+ FASTR( 4 ) = -T*WORK( q ) /
+ + WORK( p )
+ CALL DROTM( M, A( 1, p ), 1,
+ + A( 1, q ), 1, FASTR )
+ IF( RSVEC )CALL DROTM( MVL,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1,
+ + FASTR )
+ SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
+ + ONE+T*APOAQ*AAPQ ) )
+ AAPP = AAPP*DSQRT( ONE-T*AQOAP*
+ + AAPQ )
+ MXSINJ = DMAX1( MXSINJ, DABS( T ) )
+*
+ ELSE
*
* .. choose correct signum for THETA and rotate
*
- THSIGN = - DSIGN(ONE,AAPQ)
- T = ONE / ( THETA + THSIGN*DSQRT(ONE+THETA*THETA) )
- CS = DSQRT( ONE / ( ONE + T*T ) )
- SN = T * CS
-*
- MXSINJ = DMAX1( MXSINJ, DABS(SN) )
- SVA(q) = AAQQ*DSQRT( DMAX1(ZERO, ONE+T*APOAQ*AAPQ) )
- AAPP = AAPP*DSQRT( DMAX1(ZERO, ONE-T*AQOAP*AAPQ) )
-*
- APOAQ = WORK(p) / WORK(q)
- AQOAP = WORK(q) / WORK(p)
- IF ( WORK(p) .GE. ONE ) THEN
- IF ( WORK(q) .GE. ONE ) THEN
- FASTR(3) = T * APOAQ
- FASTR(4) = - T * AQOAP
- WORK(p) = WORK(p) * CS
- WORK(q) = WORK(q) * CS
- CALL DROTM( M, A(1,p),1, A(1,q),1, FASTR )
- IF ( RSVEC )
- & CALL DROTM( MVL, V(1,p),1, V(1,q),1, FASTR )
- ELSE
- CALL DAXPY( M, -T*AQOAP, A(1,q),1, A(1,p),1 )
- CALL DAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 )
- WORK(p) = WORK(p) * CS
- WORK(q) = WORK(q) / CS
- IF ( RSVEC ) THEN
- CALL DAXPY(MVL, -T*AQOAP, V(1,q),1,V(1,p),1)
- CALL DAXPY(MVL,CS*SN*APOAQ, V(1,p),1,V(1,q),1)
- END IF
- END IF
- ELSE
- IF ( WORK(q) .GE. ONE ) THEN
- CALL DAXPY( M, T*APOAQ, A(1,p),1, A(1,q),1 )
- CALL DAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 )
- WORK(p) = WORK(p) / CS
- WORK(q) = WORK(q) * CS
- IF ( RSVEC ) THEN
- CALL DAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1)
- CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1)
- END IF
- ELSE
- IF ( WORK(p) .GE. WORK(q) ) THEN
- CALL DAXPY( M,-T*AQOAP, A(1,q),1,A(1,p),1 )
- CALL DAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 )
- WORK(p) = WORK(p) * CS
- WORK(q) = WORK(q) / CS
- IF ( RSVEC ) THEN
- CALL DAXPY(MVL, -T*AQOAP, V(1,q),1,V(1,p),1)
- CALL DAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1)
- END IF
- ELSE
- CALL DAXPY( M, T*APOAQ, A(1,p),1,A(1,q),1)
- CALL DAXPY( M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1)
- WORK(p) = WORK(p) / CS
- WORK(q) = WORK(q) * CS
- IF ( RSVEC ) THEN
- CALL DAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1)
- CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1)
- END IF
- END IF
- END IF
- ENDIF
- END IF
-*
- ELSE
+ THSIGN = -DSIGN( ONE, AAPQ )
+ T = ONE / ( THETA+THSIGN*
+ + DSQRT( ONE+THETA*THETA ) )
+ CS = DSQRT( ONE / ( ONE+T*T ) )
+ SN = T*CS
+*
+ MXSINJ = DMAX1( MXSINJ, DABS( SN ) )
+ SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
+ + ONE+T*APOAQ*AAPQ ) )
+ AAPP = AAPP*DSQRT( DMAX1( ZERO,
+ + ONE-T*AQOAP*AAPQ ) )
+*
+ APOAQ = WORK( p ) / WORK( q )
+ AQOAP = WORK( q ) / WORK( p )
+ IF( WORK( p ).GE.ONE ) THEN
+ IF( WORK( q ).GE.ONE ) THEN
+ FASTR( 3 ) = T*APOAQ
+ FASTR( 4 ) = -T*AQOAP
+ WORK( p ) = WORK( p )*CS
+ WORK( q ) = WORK( q )*CS
+ CALL DROTM( M, A( 1, p ), 1,
+ + A( 1, q ), 1,
+ + FASTR )
+ IF( RSVEC )CALL DROTM( MVL,
+ + V( 1, p ), 1, V( 1, q ),
+ + 1, FASTR )
+ ELSE
+ CALL DAXPY( M, -T*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ CALL DAXPY( M, CS*SN*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ WORK( p ) = WORK( p )*CS
+ WORK( q ) = WORK( q ) / CS
+ IF( RSVEC ) THEN
+ CALL DAXPY( MVL, -T*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ CALL DAXPY( MVL,
+ + CS*SN*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ END IF
+ END IF
+ ELSE
+ IF( WORK( q ).GE.ONE ) THEN
+ CALL DAXPY( M, T*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ CALL DAXPY( M, -CS*SN*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ WORK( p ) = WORK( p ) / CS
+ WORK( q ) = WORK( q )*CS
+ IF( RSVEC ) THEN
+ CALL DAXPY( MVL, T*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ CALL DAXPY( MVL,
+ + -CS*SN*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ END IF
+ ELSE
+ IF( WORK( p ).GE.WORK( q ) )
+ + THEN
+ CALL DAXPY( M, -T*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ CALL DAXPY( M, CS*SN*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ WORK( p ) = WORK( p )*CS
+ WORK( q ) = WORK( q ) / CS
+ IF( RSVEC ) THEN
+ CALL DAXPY( MVL,
+ + -T*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ CALL DAXPY( MVL,
+ + CS*SN*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ END IF
+ ELSE
+ CALL DAXPY( M, T*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ CALL DAXPY( M,
+ + -CS*SN*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ WORK( p ) = WORK( p ) / CS
+ WORK( q ) = WORK( q )*CS
+ IF( RSVEC ) THEN
+ CALL DAXPY( MVL,
+ + T*APOAQ, V( 1, p ),
+ + 1, V( 1, q ), 1 )
+ CALL DAXPY( MVL,
+ + -CS*SN*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ END IF
+ END IF
+ END IF
+ END IF
+ END IF
+*
+ ELSE
* .. have to use modified Gram-Schmidt like transformation
- CALL DCOPY( M, A(1,p), 1, WORK(N+1), 1 )
- CALL DLASCL( 'G',0,0,AAPP,ONE,M,1,WORK(N+1),LDA,IERR )
- CALL DLASCL( 'G',0,0,AAQQ,ONE,M,1, A(1,q),LDA,IERR )
- TEMP1 = -AAPQ * WORK(p) / WORK(q)
- CALL DAXPY ( M, TEMP1, WORK(N+1), 1, A(1,q), 1 )
- CALL DLASCL( 'G',0,0,ONE,AAQQ,M,1, A(1,q),LDA,IERR )
- SVA(q) = AAQQ*DSQRT( DMAX1( ZERO, ONE - AAPQ*AAPQ ) )
- MXSINJ = DMAX1( MXSINJ, SFMIN )
- END IF
+ CALL DCOPY( M, A( 1, p ), 1,
+ + WORK( N+1 ), 1 )
+ CALL DLASCL( 'G', 0, 0, AAPP, ONE, M,
+ + 1, WORK( N+1 ), LDA,
+ + IERR )
+ CALL DLASCL( 'G', 0, 0, AAQQ, ONE, M,
+ + 1, A( 1, q ), LDA, IERR )
+ TEMP1 = -AAPQ*WORK( p ) / WORK( q )
+ CALL DAXPY( M, TEMP1, WORK( N+1 ), 1,
+ + A( 1, q ), 1 )
+ CALL DLASCL( 'G', 0, 0, ONE, AAQQ, M,
+ + 1, A( 1, q ), LDA, IERR )
+ SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
+ + ONE-AAPQ*AAPQ ) )
+ MXSINJ = DMAX1( MXSINJ, SFMIN )
+ END IF
* END IF ROTOK THEN ... ELSE
*
* In the case of cancellation in updating SVA(q), SVA(p)
* recompute SVA(q), SVA(p).
*
- IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS ) THEN
- IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN
- SVA(q) = DNRM2( M, A(1,q), 1 ) * WORK(q)
- ELSE
- T = ZERO
- AAQQ = ZERO
- CALL DLASSQ( M, A(1,q), 1, T, AAQQ )
- SVA(q) = T * DSQRT(AAQQ) * WORK(q)
- END IF
- END IF
- IF ( ( AAPP / AAPP0) .LE. ROOTEPS ) THEN
- IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN
- AAPP = DNRM2( M, A(1,p), 1 ) * WORK(p)
- ELSE
- T = ZERO
- AAPP = ZERO
- CALL DLASSQ( M, A(1,p), 1, T, AAPP )
- AAPP = T * DSQRT(AAPP) * WORK(p)
- END IF
- SVA(p) = AAPP
- END IF
-*
- ELSE
+ IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS )
+ + THEN
+ IF( ( AAQQ.LT.ROOTBIG ) .AND.
+ + ( AAQQ.GT.ROOTSFMIN ) ) THEN
+ SVA( q ) = DNRM2( M, A( 1, q ), 1 )*
+ + WORK( q )
+ ELSE
+ T = ZERO
+ AAQQ = ZERO
+ CALL DLASSQ( M, A( 1, q ), 1, T,
+ + AAQQ )
+ SVA( q ) = T*DSQRT( AAQQ )*WORK( q )
+ END IF
+ END IF
+ IF( ( AAPP / AAPP0 ).LE.ROOTEPS ) THEN
+ IF( ( AAPP.LT.ROOTBIG ) .AND.
+ + ( AAPP.GT.ROOTSFMIN ) ) THEN
+ AAPP = DNRM2( M, A( 1, p ), 1 )*
+ + WORK( p )
+ ELSE
+ T = ZERO
+ AAPP = ZERO
+ CALL DLASSQ( M, A( 1, p ), 1, T,
+ + AAPP )
+ AAPP = T*DSQRT( AAPP )*WORK( p )
+ END IF
+ SVA( p ) = AAPP
+ END IF
+*
+ ELSE
* A(:,p) and A(:,q) already numerically orthogonal
- IF ( ir1 .EQ. 0 ) NOTROT = NOTROT + 1
+ IF( ir1.EQ.0 )NOTROT = NOTROT + 1
*[RTD] SKIPPED = SKIPPED + 1
- PSKIPPED = PSKIPPED + 1
- END IF
- ELSE
+ PSKIPPED = PSKIPPED + 1
+ END IF
+ ELSE
* A(:,q) is zero column
- IF ( ir1. EQ. 0 ) NOTROT = NOTROT + 1
- PSKIPPED = PSKIPPED + 1
- END IF
+ IF( ir1.EQ.0 )NOTROT = NOTROT + 1
+ PSKIPPED = PSKIPPED + 1
+ END IF
*
- IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN
- IF ( ir1 .EQ. 0 ) AAPP = - AAPP
- NOTROT = 0
- GO TO 2103
- END IF
+ IF( ( i.LE.SWBAND ) .AND.
+ + ( PSKIPPED.GT.ROWSKIP ) ) THEN
+ IF( ir1.EQ.0 )AAPP = -AAPP
+ NOTROT = 0
+ GO TO 2103
+ END IF
*
- 2002 CONTINUE
+ 2002 CONTINUE
* END q-LOOP
*
- 2103 CONTINUE
+ 2103 CONTINUE
* bailed out of q-loop
*
- SVA(p) = AAPP
+ SVA( p ) = AAPP
*
- ELSE
- SVA(p) = AAPP
- IF ( ( ir1 .EQ. 0 ) .AND. (AAPP .EQ. ZERO) )
- & NOTROT=NOTROT+MIN0(igl+KBL-1,N)-p
- END IF
+ ELSE
+ SVA( p ) = AAPP
+ IF( ( ir1.EQ.0 ) .AND. ( AAPP.EQ.ZERO ) )
+ + NOTROT = NOTROT + MIN0( igl+KBL-1, N ) - p
+ END IF
*
- 2001 CONTINUE
+ 2001 CONTINUE
* end of the p-loop
* end of doing the block ( ibr, ibr )
- 1002 CONTINUE
+ 1002 CONTINUE
* end of ir1-loop
*
* ... go to the off diagonal blocks
*
- igl = ( ibr - 1 ) * KBL + 1
+ igl = ( ibr-1 )*KBL + 1
*
- DO 2010 jbc = ibr + 1, NBL
+ DO 2010 jbc = ibr + 1, NBL
*
- jgl = ( jbc - 1 ) * KBL + 1
+ jgl = ( jbc-1 )*KBL + 1
*
* doing the block at ( ibr, jbc )
*
- IJBLSK = 0
- DO 2100 p = igl, MIN0( igl + KBL - 1, N )
+ IJBLSK = 0
+ DO 2100 p = igl, MIN0( igl+KBL-1, N )
*
- AAPP = SVA(p)
- IF ( AAPP .GT. ZERO ) THEN
+ AAPP = SVA( p )
+ IF( AAPP.GT.ZERO ) THEN
*
- PSKIPPED = 0
+ PSKIPPED = 0
*
- DO 2200 q = jgl, MIN0( jgl + KBL - 1, N )
+ DO 2200 q = jgl, MIN0( jgl+KBL-1, N )
*
- AAQQ = SVA(q)
- IF ( AAQQ .GT. ZERO ) THEN
- AAPP0 = AAPP
+ AAQQ = SVA( q )
+ IF( AAQQ.GT.ZERO ) THEN
+ AAPP0 = AAPP
*
-* -#- M x 2 Jacobi SVD -#-
+* .. M x 2 Jacobi SVD ..
*
* Safe Gram matrix computation
*
- IF ( AAQQ .GE. ONE ) THEN
- IF ( AAPP .GE. AAQQ ) THEN
- ROTOK = ( SMALL*AAPP ) .LE. AAQQ
- ELSE
- ROTOK = ( SMALL*AAQQ ) .LE. AAPP
- END IF
- IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN
- AAPQ = ( DDOT(M, A(1,p), 1, A(1,q), 1 ) *
- & WORK(p) * WORK(q) / AAQQ ) / AAPP
- ELSE
- CALL DCOPY( M, A(1,p), 1, WORK(N+1), 1 )
- CALL DLASCL( 'G', 0, 0, AAPP, WORK(p), M,
- & 1, WORK(N+1), LDA, IERR )
- AAPQ = DDOT( M, WORK(N+1), 1, A(1,q), 1 ) *
- & WORK(q) / AAQQ
- END IF
- ELSE
- IF ( AAPP .GE. AAQQ ) THEN
- ROTOK = AAPP .LE. ( AAQQ / SMALL )
- ELSE
- ROTOK = AAQQ .LE. ( AAPP / SMALL )
- END IF
- IF ( AAPP .GT. ( SMALL / AAQQ ) ) THEN
- AAPQ = ( DDOT( M, A(1,p), 1, A(1,q), 1 ) *
- & WORK(p) * WORK(q) / AAQQ ) / AAPP
- ELSE
- CALL DCOPY( M, A(1,q), 1, WORK(N+1), 1 )
- CALL DLASCL( 'G', 0, 0, AAQQ, WORK(q), M, 1,
- & WORK(N+1), LDA, IERR )
- AAPQ = DDOT(M,WORK(N+1),1,A(1,p),1) * WORK(p) / AAPP
- END IF
- END IF
+ IF( AAQQ.GE.ONE ) THEN
+ IF( AAPP.GE.AAQQ ) THEN
+ ROTOK = ( SMALL*AAPP ).LE.AAQQ
+ ELSE
+ ROTOK = ( SMALL*AAQQ ).LE.AAPP
+ END IF
+ IF( AAPP.LT.( BIG / AAQQ ) ) THEN
+ AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1,
+ + q ), 1 )*WORK( p )*WORK( q ) /
+ + AAQQ ) / AAPP
+ ELSE
+ CALL DCOPY( M, A( 1, p ), 1,
+ + WORK( N+1 ), 1 )
+ CALL DLASCL( 'G', 0, 0, AAPP,
+ + WORK( p ), M, 1,
+ + WORK( N+1 ), LDA, IERR )
+ AAPQ = DDOT( M, WORK( N+1 ), 1,
+ + A( 1, q ), 1 )*WORK( q ) / AAQQ
+ END IF
+ ELSE
+ IF( AAPP.GE.AAQQ ) THEN
+ ROTOK = AAPP.LE.( AAQQ / SMALL )
+ ELSE
+ ROTOK = AAQQ.LE.( AAPP / SMALL )
+ END IF
+ IF( AAPP.GT.( SMALL / AAQQ ) ) THEN
+ AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1,
+ + q ), 1 )*WORK( p )*WORK( q ) /
+ + AAQQ ) / AAPP
+ ELSE
+ CALL DCOPY( M, A( 1, q ), 1,
+ + WORK( N+1 ), 1 )
+ CALL DLASCL( 'G', 0, 0, AAQQ,
+ + WORK( q ), M, 1,
+ + WORK( N+1 ), LDA, IERR )
+ AAPQ = DDOT( M, WORK( N+1 ), 1,
+ + A( 1, p ), 1 )*WORK( p ) / AAPP
+ END IF
+ END IF
*
- MXAAPQ = DMAX1( MXAAPQ, DABS(AAPQ) )
+ MXAAPQ = DMAX1( MXAAPQ, DABS( AAPQ ) )
*
* TO rotate or NOT to rotate, THAT is the question ...
*
- IF ( DABS( AAPQ ) .GT. TOL ) THEN
- NOTROT = 0
+ IF( DABS( AAPQ ).GT.TOL ) THEN
+ NOTROT = 0
*[RTD] ROTATED = ROTATED + 1
- PSKIPPED = 0
- ISWROT = ISWROT + 1
-*
- IF ( ROTOK ) THEN
-*
- AQOAP = AAQQ / AAPP
- APOAQ = AAPP / AAQQ
- THETA = - HALF * DABS( AQOAP - APOAQ ) / AAPQ
- IF ( AAQQ .GT. AAPP0 ) THETA = - THETA
-*
- IF ( DABS( THETA ) .GT. BIGTHETA ) THEN
- T = HALF / THETA
- FASTR(3) = T * WORK(p) / WORK(q)
- FASTR(4) = -T * WORK(q) / WORK(p)
- CALL DROTM( M, A(1,p), 1, A(1,q), 1, FASTR )
- IF ( RSVEC )
- & CALL DROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR )
- SVA(q) = AAQQ*DSQRT( DMAX1(ZERO,ONE + T*APOAQ*AAPQ) )
- AAPP = AAPP*DSQRT( DMAX1(ZERO,ONE - T*AQOAP*AAPQ) )
- MXSINJ = DMAX1( MXSINJ, DABS(T) )
- ELSE
+ PSKIPPED = 0
+ ISWROT = ISWROT + 1
+*
+ IF( ROTOK ) THEN
+*
+ AQOAP = AAQQ / AAPP
+ APOAQ = AAPP / AAQQ
+ THETA = -HALF*DABS( AQOAP-APOAQ ) /
+ + AAPQ
+ IF( AAQQ.GT.AAPP0 )THETA = -THETA
+*
+ IF( DABS( THETA ).GT.BIGTHETA ) THEN
+ T = HALF / THETA
+ FASTR( 3 ) = T*WORK( p ) / WORK( q )
+ FASTR( 4 ) = -T*WORK( q ) /
+ + WORK( p )
+ CALL DROTM( M, A( 1, p ), 1,
+ + A( 1, q ), 1, FASTR )
+ IF( RSVEC )CALL DROTM( MVL,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1,
+ + FASTR )
+ SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
+ + ONE+T*APOAQ*AAPQ ) )
+ AAPP = AAPP*DSQRT( DMAX1( ZERO,
+ + ONE-T*AQOAP*AAPQ ) )
+ MXSINJ = DMAX1( MXSINJ, DABS( T ) )
+ ELSE
*
* .. choose correct signum for THETA and rotate
*
- THSIGN = - DSIGN(ONE,AAPQ)
- IF ( AAQQ .GT. AAPP0 ) THSIGN = - THSIGN
- T = ONE / ( THETA + THSIGN*DSQRT(ONE+THETA*THETA) )
- CS = DSQRT( ONE / ( ONE + T*T ) )
- SN = T * CS
- MXSINJ = DMAX1( MXSINJ, DABS(SN) )
- SVA(q) = AAQQ*DSQRT( DMAX1(ZERO, ONE+T*APOAQ*AAPQ) )
- AAPP = AAPP*DSQRT( ONE - T*AQOAP*AAPQ)
-*
- APOAQ = WORK(p) / WORK(q)
- AQOAP = WORK(q) / WORK(p)
- IF ( WORK(p) .GE. ONE ) THEN
-*
- IF ( WORK(q) .GE. ONE ) THEN
- FASTR(3) = T * APOAQ
- FASTR(4) = - T * AQOAP
- WORK(p) = WORK(p) * CS
- WORK(q) = WORK(q) * CS
- CALL DROTM( M, A(1,p),1, A(1,q),1, FASTR )
- IF ( RSVEC )
- & CALL DROTM( MVL, V(1,p),1, V(1,q),1, FASTR )
- ELSE
- CALL DAXPY( M, -T*AQOAP, A(1,q),1, A(1,p),1 )
- CALL DAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 )
- IF ( RSVEC ) THEN
- CALL DAXPY( MVL, -T*AQOAP, V(1,q),1, V(1,p),1 )
- CALL DAXPY( MVL,CS*SN*APOAQ,V(1,p),1, V(1,q),1 )
- END IF
- WORK(p) = WORK(p) * CS
- WORK(q) = WORK(q) / CS
- END IF
- ELSE
- IF ( WORK(q) .GE. ONE ) THEN
- CALL DAXPY( M, T*APOAQ, A(1,p),1, A(1,q),1 )
- CALL DAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 )
- IF ( RSVEC ) THEN
- CALL DAXPY(MVL,T*APOAQ, V(1,p),1, V(1,q),1 )
- CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1, V(1,p),1 )
- END IF
- WORK(p) = WORK(p) / CS
- WORK(q) = WORK(q) * CS
- ELSE
- IF ( WORK(p) .GE. WORK(q) ) THEN
- CALL DAXPY( M,-T*AQOAP, A(1,q),1,A(1,p),1 )
- CALL DAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 )
- WORK(p) = WORK(p) * CS
- WORK(q) = WORK(q) / CS
- IF ( RSVEC ) THEN
- CALL DAXPY( MVL, -T*AQOAP, V(1,q),1,V(1,p),1)
- CALL DAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1)
- END IF
- ELSE
- CALL DAXPY(M, T*APOAQ, A(1,p),1,A(1,q),1)
- CALL DAXPY(M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1)
- WORK(p) = WORK(p) / CS
- WORK(q) = WORK(q) * CS
- IF ( RSVEC ) THEN
- CALL DAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1)
- CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1)
- END IF
- END IF
- END IF
- ENDIF
- END IF
-*
- ELSE
- IF ( AAPP .GT. AAQQ ) THEN
- CALL DCOPY( M, A(1,p), 1, WORK(N+1), 1 )
- CALL DLASCL('G',0,0,AAPP,ONE,M,1,WORK(N+1),LDA,IERR)
- CALL DLASCL('G',0,0,AAQQ,ONE,M,1, A(1,q),LDA,IERR)
- TEMP1 = -AAPQ * WORK(p) / WORK(q)
- CALL DAXPY(M,TEMP1,WORK(N+1),1,A(1,q),1)
- CALL DLASCL('G',0,0,ONE,AAQQ,M,1,A(1,q),LDA,IERR)
- SVA(q) = AAQQ*DSQRT(DMAX1(ZERO, ONE - AAPQ*AAPQ))
- MXSINJ = DMAX1( MXSINJ, SFMIN )
- ELSE
- CALL DCOPY( M, A(1,q), 1, WORK(N+1), 1 )
- CALL DLASCL('G',0,0,AAQQ,ONE,M,1,WORK(N+1),LDA,IERR)
- CALL DLASCL('G',0,0,AAPP,ONE,M,1, A(1,p),LDA,IERR)
- TEMP1 = -AAPQ * WORK(q) / WORK(p)
- CALL DAXPY(M,TEMP1,WORK(N+1),1,A(1,p),1)
- CALL DLASCL('G',0,0,ONE,AAPP,M,1,A(1,p),LDA,IERR)
- SVA(p) = AAPP*DSQRT(DMAX1(ZERO, ONE - AAPQ*AAPQ))
- MXSINJ = DMAX1( MXSINJ, SFMIN )
- END IF
- END IF
+ THSIGN = -DSIGN( ONE, AAPQ )
+ IF( AAQQ.GT.AAPP0 )THSIGN = -THSIGN
+ T = ONE / ( THETA+THSIGN*
+ + DSQRT( ONE+THETA*THETA ) )
+ CS = DSQRT( ONE / ( ONE+T*T ) )
+ SN = T*CS
+ MXSINJ = DMAX1( MXSINJ, DABS( SN ) )
+ SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
+ + ONE+T*APOAQ*AAPQ ) )
+ AAPP = AAPP*DSQRT( ONE-T*AQOAP*
+ + AAPQ )
+*
+ APOAQ = WORK( p ) / WORK( q )
+ AQOAP = WORK( q ) / WORK( p )
+ IF( WORK( p ).GE.ONE ) THEN
+*
+ IF( WORK( q ).GE.ONE ) THEN
+ FASTR( 3 ) = T*APOAQ
+ FASTR( 4 ) = -T*AQOAP
+ WORK( p ) = WORK( p )*CS
+ WORK( q ) = WORK( q )*CS
+ CALL DROTM( M, A( 1, p ), 1,
+ + A( 1, q ), 1,
+ + FASTR )
+ IF( RSVEC )CALL DROTM( MVL,
+ + V( 1, p ), 1, V( 1, q ),
+ + 1, FASTR )
+ ELSE
+ CALL DAXPY( M, -T*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ CALL DAXPY( M, CS*SN*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ IF( RSVEC ) THEN
+ CALL DAXPY( MVL, -T*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ CALL DAXPY( MVL,
+ + CS*SN*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ END IF
+ WORK( p ) = WORK( p )*CS
+ WORK( q ) = WORK( q ) / CS
+ END IF
+ ELSE
+ IF( WORK( q ).GE.ONE ) THEN
+ CALL DAXPY( M, T*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ CALL DAXPY( M, -CS*SN*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ IF( RSVEC ) THEN
+ CALL DAXPY( MVL, T*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ CALL DAXPY( MVL,
+ + -CS*SN*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ END IF
+ WORK( p ) = WORK( p ) / CS
+ WORK( q ) = WORK( q )*CS
+ ELSE
+ IF( WORK( p ).GE.WORK( q ) )
+ + THEN
+ CALL DAXPY( M, -T*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ CALL DAXPY( M, CS*SN*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ WORK( p ) = WORK( p )*CS
+ WORK( q ) = WORK( q ) / CS
+ IF( RSVEC ) THEN
+ CALL DAXPY( MVL,
+ + -T*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ CALL DAXPY( MVL,
+ + CS*SN*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ END IF
+ ELSE
+ CALL DAXPY( M, T*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ CALL DAXPY( M,
+ + -CS*SN*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ WORK( p ) = WORK( p ) / CS
+ WORK( q ) = WORK( q )*CS
+ IF( RSVEC ) THEN
+ CALL DAXPY( MVL,
+ + T*APOAQ, V( 1, p ),
+ + 1, V( 1, q ), 1 )
+ CALL DAXPY( MVL,
+ + -CS*SN*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ END IF
+ END IF
+ END IF
+ END IF
+ END IF
+*
+ ELSE
+ IF( AAPP.GT.AAQQ ) THEN
+ CALL DCOPY( M, A( 1, p ), 1,
+ + WORK( N+1 ), 1 )
+ CALL DLASCL( 'G', 0, 0, AAPP, ONE,
+ + M, 1, WORK( N+1 ), LDA,
+ + IERR )
+ CALL DLASCL( 'G', 0, 0, AAQQ, ONE,
+ + M, 1, A( 1, q ), LDA,
+ + IERR )
+ TEMP1 = -AAPQ*WORK( p ) / WORK( q )
+ CALL DAXPY( M, TEMP1, WORK( N+1 ),
+ + 1, A( 1, q ), 1 )
+ CALL DLASCL( 'G', 0, 0, ONE, AAQQ,
+ + M, 1, A( 1, q ), LDA,
+ + IERR )
+ SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
+ + ONE-AAPQ*AAPQ ) )
+ MXSINJ = DMAX1( MXSINJ, SFMIN )
+ ELSE
+ CALL DCOPY( M, A( 1, q ), 1,
+ + WORK( N+1 ), 1 )
+ CALL DLASCL( 'G', 0, 0, AAQQ, ONE,
+ + M, 1, WORK( N+1 ), LDA,
+ + IERR )
+ CALL DLASCL( 'G', 0, 0, AAPP, ONE,
+ + M, 1, A( 1, p ), LDA,
+ + IERR )
+ TEMP1 = -AAPQ*WORK( q ) / WORK( p )
+ CALL DAXPY( M, TEMP1, WORK( N+1 ),
+ + 1, A( 1, p ), 1 )
+ CALL DLASCL( 'G', 0, 0, ONE, AAPP,
+ + M, 1, A( 1, p ), LDA,
+ + IERR )
+ SVA( p ) = AAPP*DSQRT( DMAX1( ZERO,
+ + ONE-AAPQ*AAPQ ) )
+ MXSINJ = DMAX1( MXSINJ, SFMIN )
+ END IF
+ END IF
* END IF ROTOK THEN ... ELSE
*
* In the case of cancellation in updating SVA(q)
* .. recompute SVA(q)
- IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS ) THEN
- IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN
- SVA(q) = DNRM2( M, A(1,q), 1 ) * WORK(q)
- ELSE
- T = ZERO
- AAQQ = ZERO
- CALL DLASSQ( M, A(1,q), 1, T, AAQQ )
- SVA(q) = T * DSQRT(AAQQ) * WORK(q)
- END IF
- END IF
- IF ( (AAPP / AAPP0 )**2 .LE. ROOTEPS ) THEN
- IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN
- AAPP = DNRM2( M, A(1,p), 1 ) * WORK(p)
- ELSE
- T = ZERO
- AAPP = ZERO
- CALL DLASSQ( M, A(1,p), 1, T, AAPP )
- AAPP = T * DSQRT(AAPP) * WORK(p)
- END IF
- SVA(p) = AAPP
- END IF
+ IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS )
+ + THEN
+ IF( ( AAQQ.LT.ROOTBIG ) .AND.
+ + ( AAQQ.GT.ROOTSFMIN ) ) THEN
+ SVA( q ) = DNRM2( M, A( 1, q ), 1 )*
+ + WORK( q )
+ ELSE
+ T = ZERO
+ AAQQ = ZERO
+ CALL DLASSQ( M, A( 1, q ), 1, T,
+ + AAQQ )
+ SVA( q ) = T*DSQRT( AAQQ )*WORK( q )
+ END IF
+ END IF
+ IF( ( AAPP / AAPP0 )**2.LE.ROOTEPS ) THEN
+ IF( ( AAPP.LT.ROOTBIG ) .AND.
+ + ( AAPP.GT.ROOTSFMIN ) ) THEN
+ AAPP = DNRM2( M, A( 1, p ), 1 )*
+ + WORK( p )
+ ELSE
+ T = ZERO
+ AAPP = ZERO
+ CALL DLASSQ( M, A( 1, p ), 1, T,
+ + AAPP )
+ AAPP = T*DSQRT( AAPP )*WORK( p )
+ END IF
+ SVA( p ) = AAPP
+ END IF
* end of OK rotation
- ELSE
- NOTROT = NOTROT + 1
+ ELSE
+ NOTROT = NOTROT + 1
*[RTD] SKIPPED = SKIPPED + 1
- PSKIPPED = PSKIPPED + 1
- IJBLSK = IJBLSK + 1
- END IF
- ELSE
- NOTROT = NOTROT + 1
- PSKIPPED = PSKIPPED + 1
- IJBLSK = IJBLSK + 1
- END IF
+ PSKIPPED = PSKIPPED + 1
+ IJBLSK = IJBLSK + 1
+ END IF
+ ELSE
+ NOTROT = NOTROT + 1
+ PSKIPPED = PSKIPPED + 1
+ IJBLSK = IJBLSK + 1
+ END IF
*
- IF ( ( i .LE. SWBAND ) .AND. ( IJBLSK .GE. BLSKIP ) ) THEN
- SVA(p) = AAPP
- NOTROT = 0
- GO TO 2011
- END IF
- IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN
- AAPP = -AAPP
- NOTROT = 0
- GO TO 2203
- END IF
+ IF( ( i.LE.SWBAND ) .AND. ( IJBLSK.GE.BLSKIP ) )
+ + THEN
+ SVA( p ) = AAPP
+ NOTROT = 0
+ GO TO 2011
+ END IF
+ IF( ( i.LE.SWBAND ) .AND.
+ + ( PSKIPPED.GT.ROWSKIP ) ) THEN
+ AAPP = -AAPP
+ NOTROT = 0
+ GO TO 2203
+ END IF
*
- 2200 CONTINUE
+ 2200 CONTINUE
* end of the q-loop
- 2203 CONTINUE
+ 2203 CONTINUE
*
- SVA(p) = AAPP
+ SVA( p ) = AAPP
*
- ELSE
+ ELSE
*
- IF ( AAPP .EQ. ZERO ) NOTROT=NOTROT+MIN0(jgl+KBL-1,N)-jgl+1
- IF ( AAPP .LT. ZERO ) NOTROT = 0
+ IF( AAPP.EQ.ZERO )NOTROT = NOTROT +
+ + MIN0( jgl+KBL-1, N ) - jgl + 1
+ IF( AAPP.LT.ZERO )NOTROT = 0
*
- END IF
+ END IF
*
- 2100 CONTINUE
+ 2100 CONTINUE
* end of the p-loop
- 2010 CONTINUE
+ 2010 CONTINUE
* end of the jbc-loop
- 2011 CONTINUE
+ 2011 CONTINUE
*2011 bailed out of the jbc-loop
- DO 2012 p = igl, MIN0( igl + KBL - 1, N )
- SVA(p) = DABS(SVA(p))
- 2012 CONTINUE
+ DO 2012 p = igl, MIN0( igl+KBL-1, N )
+ SVA( p ) = DABS( SVA( p ) )
+ 2012 CONTINUE
***
- 2000 CONTINUE
+ 2000 CONTINUE
*2000 :: end of the ibr-loop
*
* .. update SVA(N)
- IF ((SVA(N) .LT. ROOTBIG).AND.(SVA(N) .GT. ROOTSFMIN)) THEN
- SVA(N) = DNRM2( M, A(1,N), 1 ) * WORK(N)
- ELSE
- T = ZERO
- AAPP = ZERO
- CALL DLASSQ( M, A(1,N), 1, T, AAPP )
- SVA(N) = T * DSQRT(AAPP) * WORK(N)
- END IF
+ IF( ( SVA( N ).LT.ROOTBIG ) .AND. ( SVA( N ).GT.ROOTSFMIN ) )
+ + THEN
+ SVA( N ) = DNRM2( M, A( 1, N ), 1 )*WORK( N )
+ ELSE
+ T = ZERO
+ AAPP = ZERO
+ CALL DLASSQ( M, A( 1, N ), 1, T, AAPP )
+ SVA( N ) = T*DSQRT( AAPP )*WORK( N )
+ END IF
*
* Additional steering devices
*
- IF ( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR.
- & ( ISWROT .LE. N ) ) )
- & SWBAND = i
+ IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR.
+ + ( ISWROT.LE.N ) ) )SWBAND = i
*
- IF ( (i .GT. SWBAND+1) .AND. (MXAAPQ .LT. DSQRT(DBLE(N))*TOL)
- & .AND. (DBLE(N)*MXAAPQ*MXSINJ .LT. TOL) ) THEN
- GO TO 1994
- END IF
+ IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.DSQRT( DBLE( N ) )*
+ + TOL ) .AND. ( DBLE( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN
+ GO TO 1994
+ END IF
*
- IF ( NOTROT .GE. EMPTSW ) GO TO 1994
+ IF( NOTROT.GE.EMPTSW )GO TO 1994
*
1993 CONTINUE
* end i=1:NSWEEP loop
N2 = 0
N4 = 0
DO 5991 p = 1, N - 1
- q = IDAMAX( N-p+1, SVA(p), 1 ) + p - 1
- IF ( p .NE. q ) THEN
- TEMP1 = SVA(p)
- SVA(p) = SVA(q)
- SVA(q) = TEMP1
- TEMP1 = WORK(p)
- WORK(p) = WORK(q)
- WORK(q) = TEMP1
- CALL DSWAP( M, A(1,p), 1, A(1,q), 1 )
- IF ( RSVEC ) CALL DSWAP( MVL, V(1,p), 1, V(1,q), 1 )
+ q = IDAMAX( N-p+1, SVA( p ), 1 ) + p - 1
+ IF( p.NE.q ) THEN
+ TEMP1 = SVA( p )
+ SVA( p ) = SVA( q )
+ SVA( q ) = TEMP1
+ TEMP1 = WORK( p )
+ WORK( p ) = WORK( q )
+ WORK( q ) = TEMP1
+ CALL DSWAP( M, A( 1, p ), 1, A( 1, q ), 1 )
+ IF( RSVEC )CALL DSWAP( MVL, V( 1, p ), 1, V( 1, q ), 1 )
END IF
- IF ( SVA(p) .NE. ZERO ) THEN
+ IF( SVA( p ).NE.ZERO ) THEN
N4 = N4 + 1
- IF ( SVA(p)*SCALE .GT. SFMIN ) N2 = N2 + 1
+ IF( SVA( p )*SCALE.GT.SFMIN )N2 = N2 + 1
END IF
5991 CONTINUE
- IF ( SVA(N) .NE. ZERO ) THEN
+ IF( SVA( N ).NE.ZERO ) THEN
N4 = N4 + 1
- IF ( SVA(N)*SCALE .GT. SFMIN ) N2 = N2 + 1
+ IF( SVA( N )*SCALE.GT.SFMIN )N2 = N2 + 1
END IF
*
* Normalize the left singular vectors.
*
- IF ( LSVEC .OR. UCTOL ) THEN
+ IF( LSVEC .OR. UCTOL ) THEN
DO 1998 p = 1, N2
- CALL DSCAL( M, WORK(p) / SVA(p), A(1,p), 1 )
+ CALL DSCAL( M, WORK( p ) / SVA( p ), A( 1, p ), 1 )
1998 CONTINUE
END IF
*
* Scale the product of Jacobi rotations (assemble the fast rotations).
*
- IF ( RSVEC ) THEN
- IF ( APPLV ) THEN
+ IF( RSVEC ) THEN
+ IF( APPLV ) THEN
DO 2398 p = 1, N
- CALL DSCAL( MVL, WORK(p), V(1,p), 1 )
+ CALL DSCAL( MVL, WORK( p ), V( 1, p ), 1 )
2398 CONTINUE
ELSE
DO 2399 p = 1, N
- TEMP1 = ONE / DNRM2(MVL, V(1,p), 1 )
- CALL DSCAL( MVL, TEMP1, V(1,p), 1 )
+ TEMP1 = ONE / DNRM2( MVL, V( 1, p ), 1 )
+ CALL DSCAL( MVL, TEMP1, V( 1, p ), 1 )
2399 CONTINUE
END IF
END IF
*
* Undo scaling, if necessary (and possible).
- IF ( ((SCALE.GT.ONE).AND.(SVA(1).LT.(BIG/SCALE)))
- & .OR.((SCALE.LT.ONE).AND.(SVA(N2).GT.(SFMIN/SCALE))) ) THEN
+ IF( ( ( SCALE.GT.ONE ) .AND. ( SVA( 1 ).LT.( BIG /
+ + SCALE ) ) ) .OR. ( ( SCALE.LT.ONE ) .AND. ( SVA( N2 ).GT.
+ + ( SFMIN / SCALE ) ) ) ) THEN
DO 2400 p = 1, N
- SVA(p) = SCALE*SVA(p)
+ SVA( p ) = SCALE*SVA( p )
2400 CONTINUE
SCALE = ONE
END IF
*
- WORK(1) = SCALE
+ WORK( 1 ) = SCALE
* The singular values of A are SCALE*SVA(1:N). If SCALE.NE.ONE
* then some of the singular values may overflow or underflow and
* the spectrum is given in this factored representation.
*
- WORK(2) = DBLE(N4)
+ WORK( 2 ) = DBLE( N4 )
* N4 is the number of computed nonzero singular values of A.
*
- WORK(3) = DBLE(N2)
+ WORK( 3 ) = DBLE( N2 )
* N2 is the number of singular values of A greater than SFMIN.
* If N2<N, SVA(N2:N) contains ZEROS and/or denormalized numbers
* that may carry some information.
*
- WORK(4) = DBLE(i)
+ WORK( 4 ) = DBLE( i )
* i is the index of the last sweep before declaring convergence.
*
- WORK(5) = MXAAPQ
+ WORK( 5 ) = MXAAPQ
* MXAAPQ is the largest absolute value of scaled pivots in the
* last sweep
*
- WORK(6) = MXSINJ
+ WORK( 6 ) = MXSINJ
* MXSINJ is the largest absolute value of the sines of Jacobi angles
* in the last sweep
*
* .. END OF DGESVJ
* ..
END
-*
SUBROUTINE DGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS,
- & SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )
+ + SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.2) --
*
* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the
* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0.
*
-* Scalar Arguments
-*
- IMPLICIT NONE
- INTEGER INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP
- DOUBLE PRECISION EPS, SFMIN, TOL
- CHARACTER*1 JOBV
-*
-* Array Arguments
-*
- DOUBLE PRECISION A( LDA, * ), SVA( N ), D( N ), V( LDV, * ),
- & WORK( LWORK )
+ IMPLICIT NONE
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP
+ DOUBLE PRECISION EPS, SFMIN, TOL
+ CHARACTER*1 JOBV
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), SVA( N ), D( N ), V( LDV, * ),
+ + WORK( LWORK )
* ..
*
* Purpose
-* ~~~~~~~
+* =======
+*
* DGSVJ0 is called from DGESVJ as a pre-processor and that is its main
* purpose. It applies Jacobi rotations in the same way as DGESVJ does, but
* it does not check convergence (stopping criterion). Few tuning
* drmac@math.hr. Thank you.
*
* Arguments
-* ~~~~~~~~~
+* =========
*
* JOBV (input) CHARACTER*1
* Specifies whether the output from this procedure is used
* = 0 : successful exit.
* < 0 : if INFO = -i, then the i-th argument had an illegal value
*
-* Local Parameters
- DOUBLE PRECISION ZERO, HALF, ONE, TWO
- PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0 )
-
-* Local Scalars
- DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP,
- & BIG, BIGTHETA, CS, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS,
- & ROOTSFMIN, ROOTTOL, SMALL, SN, T, TEMP1, THETA,
- & THSIGN
- INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1, ISWROT,
- & jbc, jgl, KBL, LKAHEAD, MVL, NBL, NOTROT, p, PSKIPPED,
- & q, ROWSKIP, SWBAND
- LOGICAL APPLV, ROTOK, RSVEC
-
-* Local Arrays
-*
- DOUBLE PRECISION FASTR(5)
-*
-* Intrinsic Functions
-*
- INTRINSIC DABS, DMAX1, DBLE, MIN0, DSIGN, DSQRT
-*
-* External Functions
-*
- DOUBLE PRECISION DDOT, DNRM2
- INTEGER IDAMAX
- LOGICAL LSAME
- EXTERNAL IDAMAX, LSAME, DDOT, DNRM2
-*
-* External Subroutines
-*
- EXTERNAL DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP
+* =====================================================================
*
-* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|
+* .. Local Parameters ..
+ DOUBLE PRECISION ZERO, HALF, ONE, TWO
+ PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,
+ + TWO = 2.0D0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,
+ + BIGTHETA, CS, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS,
+ + ROOTSFMIN, ROOTTOL, SMALL, SN, T, TEMP1, THETA,
+ + THSIGN
+ INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,
+ + ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, NBL,
+ + NOTROT, p, PSKIPPED, q, ROWSKIP, SWBAND
+ LOGICAL APPLV, ROTOK, RSVEC
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION FASTR( 5 )
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DABS, DMAX1, DBLE, MIN0, DSIGN, DSQRT
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DDOT, DNRM2
+ INTEGER IDAMAX
+ LOGICAL LSAME
+ EXTERNAL IDAMAX, LSAME, DDOT, DNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP
+* ..
+* .. Executable Statements ..
*
- APPLV = LSAME(JOBV,'A')
- RSVEC = LSAME(JOBV,'V')
- IF ( .NOT.( RSVEC .OR. APPLV .OR. LSAME(JOBV,'N'))) THEN
+ APPLV = LSAME( JOBV, 'A' )
+ RSVEC = LSAME( JOBV, 'V' )
+ IF( .NOT.( RSVEC .OR. APPLV .OR. LSAME( JOBV, 'N' ) ) ) THEN
INFO = -1
- ELSE IF ( M .LT. 0 ) THEN
+ ELSE IF( M.LT.0 ) THEN
INFO = -2
- ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M )) THEN
+ ELSE IF( ( N.LT.0 ) .OR. ( N.GT.M ) ) THEN
INFO = -3
- ELSE IF ( LDA .LT. M ) THEN
+ ELSE IF( LDA.LT.M ) THEN
INFO = -5
- ELSE IF ( MV .LT. 0 ) THEN
+ ELSE IF( MV.LT.0 ) THEN
INFO = -8
- ELSE IF ( LDV .LT. M ) THEN
+ ELSE IF( LDV.LT.M ) THEN
INFO = -10
- ELSE IF ( TOL .LE. EPS ) THEN
+ ELSE IF( TOL.LE.EPS ) THEN
INFO = -13
- ELSE IF ( NSWEEP .LT. 0 ) THEN
+ ELSE IF( NSWEEP.LT.0 ) THEN
INFO = -14
- ELSE IF ( LWORK .LT. M ) THEN
+ ELSE IF( LWORK.LT.M ) THEN
INFO = -16
ELSE
INFO = 0
END IF
*
* #:(
- IF ( INFO .NE. 0 ) THEN
+ IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGSVJ0', -INFO )
RETURN
END IF
*
- IF ( RSVEC ) THEN
+ IF( RSVEC ) THEN
MVL = N
- ELSE IF ( APPLV ) THEN
+ ELSE IF( APPLV ) THEN
MVL = MV
END IF
RSVEC = RSVEC .OR. APPLV
- ROOTEPS = DSQRT(EPS)
- ROOTSFMIN = DSQRT(SFMIN)
- SMALL = SFMIN / EPS
- BIG = ONE / SFMIN
- ROOTBIG = ONE / ROOTSFMIN
- BIGTHETA = ONE / ROOTEPS
- ROOTTOL = DSQRT(TOL)
+ ROOTEPS = DSQRT( EPS )
+ ROOTSFMIN = DSQRT( SFMIN )
+ SMALL = SFMIN / EPS
+ BIG = ONE / SFMIN
+ ROOTBIG = ONE / ROOTSFMIN
+ BIGTHETA = ONE / ROOTEPS
+ ROOTTOL = DSQRT( TOL )
*
*
* -#- Row-cyclic Jacobi SVD algorithm with column pivoting -#-
*
- EMPTSW = ( N * ( N - 1 ) ) / 2
- NOTROT = 0
- FASTR(1) = ZERO
+ EMPTSW = ( N*( N-1 ) ) / 2
+ NOTROT = 0
+ FASTR( 1 ) = ZERO
*
* -#- Row-cyclic pivot strategy with de Rijk's pivoting -#-
*
* parameters of the computer's memory.
*
NBL = N / KBL
- IF ( ( NBL * KBL ) .NE. N ) NBL = NBL + 1
+ IF( ( NBL*KBL ).NE.N )NBL = NBL + 1
BLSKIP = ( KBL**2 ) + 1
*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL.
DO 1993 i = 1, NSWEEP
* .. go go go ...
*
- MXAAPQ = ZERO
- MXSINJ = ZERO
- ISWROT = 0
+ MXAAPQ = ZERO
+ MXSINJ = ZERO
+ ISWROT = 0
*
- NOTROT = 0
- PSKIPPED = 0
+ NOTROT = 0
+ PSKIPPED = 0
*
- DO 2000 ibr = 1, NBL
+ DO 2000 ibr = 1, NBL
- igl = ( ibr - 1 ) * KBL + 1
+ igl = ( ibr-1 )*KBL + 1
*
- DO 1002 ir1 = 0, MIN0( LKAHEAD, NBL - ibr )
+ DO 1002 ir1 = 0, MIN0( LKAHEAD, NBL-ibr )
*
- igl = igl + ir1 * KBL
+ igl = igl + ir1*KBL
*
- DO 2001 p = igl, MIN0( igl + KBL - 1, N - 1)
+ DO 2001 p = igl, MIN0( igl+KBL-1, N-1 )
* .. de Rijk's pivoting
- q = IDAMAX( N-p+1, SVA(p), 1 ) + p - 1
- IF ( p .NE. q ) THEN
- CALL DSWAP( M, A(1,p), 1, A(1,q), 1 )
- IF ( RSVEC ) CALL DSWAP( MVL, V(1,p), 1, V(1,q), 1 )
- TEMP1 = SVA(p)
- SVA(p) = SVA(q)
- SVA(q) = TEMP1
- TEMP1 = D(p)
- D(p) = D(q)
- D(q) = TEMP1
- END IF
-*
- IF ( ir1 .EQ. 0 ) THEN
+ q = IDAMAX( N-p+1, SVA( p ), 1 ) + p - 1
+ IF( p.NE.q ) THEN
+ CALL DSWAP( M, A( 1, p ), 1, A( 1, q ), 1 )
+ IF( RSVEC )CALL DSWAP( MVL, V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ TEMP1 = SVA( p )
+ SVA( p ) = SVA( q )
+ SVA( q ) = TEMP1
+ TEMP1 = D( p )
+ D( p ) = D( q )
+ D( q ) = TEMP1
+ END IF
+*
+ IF( ir1.EQ.0 ) THEN
*
* Column norms are periodically updated by explicit
* norm computation.
* If properly implemented DNRM2 is available, the IF-THEN-ELSE
* below should read "AAPP = DNRM2( M, A(1,p), 1 ) * D(p)".
*
- IF ((SVA(p) .LT. ROOTBIG) .AND. (SVA(p) .GT. ROOTSFMIN)) THEN
- SVA(p) = DNRM2( M, A(1,p), 1 ) * D(p)
- ELSE
- TEMP1 = ZERO
- AAPP = ZERO
- CALL DLASSQ( M, A(1,p), 1, TEMP1, AAPP )
- SVA(p) = TEMP1 * DSQRT(AAPP) * D(p)
- END IF
- AAPP = SVA(p)
- ELSE
- AAPP = SVA(p)
- END IF
+ IF( ( SVA( p ).LT.ROOTBIG ) .AND.
+ + ( SVA( p ).GT.ROOTSFMIN ) ) THEN
+ SVA( p ) = DNRM2( M, A( 1, p ), 1 )*D( p )
+ ELSE
+ TEMP1 = ZERO
+ AAPP = ZERO
+ CALL DLASSQ( M, A( 1, p ), 1, TEMP1, AAPP )
+ SVA( p ) = TEMP1*DSQRT( AAPP )*D( p )
+ END IF
+ AAPP = SVA( p )
+ ELSE
+ AAPP = SVA( p )
+ END IF
*
- IF ( AAPP .GT. ZERO ) THEN
+ IF( AAPP.GT.ZERO ) THEN
*
- PSKIPPED = 0
+ PSKIPPED = 0
*
- DO 2002 q = p + 1, MIN0( igl + KBL - 1, N )
+ DO 2002 q = p + 1, MIN0( igl+KBL-1, N )
*
- AAQQ = SVA(q)
+ AAQQ = SVA( q )
- IF ( AAQQ .GT. ZERO ) THEN
-*
- AAPP0 = AAPP
- IF ( AAQQ .GE. ONE ) THEN
- ROTOK = ( SMALL*AAPP ) .LE. AAQQ
- IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN
- AAPQ = ( DDOT(M, A(1,p), 1, A(1,q), 1 ) *
- & D(p) * D(q) / AAQQ ) / AAPP
- ELSE
- CALL DCOPY( M, A(1,p), 1, WORK, 1 )
- CALL DLASCL( 'G', 0, 0, AAPP, D(p), M,
- & 1, WORK, LDA, IERR )
- AAPQ = DDOT( M, WORK,1, A(1,q),1 )*D(q) / AAQQ
- END IF
- ELSE
- ROTOK = AAPP .LE. ( AAQQ / SMALL )
- IF ( AAPP .GT. ( SMALL / AAQQ ) ) THEN
- AAPQ = ( DDOT( M, A(1,p), 1, A(1,q), 1 ) *
- & D(p) * D(q) / AAQQ ) / AAPP
- ELSE
- CALL DCOPY( M, A(1,q), 1, WORK, 1 )
- CALL DLASCL( 'G', 0, 0, AAQQ, D(q), M,
- & 1, WORK, LDA, IERR )
- AAPQ = DDOT( M, WORK,1, A(1,p),1 )*D(p) / AAPP
- END IF
- END IF
+ IF( AAQQ.GT.ZERO ) THEN
+*
+ AAPP0 = AAPP
+ IF( AAQQ.GE.ONE ) THEN
+ ROTOK = ( SMALL*AAPP ).LE.AAQQ
+ IF( AAPP.LT.( BIG / AAQQ ) ) THEN
+ AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1,
+ + q ), 1 )*D( p )*D( q ) / AAQQ )
+ + / AAPP
+ ELSE
+ CALL DCOPY( M, A( 1, p ), 1, WORK, 1 )
+ CALL DLASCL( 'G', 0, 0, AAPP, D( p ),
+ + M, 1, WORK, LDA, IERR )
+ AAPQ = DDOT( M, WORK, 1, A( 1, q ),
+ + 1 )*D( q ) / AAQQ
+ END IF
+ ELSE
+ ROTOK = AAPP.LE.( AAQQ / SMALL )
+ IF( AAPP.GT.( SMALL / AAQQ ) ) THEN
+ AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1,
+ + q ), 1 )*D( p )*D( q ) / AAQQ )
+ + / AAPP
+ ELSE
+ CALL DCOPY( M, A( 1, q ), 1, WORK, 1 )
+ CALL DLASCL( 'G', 0, 0, AAQQ, D( q ),
+ + M, 1, WORK, LDA, IERR )
+ AAPQ = DDOT( M, WORK, 1, A( 1, p ),
+ + 1 )*D( p ) / AAPP
+ END IF
+ END IF
*
- MXAAPQ = DMAX1( MXAAPQ, DABS(AAPQ) )
+ MXAAPQ = DMAX1( MXAAPQ, DABS( AAPQ ) )
*
* TO rotate or NOT to rotate, THAT is the question ...
*
- IF ( DABS( AAPQ ) .GT. TOL ) THEN
+ IF( DABS( AAPQ ).GT.TOL ) THEN
*
* .. rotate
* ROTATED = ROTATED + ONE
*
- IF ( ir1 .EQ. 0 ) THEN
- NOTROT = 0
- PSKIPPED = 0
- ISWROT = ISWROT + 1
- END IF
-*
- IF ( ROTOK ) THEN
-*
- AQOAP = AAQQ / AAPP
- APOAQ = AAPP / AAQQ
- THETA = - HALF * DABS( AQOAP - APOAQ ) / AAPQ
-*
- IF ( DABS( THETA ) .GT. BIGTHETA ) THEN
-*
- T = HALF / THETA
- FASTR(3) = T * D(p) / D(q)
- FASTR(4) = - T * D(q) / D(p)
- CALL DROTM( M, A(1,p), 1, A(1,q), 1, FASTR )
- IF ( RSVEC )
- & CALL DROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR )
- SVA(q) = AAQQ*DSQRT( DMAX1(ZERO,ONE + T*APOAQ*AAPQ) )
- AAPP = AAPP*DSQRT( ONE - T*AQOAP*AAPQ )
- MXSINJ = DMAX1( MXSINJ, DABS(T) )
-*
- ELSE
+ IF( ir1.EQ.0 ) THEN
+ NOTROT = 0
+ PSKIPPED = 0
+ ISWROT = ISWROT + 1
+ END IF
+*
+ IF( ROTOK ) THEN
+*
+ AQOAP = AAQQ / AAPP
+ APOAQ = AAPP / AAQQ
+ THETA = -HALF*DABS( AQOAP-APOAQ ) /
+ + AAPQ
+*
+ IF( DABS( THETA ).GT.BIGTHETA ) THEN
+*
+ T = HALF / THETA
+ FASTR( 3 ) = T*D( p ) / D( q )
+ FASTR( 4 ) = -T*D( q ) / D( p )
+ CALL DROTM( M, A( 1, p ), 1,
+ + A( 1, q ), 1, FASTR )
+ IF( RSVEC )CALL DROTM( MVL,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1,
+ + FASTR )
+ SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
+ + ONE+T*APOAQ*AAPQ ) )
+ AAPP = AAPP*DSQRT( ONE-T*AQOAP*
+ + AAPQ )
+ MXSINJ = DMAX1( MXSINJ, DABS( T ) )
+*
+ ELSE
*
* .. choose correct signum for THETA and rotate
*
- THSIGN = - DSIGN(ONE,AAPQ)
- T = ONE / ( THETA + THSIGN*DSQRT(ONE+THETA*THETA) )
- CS = DSQRT( ONE / ( ONE + T*T ) )
- SN = T * CS
-*
- MXSINJ = DMAX1( MXSINJ, DABS(SN) )
- SVA(q) = AAQQ*DSQRT( DMAX1(ZERO, ONE+T*APOAQ*AAPQ) )
- AAPP = AAPP*DSQRT( DMAX1(ZERO, ONE-T*AQOAP*AAPQ) )
-*
- APOAQ = D(p) / D(q)
- AQOAP = D(q) / D(p)
- IF ( D(p) .GE. ONE ) THEN
- IF ( D(q) .GE. ONE ) THEN
- FASTR(3) = T * APOAQ
- FASTR(4) = - T * AQOAP
- D(p) = D(p) * CS
- D(q) = D(q) * CS
- CALL DROTM( M, A(1,p),1, A(1,q),1, FASTR )
- IF ( RSVEC )
- & CALL DROTM( MVL, V(1,p),1, V(1,q),1, FASTR )
- ELSE
- CALL DAXPY( M, -T*AQOAP, A(1,q),1, A(1,p),1 )
- CALL DAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 )
- D(p) = D(p) * CS
- D(q) = D(q) / CS
- IF ( RSVEC ) THEN
- CALL DAXPY(MVL, -T*AQOAP, V(1,q),1,V(1,p),1)
- CALL DAXPY(MVL,CS*SN*APOAQ, V(1,p),1,V(1,q),1)
- END IF
- END IF
- ELSE
- IF ( D(q) .GE. ONE ) THEN
- CALL DAXPY( M, T*APOAQ, A(1,p),1, A(1,q),1 )
- CALL DAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 )
- D(p) = D(p) / CS
- D(q) = D(q) * CS
- IF ( RSVEC ) THEN
- CALL DAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1)
- CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1)
- END IF
- ELSE
- IF ( D(p) .GE. D(q) ) THEN
- CALL DAXPY( M,-T*AQOAP, A(1,q),1,A(1,p),1 )
- CALL DAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 )
- D(p) = D(p) * CS
- D(q) = D(q) / CS
- IF ( RSVEC ) THEN
- CALL DAXPY(MVL, -T*AQOAP, V(1,q),1,V(1,p),1)
- CALL DAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1)
- END IF
- ELSE
- CALL DAXPY( M, T*APOAQ, A(1,p),1,A(1,q),1)
- CALL DAXPY( M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1)
- D(p) = D(p) / CS
- D(q) = D(q) * CS
- IF ( RSVEC ) THEN
- CALL DAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1)
- CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1)
- END IF
- END IF
- END IF
- ENDIF
- END IF
-*
- ELSE
+ THSIGN = -DSIGN( ONE, AAPQ )
+ T = ONE / ( THETA+THSIGN*
+ + DSQRT( ONE+THETA*THETA ) )
+ CS = DSQRT( ONE / ( ONE+T*T ) )
+ SN = T*CS
+*
+ MXSINJ = DMAX1( MXSINJ, DABS( SN ) )
+ SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
+ + ONE+T*APOAQ*AAPQ ) )
+ AAPP = AAPP*DSQRT( DMAX1( ZERO,
+ + ONE-T*AQOAP*AAPQ ) )
+*
+ APOAQ = D( p ) / D( q )
+ AQOAP = D( q ) / D( p )
+ IF( D( p ).GE.ONE ) THEN
+ IF( D( q ).GE.ONE ) THEN
+ FASTR( 3 ) = T*APOAQ
+ FASTR( 4 ) = -T*AQOAP
+ D( p ) = D( p )*CS
+ D( q ) = D( q )*CS
+ CALL DROTM( M, A( 1, p ), 1,
+ + A( 1, q ), 1,
+ + FASTR )
+ IF( RSVEC )CALL DROTM( MVL,
+ + V( 1, p ), 1, V( 1, q ),
+ + 1, FASTR )
+ ELSE
+ CALL DAXPY( M, -T*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ CALL DAXPY( M, CS*SN*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ D( p ) = D( p )*CS
+ D( q ) = D( q ) / CS
+ IF( RSVEC ) THEN
+ CALL DAXPY( MVL, -T*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ CALL DAXPY( MVL,
+ + CS*SN*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ END IF
+ END IF
+ ELSE
+ IF( D( q ).GE.ONE ) THEN
+ CALL DAXPY( M, T*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ CALL DAXPY( M, -CS*SN*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ D( p ) = D( p ) / CS
+ D( q ) = D( q )*CS
+ IF( RSVEC ) THEN
+ CALL DAXPY( MVL, T*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ CALL DAXPY( MVL,
+ + -CS*SN*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ END IF
+ ELSE
+ IF( D( p ).GE.D( q ) ) THEN
+ CALL DAXPY( M, -T*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ CALL DAXPY( M, CS*SN*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ D( p ) = D( p )*CS
+ D( q ) = D( q ) / CS
+ IF( RSVEC ) THEN
+ CALL DAXPY( MVL,
+ + -T*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ CALL DAXPY( MVL,
+ + CS*SN*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ END IF
+ ELSE
+ CALL DAXPY( M, T*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ CALL DAXPY( M,
+ + -CS*SN*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ D( p ) = D( p ) / CS
+ D( q ) = D( q )*CS
+ IF( RSVEC ) THEN
+ CALL DAXPY( MVL,
+ + T*APOAQ, V( 1, p ),
+ + 1, V( 1, q ), 1 )
+ CALL DAXPY( MVL,
+ + -CS*SN*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ END IF
+ END IF
+ END IF
+ END IF
+ END IF
+*
+ ELSE
* .. have to use modified Gram-Schmidt like transformation
- CALL DCOPY( M, A(1,p), 1, WORK, 1 )
- CALL DLASCL( 'G',0,0,AAPP,ONE,M,1,WORK,LDA,IERR )
- CALL DLASCL( 'G',0,0,AAQQ,ONE,M,1, A(1,q),LDA,IERR )
- TEMP1 = -AAPQ * D(p) / D(q)
- CALL DAXPY ( M, TEMP1, WORK, 1, A(1,q), 1 )
- CALL DLASCL( 'G',0,0,ONE,AAQQ,M,1, A(1,q),LDA,IERR )
- SVA(q) = AAQQ*DSQRT( DMAX1( ZERO, ONE - AAPQ*AAPQ ) )
- MXSINJ = DMAX1( MXSINJ, SFMIN )
- END IF
+ CALL DCOPY( M, A( 1, p ), 1, WORK, 1 )
+ CALL DLASCL( 'G', 0, 0, AAPP, ONE, M,
+ + 1, WORK, LDA, IERR )
+ CALL DLASCL( 'G', 0, 0, AAQQ, ONE, M,
+ + 1, A( 1, q ), LDA, IERR )
+ TEMP1 = -AAPQ*D( p ) / D( q )
+ CALL DAXPY( M, TEMP1, WORK, 1,
+ + A( 1, q ), 1 )
+ CALL DLASCL( 'G', 0, 0, ONE, AAQQ, M,
+ + 1, A( 1, q ), LDA, IERR )
+ SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
+ + ONE-AAPQ*AAPQ ) )
+ MXSINJ = DMAX1( MXSINJ, SFMIN )
+ END IF
* END IF ROTOK THEN ... ELSE
*
* In the case of cancellation in updating SVA(q), SVA(p)
* recompute SVA(q), SVA(p).
- IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS ) THEN
- IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN
- SVA(q) = DNRM2( M, A(1,q), 1 ) * D(q)
- ELSE
- T = ZERO
- AAQQ = ZERO
- CALL DLASSQ( M, A(1,q), 1, T, AAQQ )
- SVA(q) = T * DSQRT(AAQQ) * D(q)
- END IF
- END IF
- IF ( ( AAPP / AAPP0) .LE. ROOTEPS ) THEN
- IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN
- AAPP = DNRM2( M, A(1,p), 1 ) * D(p)
- ELSE
- T = ZERO
- AAPP = ZERO
- CALL DLASSQ( M, A(1,p), 1, T, AAPP )
- AAPP = T * DSQRT(AAPP) * D(p)
- END IF
- SVA(p) = AAPP
- END IF
-*
- ELSE
+ IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS )
+ + THEN
+ IF( ( AAQQ.LT.ROOTBIG ) .AND.
+ + ( AAQQ.GT.ROOTSFMIN ) ) THEN
+ SVA( q ) = DNRM2( M, A( 1, q ), 1 )*
+ + D( q )
+ ELSE
+ T = ZERO
+ AAQQ = ZERO
+ CALL DLASSQ( M, A( 1, q ), 1, T,
+ + AAQQ )
+ SVA( q ) = T*DSQRT( AAQQ )*D( q )
+ END IF
+ END IF
+ IF( ( AAPP / AAPP0 ).LE.ROOTEPS ) THEN
+ IF( ( AAPP.LT.ROOTBIG ) .AND.
+ + ( AAPP.GT.ROOTSFMIN ) ) THEN
+ AAPP = DNRM2( M, A( 1, p ), 1 )*
+ + D( p )
+ ELSE
+ T = ZERO
+ AAPP = ZERO
+ CALL DLASSQ( M, A( 1, p ), 1, T,
+ + AAPP )
+ AAPP = T*DSQRT( AAPP )*D( p )
+ END IF
+ SVA( p ) = AAPP
+ END IF
+*
+ ELSE
* A(:,p) and A(:,q) already numerically orthogonal
- IF ( ir1 .EQ. 0 ) NOTROT = NOTROT + 1
- PSKIPPED = PSKIPPED + 1
- END IF
- ELSE
+ IF( ir1.EQ.0 )NOTROT = NOTROT + 1
+ PSKIPPED = PSKIPPED + 1
+ END IF
+ ELSE
* A(:,q) is zero column
- IF ( ir1. EQ. 0 ) NOTROT = NOTROT + 1
- PSKIPPED = PSKIPPED + 1
- END IF
+ IF( ir1.EQ.0 )NOTROT = NOTROT + 1
+ PSKIPPED = PSKIPPED + 1
+ END IF
*
- IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN
- IF ( ir1 .EQ. 0 ) AAPP = - AAPP
- NOTROT = 0
- GO TO 2103
- END IF
+ IF( ( i.LE.SWBAND ) .AND.
+ + ( PSKIPPED.GT.ROWSKIP ) ) THEN
+ IF( ir1.EQ.0 )AAPP = -AAPP
+ NOTROT = 0
+ GO TO 2103
+ END IF
*
- 2002 CONTINUE
+ 2002 CONTINUE
* END q-LOOP
*
- 2103 CONTINUE
+ 2103 CONTINUE
* bailed out of q-loop
- SVA(p) = AAPP
+ SVA( p ) = AAPP
- ELSE
- SVA(p) = AAPP
- IF ( ( ir1 .EQ. 0 ) .AND. (AAPP .EQ. ZERO) )
- & NOTROT=NOTROT+MIN0(igl+KBL-1,N)-p
- END IF
+ ELSE
+ SVA( p ) = AAPP
+ IF( ( ir1.EQ.0 ) .AND. ( AAPP.EQ.ZERO ) )
+ + NOTROT = NOTROT + MIN0( igl+KBL-1, N ) - p
+ END IF
*
- 2001 CONTINUE
+ 2001 CONTINUE
* end of the p-loop
* end of doing the block ( ibr, ibr )
- 1002 CONTINUE
+ 1002 CONTINUE
* end of ir1-loop
*
*........................................................
* ... go to the off diagonal blocks
*
- igl = ( ibr - 1 ) * KBL + 1
+ igl = ( ibr-1 )*KBL + 1
*
- DO 2010 jbc = ibr + 1, NBL
+ DO 2010 jbc = ibr + 1, NBL
*
- jgl = ( jbc - 1 ) * KBL + 1
+ jgl = ( jbc-1 )*KBL + 1
*
* doing the block at ( ibr, jbc )
*
- IJBLSK = 0
- DO 2100 p = igl, MIN0( igl + KBL - 1, N )
+ IJBLSK = 0
+ DO 2100 p = igl, MIN0( igl+KBL-1, N )
*
- AAPP = SVA(p)
+ AAPP = SVA( p )
*
- IF ( AAPP .GT. ZERO ) THEN
+ IF( AAPP.GT.ZERO ) THEN
*
- PSKIPPED = 0
+ PSKIPPED = 0
*
- DO 2200 q = jgl, MIN0( jgl + KBL - 1, N )
+ DO 2200 q = jgl, MIN0( jgl+KBL-1, N )
*
- AAQQ = SVA(q)
+ AAQQ = SVA( q )
*
- IF ( AAQQ .GT. ZERO ) THEN
- AAPP0 = AAPP
+ IF( AAQQ.GT.ZERO ) THEN
+ AAPP0 = AAPP
*
* -#- M x 2 Jacobi SVD -#-
*
* -#- Safe Gram matrix computation -#-
*
- IF ( AAQQ .GE. ONE ) THEN
- IF ( AAPP .GE. AAQQ ) THEN
- ROTOK = ( SMALL*AAPP ) .LE. AAQQ
- ELSE
- ROTOK = ( SMALL*AAQQ ) .LE. AAPP
- END IF
- IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN
- AAPQ = ( DDOT(M, A(1,p), 1, A(1,q), 1 ) *
- & D(p) * D(q) / AAQQ ) / AAPP
- ELSE
- CALL DCOPY( M, A(1,p), 1, WORK, 1 )
- CALL DLASCL( 'G', 0, 0, AAPP, D(p), M,
- & 1, WORK, LDA, IERR )
- AAPQ = DDOT( M, WORK, 1, A(1,q), 1 ) *
- & D(q) / AAQQ
- END IF
- ELSE
- IF ( AAPP .GE. AAQQ ) THEN
- ROTOK = AAPP .LE. ( AAQQ / SMALL )
- ELSE
- ROTOK = AAQQ .LE. ( AAPP / SMALL )
- END IF
- IF ( AAPP .GT. ( SMALL / AAQQ ) ) THEN
- AAPQ = ( DDOT( M, A(1,p), 1, A(1,q), 1 ) *
- & D(p) * D(q) / AAQQ ) / AAPP
- ELSE
- CALL DCOPY( M, A(1,q), 1, WORK, 1 )
- CALL DLASCL( 'G', 0, 0, AAQQ, D(q), M, 1,
- & WORK, LDA, IERR )
- AAPQ = DDOT(M,WORK,1,A(1,p),1) * D(p) / AAPP
- END IF
- END IF
+ IF( AAQQ.GE.ONE ) THEN
+ IF( AAPP.GE.AAQQ ) THEN
+ ROTOK = ( SMALL*AAPP ).LE.AAQQ
+ ELSE
+ ROTOK = ( SMALL*AAQQ ).LE.AAPP
+ END IF
+ IF( AAPP.LT.( BIG / AAQQ ) ) THEN
+ AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1,
+ + q ), 1 )*D( p )*D( q ) / AAQQ )
+ + / AAPP
+ ELSE
+ CALL DCOPY( M, A( 1, p ), 1, WORK, 1 )
+ CALL DLASCL( 'G', 0, 0, AAPP, D( p ),
+ + M, 1, WORK, LDA, IERR )
+ AAPQ = DDOT( M, WORK, 1, A( 1, q ),
+ + 1 )*D( q ) / AAQQ
+ END IF
+ ELSE
+ IF( AAPP.GE.AAQQ ) THEN
+ ROTOK = AAPP.LE.( AAQQ / SMALL )
+ ELSE
+ ROTOK = AAQQ.LE.( AAPP / SMALL )
+ END IF
+ IF( AAPP.GT.( SMALL / AAQQ ) ) THEN
+ AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1,
+ + q ), 1 )*D( p )*D( q ) / AAQQ )
+ + / AAPP
+ ELSE
+ CALL DCOPY( M, A( 1, q ), 1, WORK, 1 )
+ CALL DLASCL( 'G', 0, 0, AAQQ, D( q ),
+ + M, 1, WORK, LDA, IERR )
+ AAPQ = DDOT( M, WORK, 1, A( 1, p ),
+ + 1 )*D( p ) / AAPP
+ END IF
+ END IF
*
- MXAAPQ = DMAX1( MXAAPQ, DABS(AAPQ) )
+ MXAAPQ = DMAX1( MXAAPQ, DABS( AAPQ ) )
*
* TO rotate or NOT to rotate, THAT is the question ...
*
- IF ( DABS( AAPQ ) .GT. TOL ) THEN
- NOTROT = 0
+ IF( DABS( AAPQ ).GT.TOL ) THEN
+ NOTROT = 0
* ROTATED = ROTATED + 1
- PSKIPPED = 0
- ISWROT = ISWROT + 1
-*
- IF ( ROTOK ) THEN
-*
- AQOAP = AAQQ / AAPP
- APOAQ = AAPP / AAQQ
- THETA = - HALF * DABS( AQOAP - APOAQ ) / AAPQ
- IF ( AAQQ .GT. AAPP0 ) THETA = - THETA
-*
- IF ( DABS( THETA ) .GT. BIGTHETA ) THEN
- T = HALF / THETA
- FASTR(3) = T * D(p) / D(q)
- FASTR(4) = -T * D(q) / D(p)
- CALL DROTM( M, A(1,p), 1, A(1,q), 1, FASTR )
- IF ( RSVEC )
- & CALL DROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR )
- SVA(q) = AAQQ*DSQRT( DMAX1(ZERO,ONE + T*APOAQ*AAPQ) )
- AAPP = AAPP*DSQRT( DMAX1(ZERO,ONE - T*AQOAP*AAPQ) )
- MXSINJ = DMAX1( MXSINJ, DABS(T) )
- ELSE
+ PSKIPPED = 0
+ ISWROT = ISWROT + 1
+*
+ IF( ROTOK ) THEN
+*
+ AQOAP = AAQQ / AAPP
+ APOAQ = AAPP / AAQQ
+ THETA = -HALF*DABS( AQOAP-APOAQ ) /
+ + AAPQ
+ IF( AAQQ.GT.AAPP0 )THETA = -THETA
+*
+ IF( DABS( THETA ).GT.BIGTHETA ) THEN
+ T = HALF / THETA
+ FASTR( 3 ) = T*D( p ) / D( q )
+ FASTR( 4 ) = -T*D( q ) / D( p )
+ CALL DROTM( M, A( 1, p ), 1,
+ + A( 1, q ), 1, FASTR )
+ IF( RSVEC )CALL DROTM( MVL,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1,
+ + FASTR )
+ SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
+ + ONE+T*APOAQ*AAPQ ) )
+ AAPP = AAPP*DSQRT( DMAX1( ZERO,
+ + ONE-T*AQOAP*AAPQ ) )
+ MXSINJ = DMAX1( MXSINJ, DABS( T ) )
+ ELSE
*
* .. choose correct signum for THETA and rotate
*
- THSIGN = - DSIGN(ONE,AAPQ)
- IF ( AAQQ .GT. AAPP0 ) THSIGN = - THSIGN
- T = ONE / ( THETA + THSIGN*DSQRT(ONE+THETA*THETA) )
- CS = DSQRT( ONE / ( ONE + T*T ) )
- SN = T * CS
- MXSINJ = DMAX1( MXSINJ, DABS(SN) )
- SVA(q) = AAQQ*DSQRT( DMAX1(ZERO, ONE+T*APOAQ*AAPQ) )
- AAPP = AAPP*DSQRT( ONE - T*AQOAP*AAPQ)
-*
- APOAQ = D(p) / D(q)
- AQOAP = D(q) / D(p)
- IF ( D(p) .GE. ONE ) THEN
-*
- IF ( D(q) .GE. ONE ) THEN
- FASTR(3) = T * APOAQ
- FASTR(4) = - T * AQOAP
- D(p) = D(p) * CS
- D(q) = D(q) * CS
- CALL DROTM( M, A(1,p),1, A(1,q),1, FASTR )
- IF ( RSVEC )
- & CALL DROTM( MVL, V(1,p),1, V(1,q),1, FASTR )
- ELSE
- CALL DAXPY( M, -T*AQOAP, A(1,q),1, A(1,p),1 )
- CALL DAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 )
- IF ( RSVEC ) THEN
- CALL DAXPY( MVL, -T*AQOAP, V(1,q),1, V(1,p),1 )
- CALL DAXPY( MVL,CS*SN*APOAQ,V(1,p),1, V(1,q),1 )
- END IF
- D(p) = D(p) * CS
- D(q) = D(q) / CS
- END IF
- ELSE
- IF ( D(q) .GE. ONE ) THEN
- CALL DAXPY( M, T*APOAQ, A(1,p),1, A(1,q),1 )
- CALL DAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 )
- IF ( RSVEC ) THEN
- CALL DAXPY(MVL,T*APOAQ, V(1,p),1, V(1,q),1 )
- CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1, V(1,p),1 )
- END IF
- D(p) = D(p) / CS
- D(q) = D(q) * CS
- ELSE
- IF ( D(p) .GE. D(q) ) THEN
- CALL DAXPY( M,-T*AQOAP, A(1,q),1,A(1,p),1 )
- CALL DAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 )
- D(p) = D(p) * CS
- D(q) = D(q) / CS
- IF ( RSVEC ) THEN
- CALL DAXPY( MVL, -T*AQOAP, V(1,q),1,V(1,p),1)
- CALL DAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1)
- END IF
- ELSE
- CALL DAXPY(M, T*APOAQ, A(1,p),1,A(1,q),1)
- CALL DAXPY(M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1)
- D(p) = D(p) / CS
- D(q) = D(q) * CS
- IF ( RSVEC ) THEN
- CALL DAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1)
- CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1)
- END IF
- END IF
- END IF
- ENDIF
- END IF
-*
- ELSE
- IF ( AAPP .GT. AAQQ ) THEN
- CALL DCOPY( M, A(1,p), 1, WORK, 1 )
- CALL DLASCL('G',0,0,AAPP,ONE,M,1,WORK,LDA,IERR)
- CALL DLASCL('G',0,0,AAQQ,ONE,M,1, A(1,q),LDA,IERR)
- TEMP1 = -AAPQ * D(p) / D(q)
- CALL DAXPY(M,TEMP1,WORK,1,A(1,q),1)
- CALL DLASCL('G',0,0,ONE,AAQQ,M,1,A(1,q),LDA,IERR)
- SVA(q) = AAQQ*DSQRT(DMAX1(ZERO, ONE - AAPQ*AAPQ))
- MXSINJ = DMAX1( MXSINJ, SFMIN )
- ELSE
- CALL DCOPY( M, A(1,q), 1, WORK, 1 )
- CALL DLASCL('G',0,0,AAQQ,ONE,M,1,WORK,LDA,IERR)
- CALL DLASCL('G',0,0,AAPP,ONE,M,1, A(1,p),LDA,IERR)
- TEMP1 = -AAPQ * D(q) / D(p)
- CALL DAXPY(M,TEMP1,WORK,1,A(1,p),1)
- CALL DLASCL('G',0,0,ONE,AAPP,M,1,A(1,p),LDA,IERR)
- SVA(p) = AAPP*DSQRT(DMAX1(ZERO, ONE - AAPQ*AAPQ))
- MXSINJ = DMAX1( MXSINJ, SFMIN )
- END IF
- END IF
+ THSIGN = -DSIGN( ONE, AAPQ )
+ IF( AAQQ.GT.AAPP0 )THSIGN = -THSIGN
+ T = ONE / ( THETA+THSIGN*
+ + DSQRT( ONE+THETA*THETA ) )
+ CS = DSQRT( ONE / ( ONE+T*T ) )
+ SN = T*CS
+ MXSINJ = DMAX1( MXSINJ, DABS( SN ) )
+ SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
+ + ONE+T*APOAQ*AAPQ ) )
+ AAPP = AAPP*DSQRT( ONE-T*AQOAP*
+ + AAPQ )
+*
+ APOAQ = D( p ) / D( q )
+ AQOAP = D( q ) / D( p )
+ IF( D( p ).GE.ONE ) THEN
+*
+ IF( D( q ).GE.ONE ) THEN
+ FASTR( 3 ) = T*APOAQ
+ FASTR( 4 ) = -T*AQOAP
+ D( p ) = D( p )*CS
+ D( q ) = D( q )*CS
+ CALL DROTM( M, A( 1, p ), 1,
+ + A( 1, q ), 1,
+ + FASTR )
+ IF( RSVEC )CALL DROTM( MVL,
+ + V( 1, p ), 1, V( 1, q ),
+ + 1, FASTR )
+ ELSE
+ CALL DAXPY( M, -T*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ CALL DAXPY( M, CS*SN*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ IF( RSVEC ) THEN
+ CALL DAXPY( MVL, -T*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ CALL DAXPY( MVL,
+ + CS*SN*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ END IF
+ D( p ) = D( p )*CS
+ D( q ) = D( q ) / CS
+ END IF
+ ELSE
+ IF( D( q ).GE.ONE ) THEN
+ CALL DAXPY( M, T*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ CALL DAXPY( M, -CS*SN*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ IF( RSVEC ) THEN
+ CALL DAXPY( MVL, T*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ CALL DAXPY( MVL,
+ + -CS*SN*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ END IF
+ D( p ) = D( p ) / CS
+ D( q ) = D( q )*CS
+ ELSE
+ IF( D( p ).GE.D( q ) ) THEN
+ CALL DAXPY( M, -T*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ CALL DAXPY( M, CS*SN*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ D( p ) = D( p )*CS
+ D( q ) = D( q ) / CS
+ IF( RSVEC ) THEN
+ CALL DAXPY( MVL,
+ + -T*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ CALL DAXPY( MVL,
+ + CS*SN*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ END IF
+ ELSE
+ CALL DAXPY( M, T*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ CALL DAXPY( M,
+ + -CS*SN*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ D( p ) = D( p ) / CS
+ D( q ) = D( q )*CS
+ IF( RSVEC ) THEN
+ CALL DAXPY( MVL,
+ + T*APOAQ, V( 1, p ),
+ + 1, V( 1, q ), 1 )
+ CALL DAXPY( MVL,
+ + -CS*SN*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ END IF
+ END IF
+ END IF
+ END IF
+ END IF
+*
+ ELSE
+ IF( AAPP.GT.AAQQ ) THEN
+ CALL DCOPY( M, A( 1, p ), 1, WORK,
+ + 1 )
+ CALL DLASCL( 'G', 0, 0, AAPP, ONE,
+ + M, 1, WORK, LDA, IERR )
+ CALL DLASCL( 'G', 0, 0, AAQQ, ONE,
+ + M, 1, A( 1, q ), LDA,
+ + IERR )
+ TEMP1 = -AAPQ*D( p ) / D( q )
+ CALL DAXPY( M, TEMP1, WORK, 1,
+ + A( 1, q ), 1 )
+ CALL DLASCL( 'G', 0, 0, ONE, AAQQ,
+ + M, 1, A( 1, q ), LDA,
+ + IERR )
+ SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
+ + ONE-AAPQ*AAPQ ) )
+ MXSINJ = DMAX1( MXSINJ, SFMIN )
+ ELSE
+ CALL DCOPY( M, A( 1, q ), 1, WORK,
+ + 1 )
+ CALL DLASCL( 'G', 0, 0, AAQQ, ONE,
+ + M, 1, WORK, LDA, IERR )
+ CALL DLASCL( 'G', 0, 0, AAPP, ONE,
+ + M, 1, A( 1, p ), LDA,
+ + IERR )
+ TEMP1 = -AAPQ*D( q ) / D( p )
+ CALL DAXPY( M, TEMP1, WORK, 1,
+ + A( 1, p ), 1 )
+ CALL DLASCL( 'G', 0, 0, ONE, AAPP,
+ + M, 1, A( 1, p ), LDA,
+ + IERR )
+ SVA( p ) = AAPP*DSQRT( DMAX1( ZERO,
+ + ONE-AAPQ*AAPQ ) )
+ MXSINJ = DMAX1( MXSINJ, SFMIN )
+ END IF
+ END IF
* END IF ROTOK THEN ... ELSE
*
* In the case of cancellation in updating SVA(q)
* .. recompute SVA(q)
- IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS ) THEN
- IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN
- SVA(q) = DNRM2( M, A(1,q), 1 ) * D(q)
- ELSE
- T = ZERO
- AAQQ = ZERO
- CALL DLASSQ( M, A(1,q), 1, T, AAQQ )
- SVA(q) = T * DSQRT(AAQQ) * D(q)
- END IF
- END IF
- IF ( (AAPP / AAPP0 )**2 .LE. ROOTEPS ) THEN
- IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN
- AAPP = DNRM2( M, A(1,p), 1 ) * D(p)
- ELSE
- T = ZERO
- AAPP = ZERO
- CALL DLASSQ( M, A(1,p), 1, T, AAPP )
- AAPP = T * DSQRT(AAPP) * D(p)
- END IF
- SVA(p) = AAPP
- END IF
+ IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS )
+ + THEN
+ IF( ( AAQQ.LT.ROOTBIG ) .AND.
+ + ( AAQQ.GT.ROOTSFMIN ) ) THEN
+ SVA( q ) = DNRM2( M, A( 1, q ), 1 )*
+ + D( q )
+ ELSE
+ T = ZERO
+ AAQQ = ZERO
+ CALL DLASSQ( M, A( 1, q ), 1, T,
+ + AAQQ )
+ SVA( q ) = T*DSQRT( AAQQ )*D( q )
+ END IF
+ END IF
+ IF( ( AAPP / AAPP0 )**2.LE.ROOTEPS ) THEN
+ IF( ( AAPP.LT.ROOTBIG ) .AND.
+ + ( AAPP.GT.ROOTSFMIN ) ) THEN
+ AAPP = DNRM2( M, A( 1, p ), 1 )*
+ + D( p )
+ ELSE
+ T = ZERO
+ AAPP = ZERO
+ CALL DLASSQ( M, A( 1, p ), 1, T,
+ + AAPP )
+ AAPP = T*DSQRT( AAPP )*D( p )
+ END IF
+ SVA( p ) = AAPP
+ END IF
* end of OK rotation
- ELSE
- NOTROT = NOTROT + 1
- PSKIPPED = PSKIPPED + 1
- IJBLSK = IJBLSK + 1
- END IF
- ELSE
- NOTROT = NOTROT + 1
- PSKIPPED = PSKIPPED + 1
- IJBLSK = IJBLSK + 1
- END IF
+ ELSE
+ NOTROT = NOTROT + 1
+ PSKIPPED = PSKIPPED + 1
+ IJBLSK = IJBLSK + 1
+ END IF
+ ELSE
+ NOTROT = NOTROT + 1
+ PSKIPPED = PSKIPPED + 1
+ IJBLSK = IJBLSK + 1
+ END IF
*
- IF ( ( i .LE. SWBAND ) .AND. ( IJBLSK .GE. BLSKIP ) ) THEN
- SVA(p) = AAPP
- NOTROT = 0
- GO TO 2011
- END IF
- IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN
- AAPP = -AAPP
- NOTROT = 0
- GO TO 2203
- END IF
+ IF( ( i.LE.SWBAND ) .AND. ( IJBLSK.GE.BLSKIP ) )
+ + THEN
+ SVA( p ) = AAPP
+ NOTROT = 0
+ GO TO 2011
+ END IF
+ IF( ( i.LE.SWBAND ) .AND.
+ + ( PSKIPPED.GT.ROWSKIP ) ) THEN
+ AAPP = -AAPP
+ NOTROT = 0
+ GO TO 2203
+ END IF
*
- 2200 CONTINUE
+ 2200 CONTINUE
* end of the q-loop
- 2203 CONTINUE
+ 2203 CONTINUE
*
- SVA(p) = AAPP
+ SVA( p ) = AAPP
*
- ELSE
- IF ( AAPP .EQ. ZERO ) NOTROT=NOTROT+MIN0(jgl+KBL-1,N)-jgl+1
- IF ( AAPP .LT. ZERO ) NOTROT = 0
- END IF
+ ELSE
+ IF( AAPP.EQ.ZERO )NOTROT = NOTROT +
+ + MIN0( jgl+KBL-1, N ) - jgl + 1
+ IF( AAPP.LT.ZERO )NOTROT = 0
+ END IF
- 2100 CONTINUE
+ 2100 CONTINUE
* end of the p-loop
- 2010 CONTINUE
+ 2010 CONTINUE
* end of the jbc-loop
- 2011 CONTINUE
+ 2011 CONTINUE
*2011 bailed out of the jbc-loop
- DO 2012 p = igl, MIN0( igl + KBL - 1, N )
- SVA(p) = DABS(SVA(p))
- 2012 CONTINUE
+ DO 2012 p = igl, MIN0( igl+KBL-1, N )
+ SVA( p ) = DABS( SVA( p ) )
+ 2012 CONTINUE
*
- 2000 CONTINUE
+ 2000 CONTINUE
*2000 :: end of the ibr-loop
*
* .. update SVA(N)
- IF ((SVA(N) .LT. ROOTBIG).AND.(SVA(N) .GT. ROOTSFMIN)) THEN
- SVA(N) = DNRM2( M, A(1,N), 1 ) * D(N)
- ELSE
- T = ZERO
- AAPP = ZERO
- CALL DLASSQ( M, A(1,N), 1, T, AAPP )
- SVA(N) = T * DSQRT(AAPP) * D(N)
- END IF
+ IF( ( SVA( N ).LT.ROOTBIG ) .AND. ( SVA( N ).GT.ROOTSFMIN ) )
+ + THEN
+ SVA( N ) = DNRM2( M, A( 1, N ), 1 )*D( N )
+ ELSE
+ T = ZERO
+ AAPP = ZERO
+ CALL DLASSQ( M, A( 1, N ), 1, T, AAPP )
+ SVA( N ) = T*DSQRT( AAPP )*D( N )
+ END IF
*
* Additional steering devices
*
- IF ( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR.
- & ( ISWROT .LE. N ) ) )
- & SWBAND = i
+ IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR.
+ + ( ISWROT.LE.N ) ) )SWBAND = i
*
- IF ((i.GT.SWBAND+1).AND. (MXAAPQ.LT.DBLE(N)*TOL).AND.
- & (DBLE(N)*MXAAPQ*MXSINJ.LT.TOL))THEN
- GO TO 1994
- END IF
+ IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.DBLE( N )*TOL ) .AND.
+ + ( DBLE( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN
+ GO TO 1994
+ END IF
*
- IF ( NOTROT .GE. EMPTSW ) GO TO 1994
+ IF( NOTROT.GE.EMPTSW )GO TO 1994
1993 CONTINUE
* end i=1:NSWEEP loop
*
* Sort the vector D.
DO 5991 p = 1, N - 1
- q = IDAMAX( N-p+1, SVA(p), 1 ) + p - 1
- IF ( p .NE. q ) THEN
- TEMP1 = SVA(p)
- SVA(p) = SVA(q)
- SVA(q) = TEMP1
- TEMP1 = D(p)
- D(p) = D(q)
- D(q) = TEMP1
- CALL DSWAP( M, A(1,p), 1, A(1,q), 1 )
- IF ( RSVEC ) CALL DSWAP( MVL, V(1,p), 1, V(1,q), 1 )
+ q = IDAMAX( N-p+1, SVA( p ), 1 ) + p - 1
+ IF( p.NE.q ) THEN
+ TEMP1 = SVA( p )
+ SVA( p ) = SVA( q )
+ SVA( q ) = TEMP1
+ TEMP1 = D( p )
+ D( p ) = D( q )
+ D( q ) = TEMP1
+ CALL DSWAP( M, A( 1, p ), 1, A( 1, q ), 1 )
+ IF( RSVEC )CALL DSWAP( MVL, V( 1, p ), 1, V( 1, q ), 1 )
END IF
5991 CONTINUE
*
* .. END OF DGSVJ0
* ..
END
-*
SUBROUTINE DGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV,
- & EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )
+ + EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.2) --
*
* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the
* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0.
*
-* -#- Scalar Arguments -#-
-*
- IMPLICIT NONE
- DOUBLE PRECISION EPS, SFMIN, TOL
- INTEGER INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP
- CHARACTER*1 JOBV
-*
-* -#- Array Arguments -#-
-*
- DOUBLE PRECISION A( LDA, * ), D( N ), SVA( N ), V( LDV, * ),
- & WORK( LWORK )
+ IMPLICIT NONE
+* ..
+* .. Scalar Arguments ..
+ DOUBLE PRECISION EPS, SFMIN, TOL
+ INTEGER INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP
+ CHARACTER*1 JOBV
+* ..
+* .. Array Arguments ..
+ DOUBLE PRECISION A( LDA, * ), D( N ), SVA( N ), V( LDV, * ),
+ + WORK( LWORK )
* ..
*
* Purpose
-* ~~~~~~~
+* =======
+*
* DGSVJ1 is called from SGESVJ as a pre-processor and that is its main
* purpose. It applies Jacobi rotations in the same way as SGESVJ does, but
* it targets only particular pivots and it does not check convergence
* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)
*
* Arguments
-* ~~~~~~~~~
+* =========
*
* JOBV (input) CHARACTER*1
* Specifies whether the output from this procedure is used
* = 0 : successful exit.
* < 0 : if INFO = -i, then the i-th argument had an illegal value
*
-* -#- Local Parameters -#-
-*
- DOUBLE PRECISION ZERO, HALF, ONE, TWO
- PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0, TWO = 2.0D0 )
-
-* -#- Local Scalars -#-
-*
- DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,
- & BIGTHETA, CS, LARGE, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS,
- & ROOTSFMIN, ROOTTOL, SMALL, SN, T, TEMP1, THETA, THSIGN
- INTEGER BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK, ISWROT, jbc,
- & jgl, KBL, MVL, NOTROT, nblc, nblr, p, PSKIPPED, q,
- & ROWSKIP, SWBAND
- LOGICAL APPLV, ROTOK, RSVEC
-*
-* Local Arrays
-*
- DOUBLE PRECISION FASTR(5)
-*
-* Intrinsic Functions
-*
- INTRINSIC DABS, DMAX1, DBLE, MIN0, DSIGN, DSQRT
-*
-* External Functions
-*
- DOUBLE PRECISION DDOT, DNRM2
- INTEGER IDAMAX
- LOGICAL LSAME
- EXTERNAL IDAMAX, LSAME, DDOT, DNRM2
+* =====================================================================
*
-* External Subroutines
-*
- EXTERNAL DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP
+* .. Local Parameters ..
+ DOUBLE PRECISION ZERO, HALF, ONE, TWO
+ PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,
+ + TWO = 2.0D0 )
+* ..
+* .. Local Scalars ..
+ DOUBLE PRECISION AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,
+ + BIGTHETA, CS, LARGE, MXAAPQ, MXSINJ, ROOTBIG,
+ + ROOTEPS, ROOTSFMIN, ROOTTOL, SMALL, SN, T,
+ + TEMP1, THETA, THSIGN
+ INTEGER BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK,
+ + ISWROT, jbc, jgl, KBL, MVL, NOTROT, nblc, nblr,
+ + p, PSKIPPED, q, ROWSKIP, SWBAND
+ LOGICAL APPLV, ROTOK, RSVEC
+* ..
+* .. Local Arrays ..
+ DOUBLE PRECISION FASTR( 5 )
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC DABS, DMAX1, DBLE, MIN0, DSIGN, DSQRT
+* ..
+* .. External Functions ..
+ DOUBLE PRECISION DDOT, DNRM2
+ INTEGER IDAMAX
+ LOGICAL LSAME
+ EXTERNAL IDAMAX, LSAME, DDOT, DNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP
+* ..
+* .. Executable Statements ..
*
+* Test the input parameters.
*
- APPLV = LSAME(JOBV,'A')
- RSVEC = LSAME(JOBV,'V')
- IF ( .NOT.( RSVEC .OR. APPLV .OR. LSAME(JOBV,'N'))) THEN
+ APPLV = LSAME( JOBV, 'A' )
+ RSVEC = LSAME( JOBV, 'V' )
+ IF( .NOT.( RSVEC .OR. APPLV .OR. LSAME( JOBV, 'N' ) ) ) THEN
INFO = -1
- ELSE IF ( M .LT. 0 ) THEN
+ ELSE IF( M.LT.0 ) THEN
INFO = -2
- ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M )) THEN
+ ELSE IF( ( N.LT.0 ) .OR. ( N.GT.M ) ) THEN
INFO = -3
- ELSE IF ( N1 .LT. 0 ) THEN
+ ELSE IF( N1.LT.0 ) THEN
INFO = -4
- ELSE IF ( LDA .LT. M ) THEN
+ ELSE IF( LDA.LT.M ) THEN
INFO = -6
- ELSE IF ( MV .LT. 0 ) THEN
+ ELSE IF( MV.LT.0 ) THEN
INFO = -9
- ELSE IF ( LDV .LT. M ) THEN
+ ELSE IF( LDV.LT.M ) THEN
INFO = -11
- ELSE IF ( TOL .LE. EPS ) THEN
+ ELSE IF( TOL.LE.EPS ) THEN
INFO = -14
- ELSE IF ( NSWEEP .LT. 0 ) THEN
+ ELSE IF( NSWEEP.LT.0 ) THEN
INFO = -15
- ELSE IF ( LWORK .LT. M ) THEN
+ ELSE IF( LWORK.LT.M ) THEN
INFO = -17
ELSE
INFO = 0
END IF
*
* #:(
- IF ( INFO .NE. 0 ) THEN
+ IF( INFO.NE.0 ) THEN
CALL XERBLA( 'DGSVJ1', -INFO )
RETURN
END IF
*
- IF ( RSVEC ) THEN
+ IF( RSVEC ) THEN
MVL = N
- ELSE IF ( APPLV ) THEN
+ ELSE IF( APPLV ) THEN
MVL = MV
END IF
RSVEC = RSVEC .OR. APPLV
- ROOTEPS = DSQRT(EPS)
- ROOTSFMIN = DSQRT(SFMIN)
- SMALL = SFMIN / EPS
- BIG = ONE / SFMIN
- ROOTBIG = ONE / ROOTSFMIN
- LARGE = BIG / DSQRT(DBLE(M*N))
- BIGTHETA = ONE / ROOTEPS
- ROOTTOL = DSQRT(TOL)
+ ROOTEPS = DSQRT( EPS )
+ ROOTSFMIN = DSQRT( SFMIN )
+ SMALL = SFMIN / EPS
+ BIG = ONE / SFMIN
+ ROOTBIG = ONE / ROOTSFMIN
+ LARGE = BIG / DSQRT( DBLE( M*N ) )
+ BIGTHETA = ONE / ROOTEPS
+ ROOTTOL = DSQRT( TOL )
*
-* -#- Initialize the right singular vector matrix -#-
+* .. Initialize the right singular vector matrix ..
*
* RSVEC = LSAME( JOBV, 'Y' )
*
- EMPTSW = N1 * ( N - N1 )
- NOTROT = 0
- FASTR(1) = ZERO
+ EMPTSW = N1*( N-N1 )
+ NOTROT = 0
+ FASTR( 1 ) = ZERO
*
-* -#- Row-cyclic pivot strategy with de Rijk's pivoting -#-
+* .. Row-cyclic pivot strategy with de Rijk's pivoting ..
*
- KBL = MIN0(8,N)
+ KBL = MIN0( 8, N )
NBLR = N1 / KBL
- IF ( ( NBLR * KBL ) .NE. N1 ) NBLR = NBLR + 1
+ IF( ( NBLR*KBL ).NE.N1 )NBLR = NBLR + 1
* .. the tiling is nblr-by-nblc [tiles]
- NBLC = ( N - N1 ) / KBL
- IF ( ( NBLC * KBL ) .NE. ( N - N1 ) ) NBLC = NBLC + 1
+ NBLC = ( N-N1 ) / KBL
+ IF( ( NBLC*KBL ).NE.( N-N1 ) )NBLC = NBLC + 1
BLSKIP = ( KBL**2 ) + 1
*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL.
DO 1993 i = 1, NSWEEP
* .. go go go ...
*
- MXAAPQ = ZERO
- MXSINJ = ZERO
- ISWROT = 0
+ MXAAPQ = ZERO
+ MXSINJ = ZERO
+ ISWROT = 0
*
- NOTROT = 0
- PSKIPPED = 0
+ NOTROT = 0
+ PSKIPPED = 0
*
- DO 2000 ibr = 1, NBLR
+ DO 2000 ibr = 1, NBLR
- igl = ( ibr - 1 ) * KBL + 1
+ igl = ( ibr-1 )*KBL + 1
*
*
*........................................................
* ... go to the off diagonal blocks
- igl = ( ibr - 1 ) * KBL + 1
+ igl = ( ibr-1 )*KBL + 1
- DO 2010 jbc = 1, NBLC
+ DO 2010 jbc = 1, NBLC
- jgl = N1 + ( jbc - 1 ) * KBL + 1
+ jgl = N1 + ( jbc-1 )*KBL + 1
* doing the block at ( ibr, jbc )
- IJBLSK = 0
- DO 2100 p = igl, MIN0( igl + KBL - 1, N1 )
+ IJBLSK = 0
+ DO 2100 p = igl, MIN0( igl+KBL-1, N1 )
- AAPP = SVA(p)
+ AAPP = SVA( p )
- IF ( AAPP .GT. ZERO ) THEN
+ IF( AAPP.GT.ZERO ) THEN
- PSKIPPED = 0
+ PSKIPPED = 0
- DO 2200 q = jgl, MIN0( jgl + KBL - 1, N )
+ DO 2200 q = jgl, MIN0( jgl+KBL-1, N )
*
- AAQQ = SVA(q)
+ AAQQ = SVA( q )
- IF ( AAQQ .GT. ZERO ) THEN
- AAPP0 = AAPP
-*
-* -#- M x 2 Jacobi SVD -#-
-*
-* -#- Safe Gram matrix computation -#-
-*
- IF ( AAQQ .GE. ONE ) THEN
- IF ( AAPP .GE. AAQQ ) THEN
- ROTOK = ( SMALL*AAPP ) .LE. AAQQ
- ELSE
- ROTOK = ( SMALL*AAQQ ) .LE. AAPP
- END IF
- IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN
- AAPQ = ( DDOT(M, A(1,p), 1, A(1,q), 1 ) *
- & D(p) * D(q) / AAQQ ) / AAPP
- ELSE
- CALL DCOPY( M, A(1,p), 1, WORK, 1 )
- CALL DLASCL( 'G', 0, 0, AAPP, D(p), M,
- & 1, WORK, LDA, IERR )
- AAPQ = DDOT( M, WORK, 1, A(1,q), 1 ) *
- & D(q) / AAQQ
- END IF
- ELSE
- IF ( AAPP .GE. AAQQ ) THEN
- ROTOK = AAPP .LE. ( AAQQ / SMALL )
- ELSE
- ROTOK = AAQQ .LE. ( AAPP / SMALL )
- END IF
- IF ( AAPP .GT. ( SMALL / AAQQ ) ) THEN
- AAPQ = ( DDOT( M, A(1,p), 1, A(1,q), 1 ) *
- & D(p) * D(q) / AAQQ ) / AAPP
- ELSE
- CALL DCOPY( M, A(1,q), 1, WORK, 1 )
- CALL DLASCL( 'G', 0, 0, AAQQ, D(q), M, 1,
- & WORK, LDA, IERR )
- AAPQ = DDOT(M,WORK,1,A(1,p),1) * D(p) / AAPP
- END IF
- END IF
+ IF( AAQQ.GT.ZERO ) THEN
+ AAPP0 = AAPP
+*
+* .. M x 2 Jacobi SVD ..
+*
+* .. Safe Gram matrix computation ..
+*
+ IF( AAQQ.GE.ONE ) THEN
+ IF( AAPP.GE.AAQQ ) THEN
+ ROTOK = ( SMALL*AAPP ).LE.AAQQ
+ ELSE
+ ROTOK = ( SMALL*AAQQ ).LE.AAPP
+ END IF
+ IF( AAPP.LT.( BIG / AAQQ ) ) THEN
+ AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1,
+ + q ), 1 )*D( p )*D( q ) / AAQQ )
+ + / AAPP
+ ELSE
+ CALL DCOPY( M, A( 1, p ), 1, WORK, 1 )
+ CALL DLASCL( 'G', 0, 0, AAPP, D( p ),
+ + M, 1, WORK, LDA, IERR )
+ AAPQ = DDOT( M, WORK, 1, A( 1, q ),
+ + 1 )*D( q ) / AAQQ
+ END IF
+ ELSE
+ IF( AAPP.GE.AAQQ ) THEN
+ ROTOK = AAPP.LE.( AAQQ / SMALL )
+ ELSE
+ ROTOK = AAQQ.LE.( AAPP / SMALL )
+ END IF
+ IF( AAPP.GT.( SMALL / AAQQ ) ) THEN
+ AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1,
+ + q ), 1 )*D( p )*D( q ) / AAQQ )
+ + / AAPP
+ ELSE
+ CALL DCOPY( M, A( 1, q ), 1, WORK, 1 )
+ CALL DLASCL( 'G', 0, 0, AAQQ, D( q ),
+ + M, 1, WORK, LDA, IERR )
+ AAPQ = DDOT( M, WORK, 1, A( 1, p ),
+ + 1 )*D( p ) / AAPP
+ END IF
+ END IF
- MXAAPQ = DMAX1( MXAAPQ, DABS(AAPQ) )
+ MXAAPQ = DMAX1( MXAAPQ, DABS( AAPQ ) )
* TO rotate or NOT to rotate, THAT is the question ...
*
- IF ( DABS( AAPQ ) .GT. TOL ) THEN
- NOTROT = 0
+ IF( DABS( AAPQ ).GT.TOL ) THEN
+ NOTROT = 0
* ROTATED = ROTATED + 1
- PSKIPPED = 0
- ISWROT = ISWROT + 1
+ PSKIPPED = 0
+ ISWROT = ISWROT + 1
*
- IF ( ROTOK ) THEN
+ IF( ROTOK ) THEN
*
- AQOAP = AAQQ / AAPP
- APOAQ = AAPP / AAQQ
- THETA = - HALF * DABS( AQOAP - APOAQ ) / AAPQ
- IF ( AAQQ .GT. AAPP0 ) THETA = - THETA
+ AQOAP = AAQQ / AAPP
+ APOAQ = AAPP / AAQQ
+ THETA = -HALF*DABS( AQOAP-APOAQ ) /
+ + AAPQ
+ IF( AAQQ.GT.AAPP0 )THETA = -THETA
- IF ( DABS( THETA ) .GT. BIGTHETA ) THEN
- T = HALF / THETA
- FASTR(3) = T * D(p) / D(q)
- FASTR(4) = -T * D(q) / D(p)
- CALL DROTM( M, A(1,p), 1, A(1,q), 1, FASTR )
- IF ( RSVEC )
- & CALL DROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR )
- SVA(q) = AAQQ*DSQRT( DMAX1(ZERO,ONE + T*APOAQ*AAPQ) )
- AAPP = AAPP*DSQRT( DMAX1(ZERO,ONE - T*AQOAP*AAPQ) )
- MXSINJ = DMAX1( MXSINJ, DABS(T) )
- ELSE
+ IF( DABS( THETA ).GT.BIGTHETA ) THEN
+ T = HALF / THETA
+ FASTR( 3 ) = T*D( p ) / D( q )
+ FASTR( 4 ) = -T*D( q ) / D( p )
+ CALL DROTM( M, A( 1, p ), 1,
+ + A( 1, q ), 1, FASTR )
+ IF( RSVEC )CALL DROTM( MVL,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1,
+ + FASTR )
+ SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
+ + ONE+T*APOAQ*AAPQ ) )
+ AAPP = AAPP*DSQRT( DMAX1( ZERO,
+ + ONE-T*AQOAP*AAPQ ) )
+ MXSINJ = DMAX1( MXSINJ, DABS( T ) )
+ ELSE
*
* .. choose correct signum for THETA and rotate
*
- THSIGN = - DSIGN(ONE,AAPQ)
- IF ( AAQQ .GT. AAPP0 ) THSIGN = - THSIGN
- T = ONE / ( THETA + THSIGN*DSQRT(ONE+THETA*THETA) )
- CS = DSQRT( ONE / ( ONE + T*T ) )
- SN = T * CS
- MXSINJ = DMAX1( MXSINJ, DABS(SN) )
- SVA(q) = AAQQ*DSQRT( DMAX1(ZERO, ONE+T*APOAQ*AAPQ) )
- AAPP = AAPP*DSQRT( ONE - T*AQOAP*AAPQ)
+ THSIGN = -DSIGN( ONE, AAPQ )
+ IF( AAQQ.GT.AAPP0 )THSIGN = -THSIGN
+ T = ONE / ( THETA+THSIGN*
+ + DSQRT( ONE+THETA*THETA ) )
+ CS = DSQRT( ONE / ( ONE+T*T ) )
+ SN = T*CS
+ MXSINJ = DMAX1( MXSINJ, DABS( SN ) )
+ SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
+ + ONE+T*APOAQ*AAPQ ) )
+ AAPP = AAPP*DSQRT( ONE-T*AQOAP*
+ + AAPQ )
- APOAQ = D(p) / D(q)
- AQOAP = D(q) / D(p)
- IF ( D(p) .GE. ONE ) THEN
-*
- IF ( D(q) .GE. ONE ) THEN
- FASTR(3) = T * APOAQ
- FASTR(4) = - T * AQOAP
- D(p) = D(p) * CS
- D(q) = D(q) * CS
- CALL DROTM( M, A(1,p),1, A(1,q),1, FASTR )
- IF ( RSVEC )
- & CALL DROTM( MVL, V(1,p),1, V(1,q),1, FASTR )
- ELSE
- CALL DAXPY( M, -T*AQOAP, A(1,q),1, A(1,p),1 )
- CALL DAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 )
- IF ( RSVEC ) THEN
- CALL DAXPY( MVL, -T*AQOAP, V(1,q),1, V(1,p),1 )
- CALL DAXPY( MVL,CS*SN*APOAQ,V(1,p),1, V(1,q),1 )
- END IF
- D(p) = D(p) * CS
- D(q) = D(q) / CS
- END IF
- ELSE
- IF ( D(q) .GE. ONE ) THEN
- CALL DAXPY( M, T*APOAQ, A(1,p),1, A(1,q),1 )
- CALL DAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 )
- IF ( RSVEC ) THEN
- CALL DAXPY(MVL,T*APOAQ, V(1,p),1, V(1,q),1 )
- CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1, V(1,p),1 )
- END IF
- D(p) = D(p) / CS
- D(q) = D(q) * CS
- ELSE
- IF ( D(p) .GE. D(q) ) THEN
- CALL DAXPY( M,-T*AQOAP, A(1,q),1,A(1,p),1 )
- CALL DAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 )
- D(p) = D(p) * CS
- D(q) = D(q) / CS
- IF ( RSVEC ) THEN
- CALL DAXPY( MVL, -T*AQOAP, V(1,q),1,V(1,p),1)
- CALL DAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1)
- END IF
- ELSE
- CALL DAXPY(M, T*APOAQ, A(1,p),1,A(1,q),1)
- CALL DAXPY(M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1)
- D(p) = D(p) / CS
- D(q) = D(q) * CS
- IF ( RSVEC ) THEN
- CALL DAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1)
- CALL DAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1)
- END IF
- END IF
- END IF
- ENDIF
- END IF
+ APOAQ = D( p ) / D( q )
+ AQOAP = D( q ) / D( p )
+ IF( D( p ).GE.ONE ) THEN
+*
+ IF( D( q ).GE.ONE ) THEN
+ FASTR( 3 ) = T*APOAQ
+ FASTR( 4 ) = -T*AQOAP
+ D( p ) = D( p )*CS
+ D( q ) = D( q )*CS
+ CALL DROTM( M, A( 1, p ), 1,
+ + A( 1, q ), 1,
+ + FASTR )
+ IF( RSVEC )CALL DROTM( MVL,
+ + V( 1, p ), 1, V( 1, q ),
+ + 1, FASTR )
+ ELSE
+ CALL DAXPY( M, -T*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ CALL DAXPY( M, CS*SN*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ IF( RSVEC ) THEN
+ CALL DAXPY( MVL, -T*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ CALL DAXPY( MVL,
+ + CS*SN*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ END IF
+ D( p ) = D( p )*CS
+ D( q ) = D( q ) / CS
+ END IF
+ ELSE
+ IF( D( q ).GE.ONE ) THEN
+ CALL DAXPY( M, T*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ CALL DAXPY( M, -CS*SN*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ IF( RSVEC ) THEN
+ CALL DAXPY( MVL, T*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ CALL DAXPY( MVL,
+ + -CS*SN*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ END IF
+ D( p ) = D( p ) / CS
+ D( q ) = D( q )*CS
+ ELSE
+ IF( D( p ).GE.D( q ) ) THEN
+ CALL DAXPY( M, -T*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ CALL DAXPY( M, CS*SN*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ D( p ) = D( p )*CS
+ D( q ) = D( q ) / CS
+ IF( RSVEC ) THEN
+ CALL DAXPY( MVL,
+ + -T*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ CALL DAXPY( MVL,
+ + CS*SN*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ END IF
+ ELSE
+ CALL DAXPY( M, T*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ CALL DAXPY( M,
+ + -CS*SN*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ D( p ) = D( p ) / CS
+ D( q ) = D( q )*CS
+ IF( RSVEC ) THEN
+ CALL DAXPY( MVL,
+ + T*APOAQ, V( 1, p ),
+ + 1, V( 1, q ), 1 )
+ CALL DAXPY( MVL,
+ + -CS*SN*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ END IF
+ END IF
+ END IF
+ END IF
+ END IF
- ELSE
- IF ( AAPP .GT. AAQQ ) THEN
- CALL DCOPY( M, A(1,p), 1, WORK, 1 )
- CALL DLASCL('G',0,0,AAPP,ONE,M,1,WORK,LDA,IERR)
- CALL DLASCL('G',0,0,AAQQ,ONE,M,1, A(1,q),LDA,IERR)
- TEMP1 = -AAPQ * D(p) / D(q)
- CALL DAXPY(M,TEMP1,WORK,1,A(1,q),1)
- CALL DLASCL('G',0,0,ONE,AAQQ,M,1,A(1,q),LDA,IERR)
- SVA(q) = AAQQ*DSQRT(DMAX1(ZERO, ONE - AAPQ*AAPQ))
- MXSINJ = DMAX1( MXSINJ, SFMIN )
- ELSE
- CALL DCOPY( M, A(1,q), 1, WORK, 1 )
- CALL DLASCL('G',0,0,AAQQ,ONE,M,1,WORK,LDA,IERR)
- CALL DLASCL('G',0,0,AAPP,ONE,M,1, A(1,p),LDA,IERR)
- TEMP1 = -AAPQ * D(q) / D(p)
- CALL DAXPY(M,TEMP1,WORK,1,A(1,p),1)
- CALL DLASCL('G',0,0,ONE,AAPP,M,1,A(1,p),LDA,IERR)
- SVA(p) = AAPP*DSQRT(DMAX1(ZERO, ONE - AAPQ*AAPQ))
- MXSINJ = DMAX1( MXSINJ, SFMIN )
- END IF
- END IF
+ ELSE
+ IF( AAPP.GT.AAQQ ) THEN
+ CALL DCOPY( M, A( 1, p ), 1, WORK,
+ + 1 )
+ CALL DLASCL( 'G', 0, 0, AAPP, ONE,
+ + M, 1, WORK, LDA, IERR )
+ CALL DLASCL( 'G', 0, 0, AAQQ, ONE,
+ + M, 1, A( 1, q ), LDA,
+ + IERR )
+ TEMP1 = -AAPQ*D( p ) / D( q )
+ CALL DAXPY( M, TEMP1, WORK, 1,
+ + A( 1, q ), 1 )
+ CALL DLASCL( 'G', 0, 0, ONE, AAQQ,
+ + M, 1, A( 1, q ), LDA,
+ + IERR )
+ SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
+ + ONE-AAPQ*AAPQ ) )
+ MXSINJ = DMAX1( MXSINJ, SFMIN )
+ ELSE
+ CALL DCOPY( M, A( 1, q ), 1, WORK,
+ + 1 )
+ CALL DLASCL( 'G', 0, 0, AAQQ, ONE,
+ + M, 1, WORK, LDA, IERR )
+ CALL DLASCL( 'G', 0, 0, AAPP, ONE,
+ + M, 1, A( 1, p ), LDA,
+ + IERR )
+ TEMP1 = -AAPQ*D( q ) / D( p )
+ CALL DAXPY( M, TEMP1, WORK, 1,
+ + A( 1, p ), 1 )
+ CALL DLASCL( 'G', 0, 0, ONE, AAPP,
+ + M, 1, A( 1, p ), LDA,
+ + IERR )
+ SVA( p ) = AAPP*DSQRT( DMAX1( ZERO,
+ + ONE-AAPQ*AAPQ ) )
+ MXSINJ = DMAX1( MXSINJ, SFMIN )
+ END IF
+ END IF
* END IF ROTOK THEN ... ELSE
*
* In the case of cancellation in updating SVA(q)
* .. recompute SVA(q)
- IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS ) THEN
- IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN
- SVA(q) = DNRM2( M, A(1,q), 1 ) * D(q)
- ELSE
- T = ZERO
- AAQQ = ZERO
- CALL DLASSQ( M, A(1,q), 1, T, AAQQ )
- SVA(q) = T * DSQRT(AAQQ) * D(q)
- END IF
- END IF
- IF ( (AAPP / AAPP0 )**2 .LE. ROOTEPS ) THEN
- IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN
- AAPP = DNRM2( M, A(1,p), 1 ) * D(p)
- ELSE
- T = ZERO
- AAPP = ZERO
- CALL DLASSQ( M, A(1,p), 1, T, AAPP )
- AAPP = T * DSQRT(AAPP) * D(p)
- END IF
- SVA(p) = AAPP
- END IF
+ IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS )
+ + THEN
+ IF( ( AAQQ.LT.ROOTBIG ) .AND.
+ + ( AAQQ.GT.ROOTSFMIN ) ) THEN
+ SVA( q ) = DNRM2( M, A( 1, q ), 1 )*
+ + D( q )
+ ELSE
+ T = ZERO
+ AAQQ = ZERO
+ CALL DLASSQ( M, A( 1, q ), 1, T,
+ + AAQQ )
+ SVA( q ) = T*DSQRT( AAQQ )*D( q )
+ END IF
+ END IF
+ IF( ( AAPP / AAPP0 )**2.LE.ROOTEPS ) THEN
+ IF( ( AAPP.LT.ROOTBIG ) .AND.
+ + ( AAPP.GT.ROOTSFMIN ) ) THEN
+ AAPP = DNRM2( M, A( 1, p ), 1 )*
+ + D( p )
+ ELSE
+ T = ZERO
+ AAPP = ZERO
+ CALL DLASSQ( M, A( 1, p ), 1, T,
+ + AAPP )
+ AAPP = T*DSQRT( AAPP )*D( p )
+ END IF
+ SVA( p ) = AAPP
+ END IF
* end of OK rotation
- ELSE
- NOTROT = NOTROT + 1
+ ELSE
+ NOTROT = NOTROT + 1
* SKIPPED = SKIPPED + 1
- PSKIPPED = PSKIPPED + 1
- IJBLSK = IJBLSK + 1
- END IF
- ELSE
- NOTROT = NOTROT + 1
- PSKIPPED = PSKIPPED + 1
- IJBLSK = IJBLSK + 1
- END IF
+ PSKIPPED = PSKIPPED + 1
+ IJBLSK = IJBLSK + 1
+ END IF
+ ELSE
+ NOTROT = NOTROT + 1
+ PSKIPPED = PSKIPPED + 1
+ IJBLSK = IJBLSK + 1
+ END IF
* IF ( NOTROT .GE. EMPTSW ) GO TO 2011
- IF ( ( i .LE. SWBAND ) .AND. ( IJBLSK .GE. BLSKIP ) ) THEN
- SVA(p) = AAPP
- NOTROT = 0
- GO TO 2011
- END IF
- IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN
- AAPP = -AAPP
- NOTROT = 0
- GO TO 2203
- END IF
+ IF( ( i.LE.SWBAND ) .AND. ( IJBLSK.GE.BLSKIP ) )
+ + THEN
+ SVA( p ) = AAPP
+ NOTROT = 0
+ GO TO 2011
+ END IF
+ IF( ( i.LE.SWBAND ) .AND.
+ + ( PSKIPPED.GT.ROWSKIP ) ) THEN
+ AAPP = -AAPP
+ NOTROT = 0
+ GO TO 2203
+ END IF
*
- 2200 CONTINUE
+ 2200 CONTINUE
* end of the q-loop
- 2203 CONTINUE
+ 2203 CONTINUE
- SVA(p) = AAPP
+ SVA( p ) = AAPP
*
- ELSE
- IF ( AAPP .EQ. ZERO ) NOTROT=NOTROT+MIN0(jgl+KBL-1,N)-jgl+1
- IF ( AAPP .LT. ZERO ) NOTROT = 0
+ ELSE
+ IF( AAPP.EQ.ZERO )NOTROT = NOTROT +
+ + MIN0( jgl+KBL-1, N ) - jgl + 1
+ IF( AAPP.LT.ZERO )NOTROT = 0
*** IF ( NOTROT .GE. EMPTSW ) GO TO 2011
- END IF
+ END IF
- 2100 CONTINUE
+ 2100 CONTINUE
* end of the p-loop
- 2010 CONTINUE
+ 2010 CONTINUE
* end of the jbc-loop
- 2011 CONTINUE
+ 2011 CONTINUE
*2011 bailed out of the jbc-loop
- DO 2012 p = igl, MIN0( igl + KBL - 1, N )
- SVA(p) = DABS(SVA(p))
- 2012 CONTINUE
+ DO 2012 p = igl, MIN0( igl+KBL-1, N )
+ SVA( p ) = DABS( SVA( p ) )
+ 2012 CONTINUE
*** IF ( NOTROT .GE. EMPTSW ) GO TO 1994
- 2000 CONTINUE
+ 2000 CONTINUE
*2000 :: end of the ibr-loop
*
* .. update SVA(N)
- IF ((SVA(N) .LT. ROOTBIG).AND.(SVA(N) .GT. ROOTSFMIN)) THEN
- SVA(N) = DNRM2( M, A(1,N), 1 ) * D(N)
- ELSE
- T = ZERO
- AAPP = ZERO
- CALL DLASSQ( M, A(1,N), 1, T, AAPP )
- SVA(N) = T * DSQRT(AAPP) * D(N)
- END IF
+ IF( ( SVA( N ).LT.ROOTBIG ) .AND. ( SVA( N ).GT.ROOTSFMIN ) )
+ + THEN
+ SVA( N ) = DNRM2( M, A( 1, N ), 1 )*D( N )
+ ELSE
+ T = ZERO
+ AAPP = ZERO
+ CALL DLASSQ( M, A( 1, N ), 1, T, AAPP )
+ SVA( N ) = T*DSQRT( AAPP )*D( N )
+ END IF
*
* Additional steering devices
*
- IF ( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR.
- & ( ISWROT .LE. N ) ) )
- & SWBAND = i
+ IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR.
+ + ( ISWROT.LE.N ) ) )SWBAND = i
- IF ((i.GT.SWBAND+1).AND. (MXAAPQ.LT.DBLE(N)*TOL).AND.
- & (DBLE(N)*MXAAPQ*MXSINJ.LT.TOL))THEN
- GO TO 1994
- END IF
+ IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.DBLE( N )*TOL ) .AND.
+ + ( DBLE( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN
+ GO TO 1994
+ END IF
*
- IF ( NOTROT .GE. EMPTSW ) GO TO 1994
+ IF( NOTROT.GE.EMPTSW )GO TO 1994
1993 CONTINUE
* end i=1:NSWEEP loop
* Sort the vector D
*
DO 5991 p = 1, N - 1
- q = IDAMAX( N-p+1, SVA(p), 1 ) + p - 1
- IF ( p .NE. q ) THEN
- TEMP1 = SVA(p)
- SVA(p) = SVA(q)
- SVA(q) = TEMP1
- TEMP1 = D(p)
- D(p) = D(q)
- D(q) = TEMP1
- CALL DSWAP( M, A(1,p), 1, A(1,q), 1 )
- IF ( RSVEC ) CALL DSWAP( MVL, V(1,p), 1, V(1,q), 1 )
+ q = IDAMAX( N-p+1, SVA( p ), 1 ) + p - 1
+ IF( p.NE.q ) THEN
+ TEMP1 = SVA( p )
+ SVA( p ) = SVA( q )
+ SVA( q ) = TEMP1
+ TEMP1 = D( p )
+ D( p ) = D( q )
+ D( q ) = TEMP1
+ CALL DSWAP( M, A( 1, p ), 1, A( 1, q ), 1 )
+ IF( RSVEC )CALL DSWAP( MVL, V( 1, p ), 1, V( 1, q ), 1 )
END IF
5991 CONTINUE
*
* .. END OF DGSVJ1
* ..
END
-*
* entry is considered "symbolic" if all multiplications involved
* in computing that entry have at least one zero multiplicand.
*
-* Parameters
+* Arguments
* ==========
*
* TRANS - INTEGER
*
*
* Level 2 Blas routine.
-* ..
+*
+* =====================================================================
+*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER IWORK( * ), IPIV( * )
DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ),
$ C( * )
+* ..
+*
+* Purpose
+* =======
*
* DLA_GERCOND Estimates the Skeel condition number of op(A) * op2(C)
* where op2 is determined by CMODE as follows
* is computed by computing scaling factors R such that
* diag(R)*A*op2(C) is row equilibrated and computing the standard
* infinity-norm condition number.
-* WORK is a double precision workspace of size 5*N, and
-* IWORK is an integer workspace of size N.
-* ..
+*
+* Arguments
+* =========
+*
+* WORK double precision workspace of size 5*N.
+*
+* IWORK integer workspace of size N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
LOGICAL NOTRANS
INTEGER KASE, I, J, KD
DOUBLE PRECISION C( * ), AYB(*), RCOND, BERR_OUT(*),
$ ERRS_N( NRHS, * ), ERRS_C( NRHS, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
CHARACTER TRANS
INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE
* .. Array Arguments ..
DOUBLE PRECISION AB( LDAB, * ), AFB( LDAFB, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER I, J, KD
DOUBLE PRECISION AMAX, UMAX, RPVGRW
* entry is considered "symbolic" if all multiplications involved
* in computing that entry have at least one zero multiplicand.
*
-* Parameters
+* Arguments
* ==========
*
* TRANS - INTEGER
*
* Level 2 Blas routine.
*
-* ..
+* =====================================================================
+*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER IPIV( * ), IWORK( * )
DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ),
$ C( * )
+* ..
+*
+* Purpose
+* =======
*
* DLA_GERCOND estimates the Skeel condition number of op(A) * op2(C)
* where op2 is determined by CMODE as follows
* is computed by computing scaling factors R such that
* diag(R)*A*op2(C) is row equilibrated and computing the standard
* infinity-norm condition number.
-* WORK is a DOUBLE PRECISION workspace of size 3*N, and
-* IWORK is an INTEGER workspace of size N.
-* ..
+*
+* Arguments
+* ==========
+*
+* WORK DOUBLE PRECISION workspace of size 3*N, and
+*
+* IWORK INTEGER workspace of size N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
LOGICAL NOTRANS
INTEGER KASE, I, J
DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ),
$ ERRS_N( NRHS, * ), ERRS_C( NRHS, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
CHARACTER TRANS
INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE
* .. Array Arguments ..
DOUBLE PRECISION AYB( N, NRHS ), BERR( NRHS )
DOUBLE PRECISION RES( N, NRHS )
+* ..
+*
+* Purpose
+* =======
*
-* DLA_LIN_BERR computes componentwise relative backward error from
+* DLA_LIN_BERR computes component-wise relative backward error from
* the formula
* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )
-* where abs(Z) is the componentwise absolute value of the matrix
+* where abs(Z) is the component-wise absolute value of the matrix
* or vector Z.
-* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
DOUBLE PRECISION TMP
INTEGER I, J
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
+* ..
+*
+* Purpose
+* =======
*
* DLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C)
* where op2 is determined by CMODE as follows
* is computed by computing scaling factors R such that
* diag(R)*A*op2(C) is row equilibrated and computing the standard
* infinity-norm condition number.
-* WORK is a double precision workspace of size 3*N, and
-* IWORK is an integer workspace of size N.
-* ..
+*
+* Arguments
+* ==========
+*
+* WORK double precision workspace of size 3*N.
+*
+* IWORK integer workspace of size N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER KASE, I, J
DOUBLE PRECISION AINVNM, TMP
DOUBLE PRECISION C( * ), AYB(*), RCOND, BERR_OUT( * ),
$ ERRS_N( NRHS, * ), ERRS_C( NRHS, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE
DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION AMAX, UMAX, RPVGRW
* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * ), AF( LDAF, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION AMAX, UMAX, RPVGRW
* entry is considered "symbolic" if all multiplications involved
* in computing that entry have at least one zero multiplicand.
*
-* Parameters
+* Arguments
* ==========
*
* UPLO - INTEGER
* Y. INCY must not be zero.
* Unchanged on exit.
*
+* Further Details
+* ===============
*
* Level 2 Blas routine.
*
* -- Modified for the absolute-value product, April 2006
* Jason Riedy, UC Berkeley
*
-* ..
+* =====================================================================
+*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
* .. Array Arguments
INTEGER IWORK( * ), IPIV( * )
DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * ), C( * )
+* ..
+*
+* Purpose
+* =======
*
* DLA_SYRCOND estimates the Skeel condition number of op(A) * op2(C)
* where op2 is determined by CMODE as follows
* is computed by computing scaling factors R such that
* diag(R)*A*op2(C) is row equilibrated and computing the standard
* infinity-norm condition number.
-* WORK is a double precision workspace of size 3*N, and
-* IWORK is an integer workspace of size N.
-* ..
+*
+* Arguments
+* ==========
+*
+* WORK double precision workspace of size 3*N.
+*
+* IWORK integer workspace of size N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
CHARACTER NORMIN
INTEGER KASE, I, J
DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ),
$ ERRS_N( NRHS, * ), ERRS_C( NRHS, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE
DOUBLE PRECISION YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,
INTEGER IPIV( * )
DOUBLE PRECISION A( LDA, * ), AF( LDAF, * ), WORK( * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER NCOLS, I, J, K, KP
DOUBLE PRECISION AMAX, UMAX, RPVGRW, TMP
*
* W (input) DOUBLE PRECISION array, length N
* The vector to be added.
-* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
DOUBLE PRECISION S
INTEGER I
* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
* WORK is not referenced.
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Rectangular Full Packed (RFP) Format when N is
* even. We give an example where N = 6.
* positive definite, and the factorization could not be
* completed.
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Rectangular Full Packed (RFP) Format when N is
* even. We give an example where N = 6.
* > 0: if INFO = i, the (i,i) element of the factor U or L is
* zero, and the inverse could not be computed.
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Rectangular Full Packed (RFP) Format when N is
* even. We give an example where N = 6.
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Rectangular Full Packed (RFP) Format when N is
* even. We give an example where N = 6.
* Computer Science Division Technical Report No. UCB/CSD-97-971,
* UC Berkeley, May 1997.
*
-* Notes:
+* Further Details
* 1.DSTEMR works only on machines which follow IEEE-754
* floating-point standard in their handling of infinities and NaNs.
* This permits the use of efficient inner loops avoiding a check for
* max( 1, m ).
* Unchanged on exit.
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Rectangular Full Packed (RFP) Format when N is
* even. We give an example where N = 6.
* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
* matrix is singular and its inverse can not be computed.
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Rectangular Full Packed (RFP) Format when N is
* even. We give an example where N = 6.
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Rectangular Full Packed (RFP) Format when N is
* even. We give an example where N = 6.
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Rectangular Full Packed (RFP) Format when N is
* even. We give an example where N = 6.
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Rectangular Full Packed (RFP) Format when N is
* even. We give an example where N = 6.
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Rectangular Full Packed (RFP) Format when N is
* even. We give an example where N = 6.
INTEGER FUNCTION ILACLC(M, N, A, LDA)
IMPLICIT NONE
-!
-! -- LAPACK auxiliary routine (version 3.2) --
-! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
-! December 2007
-!
-! .. Scalar Arguments ..
+*
+* -- LAPACK auxiliary routine (version 3.2) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* December 2007
+*
+* .. Scalar Arguments ..
INTEGER M, N, LDA
-! ..
-! .. Array Arguments ..
+* ..
+* .. Array Arguments ..
COMPLEX A( LDA, * )
-! ..
-!
-! Purpose
-! =======
-!
-! ILACLC scans A for its last non-zero column.
-!
-! Arguments
-! =========
-!
-! M (input) INTEGER
-! The number of rows of the matrix A.
-!
-! N (input) INTEGER
-! The number of columns of the matrix A.
-!
-! A (input) COMPLEX array, dimension (LDA,N)
-! The m by n matrix A.
-!
-! LDA (input) INTEGER
-! The leading dimension of the array A. LDA >= max(1,M).
-!
-! =====================================================================
-!
-! .. Parameters ..
+* ..
+*
+* Purpose
+* =======
+*
+* ILACLC scans A for its last non-zero column.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A.
+*
+* A (input) COMPLEX array, dimension (LDA,N)
+* The m by n matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* =====================================================================
+*
+* .. Parameters ..
COMPLEX ZERO
PARAMETER ( ZERO = (0.0E+0, 0.0E+0) )
-! ..
-! .. Local Scalars ..
+* ..
+* .. Local Scalars ..
INTEGER I
-! ..
-! .. Executable Statements ..
-!
-! Quick test for the common case where one corner is non-zero.
- IF( N.EQ.0 .OR. A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
+* ..
+* .. Executable Statements ..
+*
+* Quick test for the common case where one corner is non-zero.
+ IF( N.EQ.0 ) THEN
+ ILACLC = N
+ ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILACLC = N
ELSE
-! Now scan each column from the end, returning with the first non-zero.
+* Now scan each column from the end, returning with the first non-zero.
DO ILACLC = N, 1, -1
DO I = 1, M
IF( A(I, ILACLC).NE.ZERO ) RETURN
INTEGER FUNCTION ILACLR(M, N, A, LDA)
IMPLICIT NONE
-!
-! -- LAPACK auxiliary routine (version 3.2) --
-! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
-! December 2007
-!
-! .. Scalar Arguments ..
+*
+* -- LAPACK auxiliary routine (version 3.2) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* December 2007
+*
+* .. Scalar Arguments ..
INTEGER M, N, LDA
-! ..
-! .. Array Arguments ..
+* ..
+* .. Array Arguments ..
COMPLEX A( LDA, * )
-! ..
-!
-! Purpose
-! =======
-!
-! ILACLR scans A for its last non-zero row.
-!
-! Arguments
-! =========
-!
-! M (input) INTEGER
-! The number of rows of the matrix A.
-!
-! N (input) INTEGER
-! The number of columns of the matrix A.
-!
-! A (input) COMPLEX array, dimension (LDA,N)
-! The m by n matrix A.
-!
-! LDA (input) INTEGER
-! The leading dimension of the array A. LDA >= max(1,M).
-!
-! =====================================================================
-!
-! .. Parameters ..
+* ..
+*
+* Purpose
+* =======
+*
+* ILACLR scans A for its last non-zero row.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A.
+*
+* A (input) COMPLEX array, dimension (LDA,N)
+* The m by n matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* =====================================================================
+*
+* .. Parameters ..
COMPLEX ZERO
PARAMETER ( ZERO = (0.0E+0, 0.0E+0) )
-! ..
-! .. Local Scalars ..
+* ..
+* .. Local Scalars ..
INTEGER I, J
-! ..
-! .. Executable Statements ..
-!
-! Quick test for the common case where one corner is non-zero.
- IF( M.EQ.0 .OR. A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
+* ..
+* .. Executable Statements ..
+*
+* Quick test for the common case where one corner is non-zero.
+ IF( M.EQ.0 ) THEN
+ ILACLR = M
+ ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILACLR = M
ELSE
-! Scan up each column tracking the last zero row seen.
+* Scan up each column tracking the last zero row seen.
ILACLR = 0
DO J = 1, N
DO I = M, 1, -1
INTEGER FUNCTION ILADLC(M, N, A, LDA)
IMPLICIT NONE
-!
-! -- LAPACK auxiliary routine (version 3.2) --
-! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
-! December 2007
-!
-! .. Scalar Arguments ..
+*
+* -- LAPACK auxiliary routine (version 3.2) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* December 2007
+*
+* .. Scalar Arguments ..
INTEGER M, N, LDA
-! ..
-! .. Array Arguments ..
+* ..
+* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
-! ..
-!
-! Purpose
-! =======
-!
-! ILADLC scans A for its last non-zero column.
-!
-! Arguments
-! =========
-!
-! M (input) INTEGER
-! The number of rows of the matrix A.
-!
-! N (input) INTEGER
-! The number of columns of the matrix A.
-!
-! A (input) DOUBLE PRECISION array, dimension (LDA,N)
-! The m by n matrix A.
-!
-! LDA (input) INTEGER
-! The leading dimension of the array A. LDA >= max(1,M).
-!
-! =====================================================================
-!
-! .. Parameters ..
+* ..
+*
+* Purpose
+* =======
+*
+* ILADLC scans A for its last non-zero column.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The m by n matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* =====================================================================
+*
+* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
-! ..
-! .. Local Scalars ..
+* ..
+* .. Local Scalars ..
INTEGER I
-! ..
-! .. Executable Statements ..
-!
-! Quick test for the common case where one corner is non-zero.
- IF( N.EQ.0 .OR. A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
+* ..
+* .. 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.
+* 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
INTEGER FUNCTION ILADLR(M, N, A, LDA)
IMPLICIT NONE
-!
-! -- LAPACK auxiliary routine (version 3.2) --
-! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
-! December 2007
-!
-! .. Scalar Arguments ..
+*
+* -- LAPACK auxiliary routine (version 3.2) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* December 2007
+*
+* .. Scalar Arguments ..
INTEGER M, N, LDA
-! ..
-! .. Array Arguments ..
+* ..
+* .. Array Arguments ..
DOUBLE PRECISION A( LDA, * )
-! ..
-!
-! Purpose
-! =======
-!
-! ILADLR scans A for its last non-zero row.
-!
-! Arguments
-! =========
-!
-! M (input) INTEGER
-! The number of rows of the matrix A.
-!
-! N (input) INTEGER
-! The number of columns of the matrix A.
-!
-! A (input) DOUBLE PRECISION array, dimension (LDA,N)
-! The m by n matrix A.
-!
-! LDA (input) INTEGER
-! The leading dimension of the array A. LDA >= max(1,M).
-!
-! =====================================================================
-!
-! .. Parameters ..
+* ..
+*
+* Purpose
+* =======
+*
+* ILADLR scans A for its last non-zero row.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A.
+*
+* A (input) DOUBLE PRECISION array, dimension (LDA,N)
+* The m by n matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* =====================================================================
+*
+* .. Parameters ..
DOUBLE PRECISION ZERO
PARAMETER ( ZERO = 0.0D+0 )
-! ..
-! .. Local Scalars ..
+* ..
+* .. Local Scalars ..
INTEGER I, J
-! ..
-! .. Executable Statements ..
-!
-! Quick test for the common case where one corner is non-zero.
- IF( M.EQ.0 .OR. A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
+* ..
+* .. 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.
+* Scan up each column tracking the last zero row seen.
ILADLR = 0
DO J = 1, N
DO I = M, 1, -1
INTEGER FUNCTION ILASLC(M, N, A, LDA)
IMPLICIT NONE
-!
-! -- LAPACK auxiliary routine (version 3.2) --
-! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
-! December 2007
-!
-! .. Scalar Arguments ..
+*
+* -- LAPACK auxiliary routine (version 3.2) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* December 2007
+*
+* .. Scalar Arguments ..
INTEGER M, N, LDA
-! ..
-! .. Array Arguments ..
+* ..
+* .. Array Arguments ..
REAL A( LDA, * )
-! ..
-!
-! Purpose
-! =======
-!
-! ILASLC scans A for its last non-zero column.
-!
-! Arguments
-! =========
-!
-! M (input) INTEGER
-! The number of rows of the matrix A.
-!
-! N (input) INTEGER
-! The number of columns of the matrix A.
-!
-! A (input) REAL array, dimension (LDA,N)
-! The m by n matrix A.
-!
-! LDA (input) INTEGER
-! The leading dimension of the array A. LDA >= max(1,M).
-!
-! =====================================================================
-!
-! .. Parameters ..
+* ..
+*
+* Purpose
+* =======
+*
+* ILASLC scans A for its last non-zero column.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The m by n matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* =====================================================================
+*
+* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0D+0 )
-! ..
-! .. Local Scalars ..
+* ..
+* .. Local Scalars ..
INTEGER I
-! ..
-! .. Executable Statements ..
-!
-! Quick test for the common case where one corner is non-zero.
- IF( N.EQ.0 .OR. A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
+* ..
+* .. Executable Statements ..
+*
+* Quick test for the common case where one corner is non-zero.
+ IF( N.EQ.0 ) THEN
+ ILASLC = N
+ ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILASLC = N
ELSE
-! Now scan each column from the end, returning with the first non-zero.
+* Now scan each column from the end, returning with the first non-zero.
DO ILASLC = N, 1, -1
DO I = 1, M
IF( A(I, ILASLC).NE.ZERO ) RETURN
INTEGER FUNCTION ILASLR(M, N, A, LDA)
IMPLICIT NONE
-!
-! -- LAPACK auxiliary routine (version 3.2) --
-! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
-! December 2007
-!
-! .. Scalar Arguments ..
+*
+* -- LAPACK auxiliary routine (version 3.2) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* December 2007
+*
+* .. Scalar Arguments ..
INTEGER M, N, LDA
-! ..
-! .. Array Arguments ..
+* ..
+* .. Array Arguments ..
REAL A( LDA, * )
-! ..
-!
-! Purpose
-! =======
-!
-! ILASLR scans A for its last non-zero row.
-!
-! Arguments
-! =========
-!
-! M (input) INTEGER
-! The number of rows of the matrix A.
-!
-! N (input) INTEGER
-! The number of columns of the matrix A.
-!
-! A (input) REAL array, dimension (LDA,N)
-! The m by n matrix A.
-!
-! LDA (input) INTEGER
-! The leading dimension of the array A. LDA >= max(1,M).
-!
-! =====================================================================
-!
-! .. Parameters ..
+* ..
+*
+* Purpose
+* =======
+*
+* ILASLR scans A for its last non-zero row.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A.
+*
+* A (input) REAL array, dimension (LDA,N)
+* The m by n matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* =====================================================================
+*
+* .. Parameters ..
REAL ZERO
PARAMETER ( ZERO = 0.0E+0 )
-! ..
-! .. Local Scalars ..
+* ..
+* .. Local Scalars ..
INTEGER I, J
-! ..
-! .. Executable Statements ..
-!
-! Quick test for the common case where one corner is non-zero.
- IF( M.EQ.0 .OR. A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
+* ..
+* .. Executable Statements ..
+*
+* Quick test for the common case where one corner is non-zero.
+ IF( M.EQ.0 ) THEN
+ ILASLR = M
+ ELSEIF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILASLR = M
ELSE
-! Scan up each column tracking the last zero row seen.
+* Scan up each column tracking the last zero row seen.
ILASLR = 0
DO J = 1, N
DO I = M, 1, -1
INTEGER VERS_MAJOR, VERS_MINOR, VERS_PATCH
* =====================================================================
VERS_MAJOR = 3
- VERS_MINOR = 1
- VERS_PATCH = 1
+ VERS_MINOR = 2
+ VERS_PATCH = 0
* =====================================================================
*
RETURN
INTEGER FUNCTION ILAZLC(M, N, A, LDA)
IMPLICIT NONE
-!
-! -- LAPACK auxiliary routine (version 3.2) --
-! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
-! December 2007
-!
-! .. Scalar Arguments ..
+*
+* -- LAPACK auxiliary routine (version 3.2) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* December 2007
+*
+* .. Scalar Arguments ..
INTEGER M, N, LDA
-! ..
-! .. Array Arguments ..
+* ..
+* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
-! ..
-!
-! Purpose
-! =======
-!
-! ILAZLC scans A for its last non-zero column.
-!
-! Arguments
-! =========
-!
-! M (input) INTEGER
-! The number of rows of the matrix A.
-!
-! N (input) INTEGER
-! The number of columns of the matrix A.
-!
-! A (input) COMPLEX*16 array, dimension (LDA,N)
-! The m by n matrix A.
-!
-! LDA (input) INTEGER
-! The leading dimension of the array A. LDA >= max(1,M).
-!
-! =====================================================================
-!
-! .. Parameters ..
+* ..
+*
+* Purpose
+* =======
+*
+* ILAZLC scans A for its last non-zero column.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A.
+*
+* A (input) COMPLEX*16 array, dimension (LDA,N)
+* The m by n matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* =====================================================================
+*
+* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = (0.0D+0, 0.0D+0) )
-! ..
-! .. Local Scalars ..
+* ..
+* .. Local Scalars ..
INTEGER I
-! ..
-! .. Executable Statements ..
-!
-! Quick test for the common case where one corner is non-zero.
- IF( N.EQ.0 .OR. A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
+* ..
+* .. Executable Statements ..
+*
+* Quick test for the common case where one corner is non-zero.
+ IF( N.EQ.0 ) THEN
+ ILAZLC = N
+ ELSE IF( A(1, N).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILAZLC = N
ELSE
-! Now scan each column from the end, returning with the first non-zero.
+* Now scan each column from the end, returning with the first non-zero.
DO ILAZLC = N, 1, -1
DO I = 1, M
IF( A(I, ILAZLC).NE.ZERO ) RETURN
INTEGER FUNCTION ILAZLR(M, N, A, LDA)
IMPLICIT NONE
-!
-! -- LAPACK auxiliary routine (version 3.2) --
-! Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
-! December 2007
-!
-! .. Scalar Arguments ..
+*
+* -- LAPACK auxiliary routine (version 3.2) --
+* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
+* December 2007
+*
+* .. Scalar Arguments ..
INTEGER M, N, LDA
-! ..
-! .. Array Arguments ..
+* ..
+* .. Array Arguments ..
COMPLEX*16 A( LDA, * )
-! ..
-!
-! Purpose
-! =======
-!
-! ILAZLR scans A for its last non-zero row.
-!
-! Arguments
-! =========
-!
-! M (input) INTEGER
-! The number of rows of the matrix A.
-!
-! N (input) INTEGER
-! The number of columns of the matrix A.
-!
-! A (input) COMPLEX*16 array, dimension (LDA,N)
-! The m by n matrix A.
-!
-! LDA (input) INTEGER
-! The leading dimension of the array A. LDA >= max(1,M).
-!
-! =====================================================================
-!
-! .. Parameters ..
+* ..
+*
+* Purpose
+* =======
+*
+* ILAZLR scans A for its last non-zero row.
+*
+* Arguments
+* =========
+*
+* M (input) INTEGER
+* The number of rows of the matrix A.
+*
+* N (input) INTEGER
+* The number of columns of the matrix A.
+*
+* A (input) COMPLEX*16 array, dimension (LDA,N)
+* The m by n matrix A.
+*
+* LDA (input) INTEGER
+* The leading dimension of the array A. LDA >= max(1,M).
+*
+* =====================================================================
+*
+* .. Parameters ..
COMPLEX*16 ZERO
PARAMETER ( ZERO = (0.0D+0, 0.0D+0) )
-! ..
-! .. Local Scalars ..
+* ..
+* .. Local Scalars ..
INTEGER I, J
-! ..
-! .. Executable Statements ..
-!
-! Quick test for the common case where one corner is non-zero.
- IF( M.EQ.0 .OR. A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
+* ..
+* .. Executable Statements ..
+*
+* Quick test for the common case where one corner is non-zero.
+ IF( M.EQ.0 ) THEN
+ ILAZLR = M
+ ELSE IF( A(M, 1).NE.ZERO .OR. A(M, N).NE.ZERO ) THEN
ILAZLR = M
ELSE
-! Scan up each column tracking the last zero row seen.
+* Scan up each column tracking the last zero row seen.
ILAZLR = 0
DO J = 1, N
DO I = M, 1, -1
- SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA,
- & MV, V, LDV, WORK, LWORK, INFO )
+ SUBROUTINE SGESVJ( JOBA, JOBU, JOBV, M, N, A, LDA, SVA, MV, V,
+ + LDV, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.2) --
*
* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the
* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0.
*
-* -#- Scalar Arguments -#-
-*
- IMPLICIT NONE
- INTEGER INFO, LDA, LDV, LWORK, M, MV, N
- CHARACTER*1 JOBA, JOBU, JOBV
-*
-* -#- Array Arguments -#-
-*
- REAL A( LDA, * ), SVA( N ), V( LDV, * ), WORK( LWORK )
+ IMPLICIT NONE
+* ..
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDV, LWORK, M, MV, N
+ CHARACTER*1 JOBA, JOBU, JOBV
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), SVA( N ), V( LDV, * ),
+ + WORK( LWORK )
* ..
*
* Purpose
-* ~~~~~~~
+* =======
+*
* SGESVJ computes the singular value decomposition (SVD) of a real
* M-by-N matrix A, where M >= N. The SVD of A is written as
* [++] [xx] [x0] [xx]
* drmac@math.hr. Thank you.
*
* Arguments
-* ~~~~~~~~~
+* =========
*
* JOBA (input) CHARACTER* 1
* Specifies the structure of A.
* JOBU (input) CHARACTER*1
* Specifies whether to compute the left singular vectors
* (columns of U):
-*
* = 'U': The left singular vectors corresponding to the nonzero
* singular values are computed and returned in the leading
* columns of A. See more details in the description of A.
* On entry, the M-by-N matrix A.
* On exit,
* If JOBU .EQ. 'U' .OR. JOBU .EQ. 'C':
-* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
-* If INFO .EQ. 0,
-* ~~~~~~~~~~~~~~~
+* If INFO .EQ. 0 :
* RANKA orthonormal columns of U are returned in the
* leading RANKA columns of the array A. Here RANKA <= N
* is the number of computed singular values of A that are
* TOL=SQRT(M)*EPS (default); or TOL=CTOL*EPS (JOBU.EQ.'C'),
* see the description of JOBU.
* If INFO .GT. 0,
-* ~~~~~~~~~~~~~~~
* the procedure SGESVJ did not converge in the given number
* of iterations (sweeps). In that case, the computed
* columns of U may not be orthogonal up to TOL. The output
* values in SVA(1:N)) and V is still a decomposition of the
* input matrix A in the sense that the residual
* ||A-SCALE*U*SIGMA*V^T||_2 / ||A||_2 is small.
-*
* If JOBU .EQ. 'N':
-* ~~~~~~~~~~~~~~~~~
-* If INFO .EQ. 0
-* ~~~~~~~~~~~~~~
+* If INFO .EQ. 0 :
* Note that the left singular vectors are 'for free' in the
* one-sided Jacobi SVD algorithm. However, if only the
* singular values are needed, the level of numerical
* numerically orthogonal up to approximately M*EPS. Thus,
* on exit, A contains the columns of U scaled with the
* corresponding singular values.
-* If INFO .GT. 0,
-* ~~~~~~~~~~~~~~~
+* If INFO .GT. 0 :
* the procedure SGESVJ did not converge in the given number
* of iterations (sweeps).
*
*
* SVA (workspace/output) REAL array, dimension (N)
* On exit,
-* If INFO .EQ. 0,
-* ~~~~~~~~~~~~~~~
+* If INFO .EQ. 0 :
* depending on the value SCALE = WORK(1), we have:
* If SCALE .EQ. ONE:
-* ~~~~~~~~~~~~~~~~~~
* SVA(1:N) contains the computed singular values of A.
* During the computation SVA contains the Euclidean column
* norms of the iterated matrices in the array A.
* If SCALE .NE. ONE:
-* ~~~~~~~~~~~~~~~~~~
* The singular values of A are SCALE*SVA(1:N), and this
* factored representation is due to the fact that some of the
* singular values of A might underflow or overflow.
*
-* If INFO .GT. 0,
-* ~~~~~~~~~~~~~~~
+* If INFO .GT. 0 :
* the procedure SGESVJ did not converge in the given number of
* iterations (sweeps) and SCALE*SVA(1:N) may not be accurate.
*
*
* WORK (input/workspace/output) REAL array, dimension max(4,M+N).
* On entry,
-* If JOBU .EQ. 'C',
-* ~~~~~~~~~~~~~~~~~
+* If JOBU .EQ. 'C' :
* WORK(1) = CTOL, where CTOL defines the threshold for convergence.
* The process stops if all columns of A are mutually
* orthogonal up to CTOL*EPS, EPS=SLAMCH('E').
* > 0 : SGESVJ did not converge in the maximal allowed number (30)
* of sweeps. The output may still be useful. See the
* description of WORK.
+* =====================================================================
+*
+* .. Local Parameters ..
+ REAL ZERO, HALF, ONE, TWO
+ PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0,
+ + TWO = 2.0E0 )
+ INTEGER NSWEEP
+ PARAMETER ( NSWEEP = 30 )
+* ..
+* .. Local Scalars ..
+ REAL AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,
+ + BIGTHETA, CS, CTOL, EPSILON, LARGE, MXAAPQ,
+ + MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL,
+ + SCALE, SFMIN, SMALL, SN, T, TEMP1, THETA,
+ + THSIGN, TOL
+ INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,
+ + ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, N2, N34,
+ + N4, NBL, NOTROT, p, PSKIPPED, q, ROWSKIP,
+ + SWBAND
+ LOGICAL APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK,
+ + RSVEC, UCTOL, UPPER
+* ..
+* .. Local Arrays ..
+ REAL FASTR( 5 )
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, AMAX1, AMIN1, FLOAT, MIN0, SIGN, SQRT
+* ..
+* .. External Functions ..
+* from BLAS
+ REAL SDOT, SNRM2
+ EXTERNAL SDOT, SNRM2
+ INTEGER ISAMAX
+ EXTERNAL ISAMAX
+* from LAPACK
+ REAL SLAMCH
+ EXTERNAL SLAMCH
+ LOGICAL LSAME
+ EXTERNAL LSAME
+* ..
+* .. External Subroutines ..
+* from BLAS
+ EXTERNAL SAXPY, SCOPY, SROTM, SSCAL, SSWAP
+* from LAPACK
+ EXTERNAL SLASCL, SLASET, SLASSQ, XERBLA
*
-* Local Parameters
-*
- REAL ZERO, HALF, ONE, TWO
- PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0, TWO = 2.0E0 )
- INTEGER NSWEEP
- PARAMETER ( NSWEEP = 30 )
-*
-* Local Scalars
-*
- REAL AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP,
- & BIG, BIGTHETA, CS, CTOL, EPSILON, LARGE,
- & MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN, ROOTTOL,
- & SCALE, SFMIN, SMALL, SN, T, TEMP1,
- & THETA, THSIGN, TOL
- INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl,
- & IJBLSK, ir1, ISWROT, jbc, jgl, KBL,
- & LKAHEAD, MVL, N2, N34, N4, NBL,
- & NOTROT, p, PSKIPPED, q, ROWSKIP, SWBAND
- LOGICAL APPLV, GOSCALE, LOWER, LSVEC, NOSCALE, ROTOK,
- & RSVEC, UCTOL, UPPER
-*
-* Local Arrays
-*
- REAL FASTR(5)
-*
-* Intrinsic Functions
-*
- INTRINSIC ABS, AMAX1, AMIN1, FLOAT, MIN0, SIGN, SQRT
-*
-* External Functions
-* .. from BLAS
- REAL SDOT, SNRM2
- EXTERNAL SDOT, SNRM2
- INTEGER ISAMAX
- EXTERNAL ISAMAX
-* .. from LAPACK
- REAL SLAMCH
- EXTERNAL SLAMCH
- LOGICAL LSAME
- EXTERNAL LSAME
-*
-* External Subroutines
-* .. from BLAS
- EXTERNAL SAXPY, SCOPY, SROTM, SSCAL, SSWAP
-* .. from LAPACK
- EXTERNAL SLASCL, SLASET, SLASSQ, XERBLA
-*
- EXTERNAL SGSVJ0, SGSVJ1
+ EXTERNAL SGSVJ0, SGSVJ1
+* ..
+* .. Executable Statements ..
*
* Test the input arguments
*
UPPER = LSAME( JOBA, 'U' )
LOWER = LSAME( JOBA, 'L' )
*
- IF ( .NOT.( UPPER .OR. LOWER .OR. LSAME(JOBA,'G') ) ) THEN
- INFO = - 1
- ELSE IF ( .NOT.( LSVEC .OR. UCTOL .OR. LSAME(JOBU,'N') ) ) THEN
- INFO = - 2
- ELSE IF ( .NOT.( RSVEC .OR. APPLV .OR. LSAME(JOBV,'N') ) ) THEN
- INFO = - 3
- ELSE IF ( M .LT. 0 ) THEN
- INFO = - 4
- ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M ) ) THEN
- INFO = - 5
- ELSE IF ( LDA .LT. M ) THEN
- INFO = - 7
- ELSE IF ( MV .LT. 0 ) THEN
- INFO = - 9
- ELSE IF ( ( RSVEC .AND. (LDV .LT. N ) ) .OR.
- & ( APPLV .AND. (LDV .LT. MV) ) ) THEN
+ IF( .NOT.( UPPER .OR. LOWER .OR. LSAME( JOBA, 'G' ) ) ) THEN
+ INFO = -1
+ ELSE IF( .NOT.( LSVEC .OR. UCTOL .OR. LSAME( JOBU, 'N' ) ) ) THEN
+ INFO = -2
+ ELSE IF( .NOT.( RSVEC .OR. APPLV .OR. LSAME( JOBV, 'N' ) ) ) THEN
+ INFO = -3
+ ELSE IF( M.LT.0 ) THEN
+ INFO = -4
+ ELSE IF( ( N.LT.0 ) .OR. ( N.GT.M ) ) THEN
+ INFO = -5
+ ELSE IF( LDA.LT.M ) THEN
+ INFO = -7
+ ELSE IF( MV.LT.0 ) THEN
+ INFO = -9
+ ELSE IF( ( RSVEC .AND. ( LDV.LT.N ) ) .OR.
+ + ( APPLV .AND. ( LDV.LT.MV ) ) ) THEN
INFO = -11
- ELSE IF ( UCTOL .AND. (WORK(1) .LE. ONE) ) THEN
- INFO = - 12
- ELSE IF ( LWORK .LT. MAX0( M + N , 6 ) ) THEN
- INFO = - 13
+ ELSE IF( UCTOL .AND. ( WORK( 1 ).LE.ONE ) ) THEN
+ INFO = -12
+ ELSE IF( LWORK.LT.MAX0( M+N, 6 ) ) THEN
+ INFO = -13
ELSE
- INFO = 0
+ INFO = 0
END IF
*
* #:(
- IF ( INFO .NE. 0 ) THEN
+ IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGESVJ', -INFO )
RETURN
END IF
*
* #:) Quick return for void matrix
*
- IF ( ( M .EQ. 0 ) .OR. ( N .EQ. 0 ) ) RETURN
+ IF( ( M.EQ.0 ) .OR. ( N.EQ.0 ) )RETURN
*
* Set numerical parameters
* The stopping criterion for Jacobi rotations is
*
* where EPS is the round-off and CTOL is defined as follows:
*
- IF ( UCTOL ) THEN
+ IF( UCTOL ) THEN
* ... user controlled
- CTOL = WORK(1)
+ CTOL = WORK( 1 )
ELSE
* ... default
- IF ( LSVEC .OR. RSVEC .OR. APPLV ) THEN
- CTOL = SQRT(FLOAT(M))
+ IF( LSVEC .OR. RSVEC .OR. APPLV ) THEN
+ CTOL = SQRT( FLOAT( M ) )
ELSE
- CTOL = FLOAT(M)
+ CTOL = FLOAT( M )
END IF
END IF
* ... and the machine dependent parameters are
*[!] (Make sure that SLAMCH() works properly on the target machine.)
*
- EPSILON = SLAMCH('Epsilon')
- ROOTEPS = SQRT(EPSILON)
- SFMIN = SLAMCH('SafeMinimum')
- ROOTSFMIN = SQRT(SFMIN)
- SMALL = SFMIN / EPSILON
- BIG = SLAMCH('Overflow')
- ROOTBIG = ONE / ROOTSFMIN
- LARGE = BIG / SQRT(FLOAT(M*N))
- BIGTHETA = ONE / ROOTEPS
-*
- TOL = CTOL * EPSILON
- ROOTTOL = SQRT(TOL)
-*
- IF ( FLOAT(M)*EPSILON .GE. ONE ) THEN
- INFO = - 5
+ EPSILON = SLAMCH( 'Epsilon' )
+ ROOTEPS = SQRT( EPSILON )
+ SFMIN = SLAMCH( 'SafeMinimum' )
+ ROOTSFMIN = SQRT( SFMIN )
+ SMALL = SFMIN / EPSILON
+ BIG = SLAMCH( 'Overflow' )
+ ROOTBIG = ONE / ROOTSFMIN
+ LARGE = BIG / SQRT( FLOAT( M*N ) )
+ BIGTHETA = ONE / ROOTEPS
+*
+ TOL = CTOL*EPSILON
+ ROOTTOL = SQRT( TOL )
+*
+ IF( FLOAT( M )*EPSILON.GE.ONE ) THEN
+ INFO = -5
CALL XERBLA( 'SGESVJ', -INFO )
RETURN
END IF
*
* Initialize the right singular vector matrix.
*
- IF ( RSVEC ) THEN
+ IF( RSVEC ) THEN
MVL = N
CALL SLASET( 'A', MVL, N, ZERO, ONE, V, LDV )
- ELSE IF ( APPLV ) THEN
+ ELSE IF( APPLV ) THEN
MVL = MV
END IF
RSVEC = RSVEC .OR. APPLV
* SQRT(N)*max_i SVA(i) does not overflow. If INFinite entries
* in A are detected, the procedure returns with INFO=-6.
*
- SCALE = ONE / SQRT(FLOAT(M)*FLOAT(N))
- NOSCALE = .TRUE.
- GOSCALE = .TRUE.
+ SCALE = ONE / SQRT( FLOAT( M )*FLOAT( N ) )
+ NOSCALE = .TRUE.
+ GOSCALE = .TRUE.
*
- IF ( LOWER ) THEN
+ IF( LOWER ) THEN
* the input matrix is M-by-N lower triangular (trapezoidal)
DO 1874 p = 1, N
AAPP = ZERO
AAQQ = ZERO
- CALL SLASSQ( M-p+1, A(p,p), 1, AAPP, AAQQ )
- IF ( AAPP .GT. BIG ) THEN
- INFO = - 6
+ CALL SLASSQ( M-p+1, A( p, p ), 1, AAPP, AAQQ )
+ IF( AAPP.GT.BIG ) THEN
+ INFO = -6
CALL XERBLA( 'SGESVJ', -INFO )
RETURN
END IF
- AAQQ = SQRT(AAQQ)
- IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCALE ) THEN
- SVA(p) = AAPP * AAQQ
+ AAQQ = SQRT( AAQQ )
+ IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN
+ SVA( p ) = AAPP*AAQQ
ELSE
NOSCALE = .FALSE.
- SVA(p) = AAPP * ( AAQQ * SCALE )
- IF ( GOSCALE ) THEN
+ SVA( p ) = AAPP*( AAQQ*SCALE )
+ IF( GOSCALE ) THEN
GOSCALE = .FALSE.
DO 1873 q = 1, p - 1
- SVA(q) = SVA(q)*SCALE
+ SVA( q ) = SVA( q )*SCALE
1873 CONTINUE
END IF
END IF
1874 CONTINUE
- ELSE IF ( UPPER ) THEN
+ ELSE IF( UPPER ) THEN
* the input matrix is M-by-N upper triangular (trapezoidal)
DO 2874 p = 1, N
AAPP = ZERO
AAQQ = ZERO
- CALL SLASSQ( p, A(1,p), 1, AAPP, AAQQ )
- IF ( AAPP .GT. BIG ) THEN
- INFO = - 6
+ CALL SLASSQ( p, A( 1, p ), 1, AAPP, AAQQ )
+ IF( AAPP.GT.BIG ) THEN
+ INFO = -6
CALL XERBLA( 'SGESVJ', -INFO )
RETURN
END IF
- AAQQ = SQRT(AAQQ)
- IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCALE ) THEN
- SVA(p) = AAPP * AAQQ
+ AAQQ = SQRT( AAQQ )
+ IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN
+ SVA( p ) = AAPP*AAQQ
ELSE
NOSCALE = .FALSE.
- SVA(p) = AAPP * ( AAQQ * SCALE )
- IF ( GOSCALE ) THEN
+ SVA( p ) = AAPP*( AAQQ*SCALE )
+ IF( GOSCALE ) THEN
GOSCALE = .FALSE.
DO 2873 q = 1, p - 1
- SVA(q) = SVA(q)*SCALE
+ SVA( q ) = SVA( q )*SCALE
2873 CONTINUE
END IF
END IF
DO 3874 p = 1, N
AAPP = ZERO
AAQQ = ZERO
- CALL SLASSQ( M, A(1,p), 1, AAPP, AAQQ )
- IF ( AAPP .GT. BIG ) THEN
- INFO = - 6
+ CALL SLASSQ( M, A( 1, p ), 1, AAPP, AAQQ )
+ IF( AAPP.GT.BIG ) THEN
+ INFO = -6
CALL XERBLA( 'SGESVJ', -INFO )
RETURN
END IF
- AAQQ = SQRT(AAQQ)
- IF ( ( AAPP .LT. (BIG / AAQQ) ) .AND. NOSCALE ) THEN
- SVA(p) = AAPP * AAQQ
+ AAQQ = SQRT( AAQQ )
+ IF( ( AAPP.LT.( BIG / AAQQ ) ) .AND. NOSCALE ) THEN
+ SVA( p ) = AAPP*AAQQ
ELSE
NOSCALE = .FALSE.
- SVA(p) = AAPP * ( AAQQ * SCALE )
- IF ( GOSCALE ) THEN
+ SVA( p ) = AAPP*( AAQQ*SCALE )
+ IF( GOSCALE ) THEN
GOSCALE = .FALSE.
DO 3873 q = 1, p - 1
- SVA(q) = SVA(q)*SCALE
+ SVA( q ) = SVA( q )*SCALE
3873 CONTINUE
END IF
END IF
3874 CONTINUE
END IF
*
- IF ( NOSCALE ) SCALE = ONE
+ IF( NOSCALE )SCALE = ONE
*
* Move the smaller part of the spectrum from the underflow threshold
*(!) Start by determining the position of the nonzero entries of the
AAPP = ZERO
AAQQ = BIG
DO 4781 p = 1, N
- IF ( SVA(p) .NE. ZERO ) AAQQ = AMIN1( AAQQ, SVA(p) )
- AAPP = AMAX1( AAPP, SVA(p) )
+ IF( SVA( p ).NE.ZERO )AAQQ = AMIN1( AAQQ, SVA( p ) )
+ AAPP = AMAX1( AAPP, SVA( p ) )
4781 CONTINUE
*
* #:) Quick return for zero matrix
*
- IF ( AAPP .EQ. ZERO ) THEN
- IF ( LSVEC ) CALL SLASET( 'G', M, N, ZERO, ONE, A, LDA )
- WORK(1) = ONE
- WORK(2) = ZERO
- WORK(3) = ZERO
- WORK(4) = ZERO
- WORK(5) = ZERO
- WORK(6) = ZERO
+ IF( AAPP.EQ.ZERO ) THEN
+ IF( LSVEC )CALL SLASET( 'G', M, N, ZERO, ONE, A, LDA )
+ WORK( 1 ) = ONE
+ WORK( 2 ) = ZERO
+ WORK( 3 ) = ZERO
+ WORK( 4 ) = ZERO
+ WORK( 5 ) = ZERO
+ WORK( 6 ) = ZERO
RETURN
END IF
*
* #:) Quick return for one-column matrix
*
- IF ( N .EQ. 1 ) THEN
- IF ( LSVEC )
- & CALL SLASCL( 'G',0,0,SVA(1),SCALE,M,1,A(1,1),LDA,IERR )
- WORK(1) = ONE / SCALE
- IF ( SVA(1) .GE. SFMIN ) THEN
- WORK(2) = ONE
+ IF( N.EQ.1 ) THEN
+ IF( LSVEC )CALL SLASCL( 'G', 0, 0, SVA( 1 ), SCALE, M, 1,
+ + A( 1, 1 ), LDA, IERR )
+ WORK( 1 ) = ONE / SCALE
+ IF( SVA( 1 ).GE.SFMIN ) THEN
+ WORK( 2 ) = ONE
ELSE
- WORK(2) = ZERO
+ WORK( 2 ) = ZERO
END IF
- WORK(3) = ZERO
- WORK(4) = ZERO
- WORK(5) = ZERO
- WORK(6) = ZERO
+ WORK( 3 ) = ZERO
+ WORK( 4 ) = ZERO
+ WORK( 5 ) = ZERO
+ WORK( 6 ) = ZERO
RETURN
END IF
*
* Protect small singular values from underflow, and try to
* avoid underflows/overflows in computing Jacobi rotations.
*
- SN = SQRT( SFMIN / EPSILON )
- TEMP1 = SQRT( BIG / FLOAT(N) )
- IF ( (AAPP.LE.SN).OR.(AAQQ.GE.TEMP1)
- & .OR.((SN.LE.AAQQ).AND.(AAPP.LE.TEMP1)) ) THEN
- TEMP1 = AMIN1(BIG,TEMP1/AAPP)
+ SN = SQRT( SFMIN / EPSILON )
+ TEMP1 = SQRT( BIG / FLOAT( N ) )
+ IF( ( AAPP.LE.SN ) .OR. ( AAQQ.GE.TEMP1 ) .OR.
+ + ( ( SN.LE.AAQQ ) .AND. ( AAPP.LE.TEMP1 ) ) ) THEN
+ TEMP1 = AMIN1( BIG, TEMP1 / AAPP )
* AAQQ = AAQQ*TEMP1
* AAPP = AAPP*TEMP1
- ELSE IF ( (AAQQ.LE.SN).AND.(AAPP.LE.TEMP1) ) THEN
- TEMP1 = AMIN1( SN / AAQQ, BIG/(AAPP*SQRT(FLOAT(N))) )
+ ELSE IF( ( AAQQ.LE.SN ) .AND. ( AAPP.LE.TEMP1 ) ) THEN
+ TEMP1 = AMIN1( SN / AAQQ, BIG / ( AAPP*SQRT( FLOAT( N ) ) ) )
* AAQQ = AAQQ*TEMP1
* AAPP = AAPP*TEMP1
- ELSE IF ( (AAQQ.GE.SN).AND.(AAPP.GE.TEMP1) ) THEN
+ ELSE IF( ( AAQQ.GE.SN ) .AND. ( AAPP.GE.TEMP1 ) ) THEN
TEMP1 = AMAX1( SN / AAQQ, TEMP1 / AAPP )
* AAQQ = AAQQ*TEMP1
* AAPP = AAPP*TEMP1
- ELSE IF ( (AAQQ.LE.SN).AND.(AAPP.GE.TEMP1) ) THEN
- TEMP1 = AMIN1( SN / AAQQ, BIG / (SQRT(FLOAT(N))*AAPP))
+ ELSE IF( ( AAQQ.LE.SN ) .AND. ( AAPP.GE.TEMP1 ) ) THEN
+ TEMP1 = AMIN1( SN / AAQQ, BIG / ( SQRT( FLOAT( N ) )*AAPP ) )
* AAQQ = AAQQ*TEMP1
* AAPP = AAPP*TEMP1
ELSE
*
* Scale, if necessary
*
- IF ( TEMP1 .NE. ONE ) THEN
+ IF( TEMP1.NE.ONE ) THEN
CALL SLASCL( 'G', 0, 0, ONE, TEMP1, N, 1, SVA, N, IERR )
END IF
- SCALE = TEMP1 * SCALE
- IF ( SCALE .NE. ONE ) THEN
+ SCALE = TEMP1*SCALE
+ IF( SCALE.NE.ONE ) THEN
CALL SLASCL( JOBA, 0, 0, ONE, SCALE, M, N, A, LDA, IERR )
SCALE = ONE / SCALE
END IF
*
* Row-cyclic Jacobi SVD algorithm with column pivoting
*
- EMPTSW = ( N * ( N - 1 ) ) / 2
- NOTROT = 0
- FASTR(1) = ZERO
+ EMPTSW = ( N*( N-1 ) ) / 2
+ NOTROT = 0
+ FASTR( 1 ) = ZERO
*
* A is represented in factored form A = A * diag(WORK), where diag(WORK)
* is initialized to identity. WORK is updated during fast scaled
* rotations.
*
DO 1868 q = 1, N
- WORK(q) = ONE
+ WORK( q ) = ONE
1868 CONTINUE
*
*
* parameters of the computer's memory.
*
NBL = N / KBL
- IF ( ( NBL * KBL ) .NE. N ) NBL = NBL + 1
+ IF( ( NBL*KBL ).NE.N )NBL = NBL + 1
*
BLSKIP = KBL**2
*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL.
* invokes cubic convergence. Big part of this cycle is done inside
* canonical subspaces of dimensions less than M.
*
- IF ( (LOWER .OR. UPPER) .AND. (N .GT. MAX0(64, 4*KBL)) ) THEN
+ IF( ( LOWER .OR. UPPER ) .AND. ( N.GT.MAX0( 64, 4*KBL ) ) ) THEN
*[TP] The number of partition levels and the actual partition are
* tuning parameters.
- N4 = N / 4
- N2 = N / 2
- N34 = 3 * N4
- IF ( APPLV ) THEN
- q = 0
- ELSE
- q = 1
- END IF
+ N4 = N / 4
+ N2 = N / 2
+ N34 = 3*N4
+ IF( APPLV ) THEN
+ q = 0
+ ELSE
+ q = 1
+ END IF
*
- IF ( LOWER ) THEN
+ IF( LOWER ) THEN
*
* This works very well on lower triangular matrices, in particular
* in the framework of the preconditioned Jacobi SVD (xGEJSV).
* [+ + x 0] actually work on [x 0] [x 0]
* [+ + x x] [x x]. [x x]
*
- CALL SGSVJ0(JOBV,M-N34,N-N34,A(N34+1,N34+1),LDA,WORK(N34+1),
- & SVA(N34+1),MVL,V(N34*q+1,N34+1),LDV,EPSILON,SFMIN,TOL,2,
- & WORK(N+1),LWORK-N,IERR )
+ CALL SGSVJ0( JOBV, M-N34, N-N34, A( N34+1, N34+1 ), LDA,
+ + WORK( N34+1 ), SVA( N34+1 ), MVL,
+ + V( N34*q+1, N34+1 ), LDV, EPSILON, SFMIN, TOL,
+ + 2, WORK( N+1 ), LWORK-N, IERR )
*
- CALL SGSVJ0( JOBV,M-N2,N34-N2,A(N2+1,N2+1),LDA,WORK(N2+1),
- & SVA(N2+1),MVL,V(N2*q+1,N2+1),LDV,EPSILON,SFMIN,TOL,2,
- & WORK(N+1),LWORK-N,IERR )
+ CALL SGSVJ0( JOBV, M-N2, N34-N2, A( N2+1, N2+1 ), LDA,
+ + WORK( N2+1 ), SVA( N2+1 ), MVL,
+ + V( N2*q+1, N2+1 ), LDV, EPSILON, SFMIN, TOL, 2,
+ + WORK( N+1 ), LWORK-N, IERR )
*
- CALL SGSVJ1( JOBV,M-N2,N-N2,N4,A(N2+1,N2+1),LDA,WORK(N2+1),
- & SVA(N2+1),MVL,V(N2*q+1,N2+1),LDV,EPSILON,SFMIN,TOL,1,
- & WORK(N+1),LWORK-N,IERR )
+ CALL SGSVJ1( JOBV, M-N2, N-N2, N4, A( N2+1, N2+1 ), LDA,
+ + WORK( N2+1 ), SVA( N2+1 ), MVL,
+ + V( N2*q+1, N2+1 ), LDV, EPSILON, SFMIN, TOL, 1,
+ + WORK( N+1 ), LWORK-N, IERR )
*
- CALL SGSVJ0( JOBV,M-N4,N2-N4,A(N4+1,N4+1),LDA,WORK(N4+1),
- & SVA(N4+1),MVL,V(N4*q+1,N4+1),LDV,EPSILON,SFMIN,TOL,1,
- & WORK(N+1),LWORK-N,IERR )
+ CALL SGSVJ0( JOBV, M-N4, N2-N4, A( N4+1, N4+1 ), LDA,
+ + WORK( N4+1 ), SVA( N4+1 ), MVL,
+ + V( N4*q+1, N4+1 ), LDV, EPSILON, SFMIN, TOL, 1,
+ + WORK( N+1 ), LWORK-N, IERR )
*
- CALL SGSVJ0( JOBV,M,N4,A,LDA,WORK,SVA,MVL,V,LDV,EPSILON,
- & SFMIN,TOL,1,WORK(N+1),LWORK-N,IERR )
+ CALL SGSVJ0( JOBV, M, N4, A, LDA, WORK, SVA, MVL, V, LDV,
+ + EPSILON, SFMIN, TOL, 1, WORK( N+1 ), LWORK-N,
+ + IERR )
*
- CALL SGSVJ1( JOBV,M,N2,N4,A,LDA,WORK,SVA,MVL,V,LDV,EPSILON,
- & SFMIN,TOL,1,WORK(N+1),LWORK-N,IERR )
+ CALL SGSVJ1( JOBV, M, N2, N4, A, LDA, WORK, SVA, MVL, V,
+ + LDV, EPSILON, SFMIN, TOL, 1, WORK( N+1 ),
+ + LWORK-N, IERR )
*
*
- ELSE IF ( UPPER ) THEN
+ ELSE IF( UPPER ) THEN
*
*
- CALL SGSVJ0( JOBV,N4,N4,A,LDA,WORK,SVA,MVL,V,LDV,EPSILON,
- & SFMIN,TOL,2,WORK(N+1),LWORK-N,IERR )
+ CALL SGSVJ0( JOBV, N4, N4, A, LDA, WORK, SVA, MVL, V, LDV,
+ + EPSILON, SFMIN, TOL, 2, WORK( N+1 ), LWORK-N,
+ + IERR )
*
- CALL SGSVJ0(JOBV,N2,N4,A(1,N4+1),LDA,WORK(N4+1),SVA(N4+1),MVL,
- & V(N4*q+1,N4+1),LDV,EPSILON,SFMIN,TOL,1,WORK(N+1),LWORK-N,
- & IERR )
+ CALL SGSVJ0( JOBV, N2, N4, A( 1, N4+1 ), LDA, WORK( N4+1 ),
+ + SVA( N4+1 ), MVL, V( N4*q+1, N4+1 ), LDV,
+ + EPSILON, SFMIN, TOL, 1, WORK( N+1 ), LWORK-N,
+ + IERR )
*
- CALL SGSVJ1( JOBV,N2,N2,N4,A,LDA,WORK,SVA,MVL,V,LDV,EPSILON,
- & SFMIN,TOL,1,WORK(N+1),LWORK-N,IERR )
+ CALL SGSVJ1( JOBV, N2, N2, N4, A, LDA, WORK, SVA, MVL, V,
+ + LDV, EPSILON, SFMIN, TOL, 1, WORK( N+1 ),
+ + LWORK-N, IERR )
*
- CALL SGSVJ0( JOBV,N2+N4,N4,A(1,N2+1),LDA,WORK(N2+1),SVA(N2+1),MVL,
- & V(N2*q+1,N2+1),LDV,EPSILON,SFMIN,TOL,1,
- & WORK(N+1),LWORK-N,IERR )
+ CALL SGSVJ0( JOBV, N2+N4, N4, A( 1, N2+1 ), LDA,
+ + WORK( N2+1 ), SVA( N2+1 ), MVL,
+ + V( N2*q+1, N2+1 ), LDV, EPSILON, SFMIN, TOL, 1,
+ + WORK( N+1 ), LWORK-N, IERR )
- END IF
+ END IF
*
END IF
*
-* -#- Row-cyclic pivot strategy with de Rijk's pivoting -#-
+* .. Row-cyclic pivot strategy with de Rijk's pivoting ..
*
DO 1993 i = 1, NSWEEP
* .. go go go ...
*
- MXAAPQ = ZERO
- MXSINJ = ZERO
- ISWROT = 0
+ MXAAPQ = ZERO
+ MXSINJ = ZERO
+ ISWROT = 0
*
- NOTROT = 0
- PSKIPPED = 0
+ NOTROT = 0
+ PSKIPPED = 0
*
* Each sweep is unrolled using KBL-by-KBL tiles over the pivot pairs
* 1 <= p < q <= N. This is the first step toward a blocked implementation
* of the rotations. New implementation, based on block transformations,
* is under development.
*
- DO 2000 ibr = 1, NBL
+ DO 2000 ibr = 1, NBL
*
- igl = ( ibr - 1 ) * KBL + 1
+ igl = ( ibr-1 )*KBL + 1
*
- DO 1002 ir1 = 0, MIN0( LKAHEAD, NBL - ibr )
+ DO 1002 ir1 = 0, MIN0( LKAHEAD, NBL-ibr )
*
- igl = igl + ir1 * KBL
+ igl = igl + ir1*KBL
*
- DO 2001 p = igl, MIN0( igl + KBL - 1, N - 1)
+ DO 2001 p = igl, MIN0( igl+KBL-1, N-1 )
*
* .. de Rijk's pivoting
*
- q = ISAMAX( N-p+1, SVA(p), 1 ) + p - 1
- IF ( p .NE. q ) THEN
- CALL SSWAP( M, A(1,p), 1, A(1,q), 1 )
- IF ( RSVEC ) CALL SSWAP( MVL, V(1,p), 1, V(1,q), 1 )
- TEMP1 = SVA(p)
- SVA(p) = SVA(q)
- SVA(q) = TEMP1
- TEMP1 = WORK(p)
- WORK(p) = WORK(q)
- WORK(q) = TEMP1
- END IF
-*
- IF ( ir1 .EQ. 0 ) THEN
+ q = ISAMAX( N-p+1, SVA( p ), 1 ) + p - 1
+ IF( p.NE.q ) THEN
+ CALL SSWAP( M, A( 1, p ), 1, A( 1, q ), 1 )
+ IF( RSVEC )CALL SSWAP( MVL, V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ TEMP1 = SVA( p )
+ SVA( p ) = SVA( q )
+ SVA( q ) = TEMP1
+ TEMP1 = WORK( p )
+ WORK( p ) = WORK( q )
+ WORK( q ) = TEMP1
+ END IF
+*
+ IF( ir1.EQ.0 ) THEN
*
* Column norms are periodically updated by explicit
* norm computation.
* If properly implemented SNRM2 is available, the IF-THEN-ELSE
* below should read "AAPP = SNRM2( M, A(1,p), 1 ) * WORK(p)".
*
- IF ((SVA(p) .LT. ROOTBIG) .AND. (SVA(p) .GT. ROOTSFMIN)) THEN
- SVA(p) = SNRM2( M, A(1,p), 1 ) * WORK(p)
- ELSE
- TEMP1 = ZERO
- AAPP = ZERO
- CALL SLASSQ( M, A(1,p), 1, TEMP1, AAPP )
- SVA(p) = TEMP1 * SQRT(AAPP) * WORK(p)
- END IF
- AAPP = SVA(p)
- ELSE
- AAPP = SVA(p)
- END IF
-*
- IF ( AAPP .GT. ZERO ) THEN
-*
- PSKIPPED = 0
-*
- DO 2002 q = p + 1, MIN0( igl + KBL - 1, N )
-*
- AAQQ = SVA(q)
-*
- IF ( AAQQ .GT. ZERO ) THEN
-*
- AAPP0 = AAPP
- IF ( AAQQ .GE. ONE ) THEN
- ROTOK = ( SMALL*AAPP ) .LE. AAQQ
- IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN
- AAPQ = ( SDOT(M, A(1,p), 1, A(1,q), 1 ) *
- & WORK(p) * WORK(q) / AAQQ ) / AAPP
- ELSE
- CALL SCOPY( M, A(1,p), 1, WORK(N+1), 1 )
- CALL SLASCL( 'G', 0, 0, AAPP, WORK(p), M,
- & 1, WORK(N+1), LDA, IERR )
- AAPQ = SDOT( M, WORK(N+1),1, A(1,q),1 )*WORK(q) / AAQQ
- END IF
- ELSE
- ROTOK = AAPP .LE. ( AAQQ / SMALL )
- IF ( AAPP .GT. ( SMALL / AAQQ ) ) THEN
- AAPQ = ( SDOT( M, A(1,p), 1, A(1,q), 1 ) *
- & WORK(p) * WORK(q) / AAQQ ) / AAPP
- ELSE
- CALL SCOPY( M, A(1,q), 1, WORK(N+1), 1 )
- CALL SLASCL( 'G', 0, 0, AAQQ, WORK(q), M,
- & 1, WORK(N+1), LDA, IERR )
- AAPQ = SDOT( M, WORK(N+1),1, A(1,p),1 )*WORK(p) / AAPP
- END IF
- END IF
+ IF( ( SVA( p ).LT.ROOTBIG ) .AND.
+ + ( SVA( p ).GT.ROOTSFMIN ) ) THEN
+ SVA( p ) = SNRM2( M, A( 1, p ), 1 )*WORK( p )
+ ELSE
+ TEMP1 = ZERO
+ AAPP = ZERO
+ CALL SLASSQ( M, A( 1, p ), 1, TEMP1, AAPP )
+ SVA( p ) = TEMP1*SQRT( AAPP )*WORK( p )
+ END IF
+ AAPP = SVA( p )
+ ELSE
+ AAPP = SVA( p )
+ END IF
+*
+ IF( AAPP.GT.ZERO ) THEN
+*
+ PSKIPPED = 0
+*
+ DO 2002 q = p + 1, MIN0( igl+KBL-1, N )
+*
+ AAQQ = SVA( q )
+*
+ IF( AAQQ.GT.ZERO ) THEN
+*
+ AAPP0 = AAPP
+ IF( AAQQ.GE.ONE ) THEN
+ ROTOK = ( SMALL*AAPP ).LE.AAQQ
+ IF( AAPP.LT.( BIG / AAQQ ) ) THEN
+ AAPQ = ( SDOT( M, A( 1, p ), 1, A( 1,
+ + q ), 1 )*WORK( p )*WORK( q ) /
+ + AAQQ ) / AAPP
+ ELSE
+ CALL SCOPY( M, A( 1, p ), 1,
+ + WORK( N+1 ), 1 )
+ CALL SLASCL( 'G', 0, 0, AAPP,
+ + WORK( p ), M, 1,
+ + WORK( N+1 ), LDA, IERR )
+ AAPQ = SDOT( M, WORK( N+1 ), 1,
+ + A( 1, q ), 1 )*WORK( q ) / AAQQ
+ END IF
+ ELSE
+ ROTOK = AAPP.LE.( AAQQ / SMALL )
+ IF( AAPP.GT.( SMALL / AAQQ ) ) THEN
+ AAPQ = ( SDOT( M, A( 1, p ), 1, A( 1,
+ + q ), 1 )*WORK( p )*WORK( q ) /
+ + AAQQ ) / AAPP
+ ELSE
+ CALL SCOPY( M, A( 1, q ), 1,
+ + WORK( N+1 ), 1 )
+ CALL SLASCL( 'G', 0, 0, AAQQ,
+ + WORK( q ), M, 1,
+ + WORK( N+1 ), LDA, IERR )
+ AAPQ = SDOT( M, WORK( N+1 ), 1,
+ + A( 1, p ), 1 )*WORK( p ) / AAPP
+ END IF
+ END IF
*
- MXAAPQ = AMAX1( MXAAPQ, ABS(AAPQ) )
+ MXAAPQ = AMAX1( MXAAPQ, ABS( AAPQ ) )
*
* TO rotate or NOT to rotate, THAT is the question ...
*
- IF ( ABS( AAPQ ) .GT. TOL ) THEN
+ IF( ABS( AAPQ ).GT.TOL ) THEN
*
* .. rotate
*[RTD] ROTATED = ROTATED + ONE
*
- IF ( ir1 .EQ. 0 ) THEN
- NOTROT = 0
- PSKIPPED = 0
- ISWROT = ISWROT + 1
- END IF
-*
- IF ( ROTOK ) THEN
-*
- AQOAP = AAQQ / AAPP
- APOAQ = AAPP / AAQQ
- THETA = - HALF * ABS( AQOAP - APOAQ ) / AAPQ
-*
- IF ( ABS( THETA ) .GT. BIGTHETA ) THEN
-*
- T = HALF / THETA
- FASTR(3) = T * WORK(p) / WORK(q)
- FASTR(4) = - T * WORK(q) / WORK(p)
- CALL SROTM( M, A(1,p), 1, A(1,q), 1, FASTR )
- IF ( RSVEC )
- & CALL SROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR )
- SVA(q) = AAQQ*SQRT( AMAX1(ZERO,ONE + T*APOAQ*AAPQ) )
- AAPP = AAPP*SQRT( ONE - T*AQOAP*AAPQ )
- MXSINJ = AMAX1( MXSINJ, ABS(T) )
-*
- ELSE
+ IF( ir1.EQ.0 ) THEN
+ NOTROT = 0
+ PSKIPPED = 0
+ ISWROT = ISWROT + 1
+ END IF
+*
+ IF( ROTOK ) THEN
+*
+ AQOAP = AAQQ / AAPP
+ APOAQ = AAPP / AAQQ
+ THETA = -HALF*ABS( AQOAP-APOAQ ) / AAPQ
+*
+ IF( ABS( THETA ).GT.BIGTHETA ) THEN
+*
+ T = HALF / THETA
+ FASTR( 3 ) = T*WORK( p ) / WORK( q )
+ FASTR( 4 ) = -T*WORK( q ) /
+ + WORK( p )
+ CALL SROTM( M, A( 1, p ), 1,
+ + A( 1, q ), 1, FASTR )
+ IF( RSVEC )CALL SROTM( MVL,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1,
+ + FASTR )
+ SVA( q ) = AAQQ*SQRT( AMAX1( ZERO,
+ + ONE+T*APOAQ*AAPQ ) )
+ AAPP = AAPP*SQRT( ONE-T*AQOAP*AAPQ )
+ MXSINJ = AMAX1( MXSINJ, ABS( T ) )
+*
+ ELSE
*
* .. choose correct signum for THETA and rotate
*
- THSIGN = - SIGN(ONE,AAPQ)
- T = ONE / ( THETA + THSIGN*SQRT(ONE+THETA*THETA) )
- CS = SQRT( ONE / ( ONE + T*T ) )
- SN = T * CS
-*
- MXSINJ = AMAX1( MXSINJ, ABS(SN) )
- SVA(q) = AAQQ*SQRT( AMAX1(ZERO, ONE+T*APOAQ*AAPQ) )
- AAPP = AAPP*SQRT( AMAX1(ZERO, ONE-T*AQOAP*AAPQ) )
-*
- APOAQ = WORK(p) / WORK(q)
- AQOAP = WORK(q) / WORK(p)
- IF ( WORK(p) .GE. ONE ) THEN
- IF ( WORK(q) .GE. ONE ) THEN
- FASTR(3) = T * APOAQ
- FASTR(4) = - T * AQOAP
- WORK(p) = WORK(p) * CS
- WORK(q) = WORK(q) * CS
- CALL SROTM( M, A(1,p),1, A(1,q),1, FASTR )
- IF ( RSVEC )
- & CALL SROTM( MVL, V(1,p),1, V(1,q),1, FASTR )
- ELSE
- CALL SAXPY( M, -T*AQOAP, A(1,q),1, A(1,p),1 )
- CALL SAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 )
- WORK(p) = WORK(p) * CS
- WORK(q) = WORK(q) / CS
- IF ( RSVEC ) THEN
- CALL SAXPY(MVL, -T*AQOAP, V(1,q),1,V(1,p),1)
- CALL SAXPY(MVL,CS*SN*APOAQ, V(1,p),1,V(1,q),1)
- END IF
- END IF
- ELSE
- IF ( WORK(q) .GE. ONE ) THEN
- CALL SAXPY( M, T*APOAQ, A(1,p),1, A(1,q),1 )
- CALL SAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 )
- WORK(p) = WORK(p) / CS
- WORK(q) = WORK(q) * CS
- IF ( RSVEC ) THEN
- CALL SAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1)
- CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1)
- END IF
- ELSE
- IF ( WORK(p) .GE. WORK(q) ) THEN
- CALL SAXPY( M,-T*AQOAP, A(1,q),1,A(1,p),1 )
- CALL SAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 )
- WORK(p) = WORK(p) * CS
- WORK(q) = WORK(q) / CS
- IF ( RSVEC ) THEN
- CALL SAXPY(MVL, -T*AQOAP, V(1,q),1,V(1,p),1)
- CALL SAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1)
- END IF
- ELSE
- CALL SAXPY( M, T*APOAQ, A(1,p),1,A(1,q),1)
- CALL SAXPY( M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1)
- WORK(p) = WORK(p) / CS
- WORK(q) = WORK(q) * CS
- IF ( RSVEC ) THEN
- CALL SAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1)
- CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1)
- END IF
- END IF
- END IF
- ENDIF
- END IF
-*
- ELSE
+ THSIGN = -SIGN( ONE, AAPQ )
+ T = ONE / ( THETA+THSIGN*
+ + SQRT( ONE+THETA*THETA ) )
+ CS = SQRT( ONE / ( ONE+T*T ) )
+ SN = T*CS
+*
+ MXSINJ = AMAX1( MXSINJ, ABS( SN ) )
+ SVA( q ) = AAQQ*SQRT( AMAX1( ZERO,
+ + ONE+T*APOAQ*AAPQ ) )
+ AAPP = AAPP*SQRT( AMAX1( ZERO,
+ + ONE-T*AQOAP*AAPQ ) )
+*
+ APOAQ = WORK( p ) / WORK( q )
+ AQOAP = WORK( q ) / WORK( p )
+ IF( WORK( p ).GE.ONE ) THEN
+ IF( WORK( q ).GE.ONE ) THEN
+ FASTR( 3 ) = T*APOAQ
+ FASTR( 4 ) = -T*AQOAP
+ WORK( p ) = WORK( p )*CS
+ WORK( q ) = WORK( q )*CS
+ CALL SROTM( M, A( 1, p ), 1,
+ + A( 1, q ), 1,
+ + FASTR )
+ IF( RSVEC )CALL SROTM( MVL,
+ + V( 1, p ), 1, V( 1, q ),
+ + 1, FASTR )
+ ELSE
+ CALL SAXPY( M, -T*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ CALL SAXPY( M, CS*SN*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ WORK( p ) = WORK( p )*CS
+ WORK( q ) = WORK( q ) / CS
+ IF( RSVEC ) THEN
+ CALL SAXPY( MVL, -T*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ CALL SAXPY( MVL,
+ + CS*SN*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ END IF
+ END IF
+ ELSE
+ IF( WORK( q ).GE.ONE ) THEN
+ CALL SAXPY( M, T*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ CALL SAXPY( M, -CS*SN*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ WORK( p ) = WORK( p ) / CS
+ WORK( q ) = WORK( q )*CS
+ IF( RSVEC ) THEN
+ CALL SAXPY( MVL, T*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ CALL SAXPY( MVL,
+ + -CS*SN*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ END IF
+ ELSE
+ IF( WORK( p ).GE.WORK( q ) )
+ + THEN
+ CALL SAXPY( M, -T*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ CALL SAXPY( M, CS*SN*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ WORK( p ) = WORK( p )*CS
+ WORK( q ) = WORK( q ) / CS
+ IF( RSVEC ) THEN
+ CALL SAXPY( MVL,
+ + -T*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ CALL SAXPY( MVL,
+ + CS*SN*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ END IF
+ ELSE
+ CALL SAXPY( M, T*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ CALL SAXPY( M,
+ + -CS*SN*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ WORK( p ) = WORK( p ) / CS
+ WORK( q ) = WORK( q )*CS
+ IF( RSVEC ) THEN
+ CALL SAXPY( MVL,
+ + T*APOAQ, V( 1, p ),
+ + 1, V( 1, q ), 1 )
+ CALL SAXPY( MVL,
+ + -CS*SN*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ END IF
+ END IF
+ END IF
+ END IF
+ END IF
+*
+ ELSE
* .. have to use modified Gram-Schmidt like transformation
- CALL SCOPY( M, A(1,p), 1, WORK(N+1), 1 )
- CALL SLASCL( 'G',0,0,AAPP,ONE,M,1,WORK(N+1),LDA,IERR )
- CALL SLASCL( 'G',0,0,AAQQ,ONE,M,1, A(1,q),LDA,IERR )
- TEMP1 = -AAPQ * WORK(p) / WORK(q)
- CALL SAXPY ( M, TEMP1, WORK(N+1), 1, A(1,q), 1 )
- CALL SLASCL( 'G',0,0,ONE,AAQQ,M,1, A(1,q),LDA,IERR )
- SVA(q) = AAQQ*SQRT( AMAX1( ZERO, ONE - AAPQ*AAPQ ) )
- MXSINJ = AMAX1( MXSINJ, SFMIN )
- END IF
+ CALL SCOPY( M, A( 1, p ), 1,
+ + WORK( N+1 ), 1 )
+ CALL SLASCL( 'G', 0, 0, AAPP, ONE, M,
+ + 1, WORK( N+1 ), LDA,
+ + IERR )
+ CALL SLASCL( 'G', 0, 0, AAQQ, ONE, M,
+ + 1, A( 1, q ), LDA, IERR )
+ TEMP1 = -AAPQ*WORK( p ) / WORK( q )
+ CALL SAXPY( M, TEMP1, WORK( N+1 ), 1,
+ + A( 1, q ), 1 )
+ CALL SLASCL( 'G', 0, 0, ONE, AAQQ, M,
+ + 1, A( 1, q ), LDA, IERR )
+ SVA( q ) = AAQQ*SQRT( AMAX1( ZERO,
+ + ONE-AAPQ*AAPQ ) )
+ MXSINJ = AMAX1( MXSINJ, SFMIN )
+ END IF
* END IF ROTOK THEN ... ELSE
*
* In the case of cancellation in updating SVA(q), SVA(p)
* recompute SVA(q), SVA(p).
*
- IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS ) THEN
- IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN
- SVA(q) = SNRM2( M, A(1,q), 1 ) * WORK(q)
- ELSE
- T = ZERO
- AAQQ = ZERO
- CALL SLASSQ( M, A(1,q), 1, T, AAQQ )
- SVA(q) = T * SQRT(AAQQ) * WORK(q)
- END IF
- END IF
- IF ( ( AAPP / AAPP0) .LE. ROOTEPS ) THEN
- IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN
- AAPP = SNRM2( M, A(1,p), 1 ) * WORK(p)
- ELSE
- T = ZERO
- AAPP = ZERO
- CALL SLASSQ( M, A(1,p), 1, T, AAPP )
- AAPP = T * SQRT(AAPP) * WORK(p)
- END IF
- SVA(p) = AAPP
- END IF
-*
- ELSE
+ IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS )
+ + THEN
+ IF( ( AAQQ.LT.ROOTBIG ) .AND.
+ + ( AAQQ.GT.ROOTSFMIN ) ) THEN
+ SVA( q ) = SNRM2( M, A( 1, q ), 1 )*
+ + WORK( q )
+ ELSE
+ T = ZERO
+ AAQQ = ZERO
+ CALL SLASSQ( M, A( 1, q ), 1, T,
+ + AAQQ )
+ SVA( q ) = T*SQRT( AAQQ )*WORK( q )
+ END IF
+ END IF
+ IF( ( AAPP / AAPP0 ).LE.ROOTEPS ) THEN
+ IF( ( AAPP.LT.ROOTBIG ) .AND.
+ + ( AAPP.GT.ROOTSFMIN ) ) THEN
+ AAPP = SNRM2( M, A( 1, p ), 1 )*
+ + WORK( p )
+ ELSE
+ T = ZERO
+ AAPP = ZERO
+ CALL SLASSQ( M, A( 1, p ), 1, T,
+ + AAPP )
+ AAPP = T*SQRT( AAPP )*WORK( p )
+ END IF
+ SVA( p ) = AAPP
+ END IF
+*
+ ELSE
* A(:,p) and A(:,q) already numerically orthogonal
- IF ( ir1 .EQ. 0 ) NOTROT = NOTROT + 1
+ IF( ir1.EQ.0 )NOTROT = NOTROT + 1
*[RTD] SKIPPED = SKIPPED + 1
- PSKIPPED = PSKIPPED + 1
- END IF
- ELSE
+ PSKIPPED = PSKIPPED + 1
+ END IF
+ ELSE
* A(:,q) is zero column
- IF ( ir1. EQ. 0 ) NOTROT = NOTROT + 1
- PSKIPPED = PSKIPPED + 1
- END IF
+ IF( ir1.EQ.0 )NOTROT = NOTROT + 1
+ PSKIPPED = PSKIPPED + 1
+ END IF
*
- IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN
- IF ( ir1 .EQ. 0 ) AAPP = - AAPP
- NOTROT = 0
- GO TO 2103
- END IF
+ IF( ( i.LE.SWBAND ) .AND.
+ + ( PSKIPPED.GT.ROWSKIP ) ) THEN
+ IF( ir1.EQ.0 )AAPP = -AAPP
+ NOTROT = 0
+ GO TO 2103
+ END IF
*
- 2002 CONTINUE
+ 2002 CONTINUE
* END q-LOOP
*
- 2103 CONTINUE
+ 2103 CONTINUE
* bailed out of q-loop
*
- SVA(p) = AAPP
+ SVA( p ) = AAPP
*
- ELSE
- SVA(p) = AAPP
- IF ( ( ir1 .EQ. 0 ) .AND. (AAPP .EQ. ZERO) )
- & NOTROT=NOTROT+MIN0(igl+KBL-1,N)-p
- END IF
+ ELSE
+ SVA( p ) = AAPP
+ IF( ( ir1.EQ.0 ) .AND. ( AAPP.EQ.ZERO ) )
+ + NOTROT = NOTROT + MIN0( igl+KBL-1, N ) - p
+ END IF
*
- 2001 CONTINUE
+ 2001 CONTINUE
* end of the p-loop
* end of doing the block ( ibr, ibr )
- 1002 CONTINUE
+ 1002 CONTINUE
* end of ir1-loop
*
* ... go to the off diagonal blocks
*
- igl = ( ibr - 1 ) * KBL + 1
+ igl = ( ibr-1 )*KBL + 1
*
- DO 2010 jbc = ibr + 1, NBL
+ DO 2010 jbc = ibr + 1, NBL
*
- jgl = ( jbc - 1 ) * KBL + 1
+ jgl = ( jbc-1 )*KBL + 1
*
* doing the block at ( ibr, jbc )
*
- IJBLSK = 0
- DO 2100 p = igl, MIN0( igl + KBL - 1, N )
+ IJBLSK = 0
+ DO 2100 p = igl, MIN0( igl+KBL-1, N )
*
- AAPP = SVA(p)
- IF ( AAPP .GT. ZERO ) THEN
+ AAPP = SVA( p )
+ IF( AAPP.GT.ZERO ) THEN
*
- PSKIPPED = 0
+ PSKIPPED = 0
*
- DO 2200 q = jgl, MIN0( jgl + KBL - 1, N )
+ DO 2200 q = jgl, MIN0( jgl+KBL-1, N )
*
- AAQQ = SVA(q)
- IF ( AAQQ .GT. ZERO ) THEN
- AAPP0 = AAPP
+ AAQQ = SVA( q )
+ IF( AAQQ.GT.ZERO ) THEN
+ AAPP0 = AAPP
*
-* -#- M x 2 Jacobi SVD -#-
+* .. M x 2 Jacobi SVD ..
*
* Safe Gram matrix computation
*
- IF ( AAQQ .GE. ONE ) THEN
- IF ( AAPP .GE. AAQQ ) THEN
- ROTOK = ( SMALL*AAPP ) .LE. AAQQ
- ELSE
- ROTOK = ( SMALL*AAQQ ) .LE. AAPP
- END IF
- IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN
- AAPQ = ( SDOT(M, A(1,p), 1, A(1,q), 1 ) *
- & WORK(p) * WORK(q) / AAQQ ) / AAPP
- ELSE
- CALL SCOPY( M, A(1,p), 1, WORK(N+1), 1 )
- CALL SLASCL( 'G', 0, 0, AAPP, WORK(p), M,
- & 1, WORK(N+1), LDA, IERR )
- AAPQ = SDOT( M, WORK(N+1), 1, A(1,q), 1 ) *
- & WORK(q) / AAQQ
- END IF
- ELSE
- IF ( AAPP .GE. AAQQ ) THEN
- ROTOK = AAPP .LE. ( AAQQ / SMALL )
- ELSE
- ROTOK = AAQQ .LE. ( AAPP / SMALL )
- END IF
- IF ( AAPP .GT. ( SMALL / AAQQ ) ) THEN
- AAPQ = ( SDOT( M, A(1,p), 1, A(1,q), 1 ) *
- & WORK(p) * WORK(q) / AAQQ ) / AAPP
- ELSE
- CALL SCOPY( M, A(1,q), 1, WORK(N+1), 1 )
- CALL SLASCL( 'G', 0, 0, AAQQ, WORK(q), M, 1,
- & WORK(N+1), LDA, IERR )
- AAPQ = SDOT(M,WORK(N+1),1,A(1,p),1) * WORK(p) / AAPP
- END IF
- END IF
+ IF( AAQQ.GE.ONE ) THEN
+ IF( AAPP.GE.AAQQ ) THEN
+ ROTOK = ( SMALL*AAPP ).LE.AAQQ
+ ELSE
+ ROTOK = ( SMALL*AAQQ ).LE.AAPP
+ END IF
+ IF( AAPP.LT.( BIG / AAQQ ) ) THEN
+ AAPQ = ( SDOT( M, A( 1, p ), 1, A( 1,
+ + q ), 1 )*WORK( p )*WORK( q ) /
+ + AAQQ ) / AAPP
+ ELSE
+ CALL SCOPY( M, A( 1, p ), 1,
+ + WORK( N+1 ), 1 )
+ CALL SLASCL( 'G', 0, 0, AAPP,
+ + WORK( p ), M, 1,
+ + WORK( N+1 ), LDA, IERR )
+ AAPQ = SDOT( M, WORK( N+1 ), 1,
+ + A( 1, q ), 1 )*WORK( q ) / AAQQ
+ END IF
+ ELSE
+ IF( AAPP.GE.AAQQ ) THEN
+ ROTOK = AAPP.LE.( AAQQ / SMALL )
+ ELSE
+ ROTOK = AAQQ.LE.( AAPP / SMALL )
+ END IF
+ IF( AAPP.GT.( SMALL / AAQQ ) ) THEN
+ AAPQ = ( SDOT( M, A( 1, p ), 1, A( 1,
+ + q ), 1 )*WORK( p )*WORK( q ) /
+ + AAQQ ) / AAPP
+ ELSE
+ CALL SCOPY( M, A( 1, q ), 1,
+ + WORK( N+1 ), 1 )
+ CALL SLASCL( 'G', 0, 0, AAQQ,
+ + WORK( q ), M, 1,
+ + WORK( N+1 ), LDA, IERR )
+ AAPQ = SDOT( M, WORK( N+1 ), 1,
+ + A( 1, p ), 1 )*WORK( p ) / AAPP
+ END IF
+ END IF
*
- MXAAPQ = AMAX1( MXAAPQ, ABS(AAPQ) )
+ MXAAPQ = AMAX1( MXAAPQ, ABS( AAPQ ) )
*
* TO rotate or NOT to rotate, THAT is the question ...
*
- IF ( ABS( AAPQ ) .GT. TOL ) THEN
- NOTROT = 0
+ IF( ABS( AAPQ ).GT.TOL ) THEN
+ NOTROT = 0
*[RTD] ROTATED = ROTATED + 1
- PSKIPPED = 0
- ISWROT = ISWROT + 1
-*
- IF ( ROTOK ) THEN
-*
- AQOAP = AAQQ / AAPP
- APOAQ = AAPP / AAQQ
- THETA = - HALF * ABS( AQOAP - APOAQ ) / AAPQ
- IF ( AAQQ .GT. AAPP0 ) THETA = - THETA
-*
- IF ( ABS( THETA ) .GT. BIGTHETA ) THEN
- T = HALF / THETA
- FASTR(3) = T * WORK(p) / WORK(q)
- FASTR(4) = -T * WORK(q) / WORK(p)
- CALL SROTM( M, A(1,p), 1, A(1,q), 1, FASTR )
- IF ( RSVEC )
- & CALL SROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR )
- SVA(q) = AAQQ*SQRT( AMAX1(ZERO,ONE + T*APOAQ*AAPQ) )
- AAPP = AAPP*SQRT( AMAX1(ZERO,ONE - T*AQOAP*AAPQ) )
- MXSINJ = AMAX1( MXSINJ, ABS(T) )
- ELSE
+ PSKIPPED = 0
+ ISWROT = ISWROT + 1
+*
+ IF( ROTOK ) THEN
+*
+ AQOAP = AAQQ / AAPP
+ APOAQ = AAPP / AAQQ
+ THETA = -HALF*ABS( AQOAP-APOAQ ) / AAPQ
+ IF( AAQQ.GT.AAPP0 )THETA = -THETA
+*
+ IF( ABS( THETA ).GT.BIGTHETA ) THEN
+ T = HALF / THETA
+ FASTR( 3 ) = T*WORK( p ) / WORK( q )
+ FASTR( 4 ) = -T*WORK( q ) /
+ + WORK( p )
+ CALL SROTM( M, A( 1, p ), 1,
+ + A( 1, q ), 1, FASTR )
+ IF( RSVEC )CALL SROTM( MVL,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1,
+ + FASTR )
+ SVA( q ) = AAQQ*SQRT( AMAX1( ZERO,
+ + ONE+T*APOAQ*AAPQ ) )
+ AAPP = AAPP*SQRT( AMAX1( ZERO,
+ + ONE-T*AQOAP*AAPQ ) )
+ MXSINJ = AMAX1( MXSINJ, ABS( T ) )
+ ELSE
*
* .. choose correct signum for THETA and rotate
*
- THSIGN = - SIGN(ONE,AAPQ)
- IF ( AAQQ .GT. AAPP0 ) THSIGN = - THSIGN
- T = ONE / ( THETA + THSIGN*SQRT(ONE+THETA*THETA) )
- CS = SQRT( ONE / ( ONE + T*T ) )
- SN = T * CS
- MXSINJ = AMAX1( MXSINJ, ABS(SN) )
- SVA(q) = AAQQ*SQRT( AMAX1(ZERO, ONE+T*APOAQ*AAPQ) )
- AAPP = AAPP*SQRT( ONE - T*AQOAP*AAPQ)
-*
- APOAQ = WORK(p) / WORK(q)
- AQOAP = WORK(q) / WORK(p)
- IF ( WORK(p) .GE. ONE ) THEN
-*
- IF ( WORK(q) .GE. ONE ) THEN
- FASTR(3) = T * APOAQ
- FASTR(4) = - T * AQOAP
- WORK(p) = WORK(p) * CS
- WORK(q) = WORK(q) * CS
- CALL SROTM( M, A(1,p),1, A(1,q),1, FASTR )
- IF ( RSVEC )
- & CALL SROTM( MVL, V(1,p),1, V(1,q),1, FASTR )
- ELSE
- CALL SAXPY( M, -T*AQOAP, A(1,q),1, A(1,p),1 )
- CALL SAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 )
- IF ( RSVEC ) THEN
- CALL SAXPY( MVL, -T*AQOAP, V(1,q),1, V(1,p),1 )
- CALL SAXPY( MVL,CS*SN*APOAQ,V(1,p),1, V(1,q),1 )
- END IF
- WORK(p) = WORK(p) * CS
- WORK(q) = WORK(q) / CS
- END IF
- ELSE
- IF ( WORK(q) .GE. ONE ) THEN
- CALL SAXPY( M, T*APOAQ, A(1,p),1, A(1,q),1 )
- CALL SAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 )
- IF ( RSVEC ) THEN
- CALL SAXPY(MVL,T*APOAQ, V(1,p),1, V(1,q),1 )
- CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1, V(1,p),1 )
- END IF
- WORK(p) = WORK(p) / CS
- WORK(q) = WORK(q) * CS
- ELSE
- IF ( WORK(p) .GE. WORK(q) ) THEN
- CALL SAXPY( M,-T*AQOAP, A(1,q),1,A(1,p),1 )
- CALL SAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 )
- WORK(p) = WORK(p) * CS
- WORK(q) = WORK(q) / CS
- IF ( RSVEC ) THEN
- CALL SAXPY( MVL, -T*AQOAP, V(1,q),1,V(1,p),1)
- CALL SAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1)
- END IF
- ELSE
- CALL SAXPY(M, T*APOAQ, A(1,p),1,A(1,q),1)
- CALL SAXPY(M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1)
- WORK(p) = WORK(p) / CS
- WORK(q) = WORK(q) * CS
- IF ( RSVEC ) THEN
- CALL SAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1)
- CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1)
- END IF
- END IF
- END IF
- ENDIF
- END IF
-*
- ELSE
- IF ( AAPP .GT. AAQQ ) THEN
- CALL SCOPY( M, A(1,p), 1, WORK(N+1), 1 )
- CALL SLASCL('G',0,0,AAPP,ONE,M,1,WORK(N+1),LDA,IERR)
- CALL SLASCL('G',0,0,AAQQ,ONE,M,1, A(1,q),LDA,IERR)
- TEMP1 = -AAPQ * WORK(p) / WORK(q)
- CALL SAXPY(M,TEMP1,WORK(N+1),1,A(1,q),1)
- CALL SLASCL('G',0,0,ONE,AAQQ,M,1,A(1,q),LDA,IERR)
- SVA(q) = AAQQ*SQRT(AMAX1(ZERO, ONE - AAPQ*AAPQ))
- MXSINJ = AMAX1( MXSINJ, SFMIN )
- ELSE
- CALL SCOPY( M, A(1,q), 1, WORK(N+1), 1 )
- CALL SLASCL('G',0,0,AAQQ,ONE,M,1,WORK(N+1),LDA,IERR)
- CALL SLASCL('G',0,0,AAPP,ONE,M,1, A(1,p),LDA,IERR)
- TEMP1 = -AAPQ * WORK(q) / WORK(p)
- CALL SAXPY(M,TEMP1,WORK(N+1),1,A(1,p),1)
- CALL SLASCL('G',0,0,ONE,AAPP,M,1,A(1,p),LDA,IERR)
- SVA(p) = AAPP*SQRT(AMAX1(ZERO, ONE - AAPQ*AAPQ))
- MXSINJ = AMAX1( MXSINJ, SFMIN )
- END IF
- END IF
+ THSIGN = -SIGN( ONE, AAPQ )
+ IF( AAQQ.GT.AAPP0 )THSIGN = -THSIGN
+ T = ONE / ( THETA+THSIGN*
+ + SQRT( ONE+THETA*THETA ) )
+ CS = SQRT( ONE / ( ONE+T*T ) )
+ SN = T*CS
+ MXSINJ = AMAX1( MXSINJ, ABS( SN ) )
+ SVA( q ) = AAQQ*SQRT( AMAX1( ZERO,
+ + ONE+T*APOAQ*AAPQ ) )
+ AAPP = AAPP*SQRT( ONE-T*AQOAP*AAPQ )
+*
+ APOAQ = WORK( p ) / WORK( q )
+ AQOAP = WORK( q ) / WORK( p )
+ IF( WORK( p ).GE.ONE ) THEN
+*
+ IF( WORK( q ).GE.ONE ) THEN
+ FASTR( 3 ) = T*APOAQ
+ FASTR( 4 ) = -T*AQOAP
+ WORK( p ) = WORK( p )*CS
+ WORK( q ) = WORK( q )*CS
+ CALL SROTM( M, A( 1, p ), 1,
+ + A( 1, q ), 1,
+ + FASTR )
+ IF( RSVEC )CALL SROTM( MVL,
+ + V( 1, p ), 1, V( 1, q ),
+ + 1, FASTR )
+ ELSE
+ CALL SAXPY( M, -T*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ CALL SAXPY( M, CS*SN*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ IF( RSVEC ) THEN
+ CALL SAXPY( MVL, -T*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ CALL SAXPY( MVL,
+ + CS*SN*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ END IF
+ WORK( p ) = WORK( p )*CS
+ WORK( q ) = WORK( q ) / CS
+ END IF
+ ELSE
+ IF( WORK( q ).GE.ONE ) THEN
+ CALL SAXPY( M, T*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ CALL SAXPY( M, -CS*SN*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ IF( RSVEC ) THEN
+ CALL SAXPY( MVL, T*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ CALL SAXPY( MVL,
+ + -CS*SN*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ END IF
+ WORK( p ) = WORK( p ) / CS
+ WORK( q ) = WORK( q )*CS
+ ELSE
+ IF( WORK( p ).GE.WORK( q ) )
+ + THEN
+ CALL SAXPY( M, -T*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ CALL SAXPY( M, CS*SN*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ WORK( p ) = WORK( p )*CS
+ WORK( q ) = WORK( q ) / CS
+ IF( RSVEC ) THEN
+ CALL SAXPY( MVL,
+ + -T*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ CALL SAXPY( MVL,
+ + CS*SN*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ END IF
+ ELSE
+ CALL SAXPY( M, T*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ CALL SAXPY( M,
+ + -CS*SN*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ WORK( p ) = WORK( p ) / CS
+ WORK( q ) = WORK( q )*CS
+ IF( RSVEC ) THEN
+ CALL SAXPY( MVL,
+ + T*APOAQ, V( 1, p ),
+ + 1, V( 1, q ), 1 )
+ CALL SAXPY( MVL,
+ + -CS*SN*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ END IF
+ END IF
+ END IF
+ END IF
+ END IF
+*
+ ELSE
+ IF( AAPP.GT.AAQQ ) THEN
+ CALL SCOPY( M, A( 1, p ), 1,
+ + WORK( N+1 ), 1 )
+ CALL SLASCL( 'G', 0, 0, AAPP, ONE,
+ + M, 1, WORK( N+1 ), LDA,
+ + IERR )
+ CALL SLASCL( 'G', 0, 0, AAQQ, ONE,
+ + M, 1, A( 1, q ), LDA,
+ + IERR )
+ TEMP1 = -AAPQ*WORK( p ) / WORK( q )
+ CALL SAXPY( M, TEMP1, WORK( N+1 ),
+ + 1, A( 1, q ), 1 )
+ CALL SLASCL( 'G', 0, 0, ONE, AAQQ,
+ + M, 1, A( 1, q ), LDA,
+ + IERR )
+ SVA( q ) = AAQQ*SQRT( AMAX1( ZERO,
+ + ONE-AAPQ*AAPQ ) )
+ MXSINJ = AMAX1( MXSINJ, SFMIN )
+ ELSE
+ CALL SCOPY( M, A( 1, q ), 1,
+ + WORK( N+1 ), 1 )
+ CALL SLASCL( 'G', 0, 0, AAQQ, ONE,
+ + M, 1, WORK( N+1 ), LDA,
+ + IERR )
+ CALL SLASCL( 'G', 0, 0, AAPP, ONE,
+ + M, 1, A( 1, p ), LDA,
+ + IERR )
+ TEMP1 = -AAPQ*WORK( q ) / WORK( p )
+ CALL SAXPY( M, TEMP1, WORK( N+1 ),
+ + 1, A( 1, p ), 1 )
+ CALL SLASCL( 'G', 0, 0, ONE, AAPP,
+ + M, 1, A( 1, p ), LDA,
+ + IERR )
+ SVA( p ) = AAPP*SQRT( AMAX1( ZERO,
+ + ONE-AAPQ*AAPQ ) )
+ MXSINJ = AMAX1( MXSINJ, SFMIN )
+ END IF
+ END IF
* END IF ROTOK THEN ... ELSE
*
* In the case of cancellation in updating SVA(q)
* .. recompute SVA(q)
- IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS ) THEN
- IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN
- SVA(q) = SNRM2( M, A(1,q), 1 ) * WORK(q)
- ELSE
- T = ZERO
- AAQQ = ZERO
- CALL SLASSQ( M, A(1,q), 1, T, AAQQ )
- SVA(q) = T * SQRT(AAQQ) * WORK(q)
- END IF
- END IF
- IF ( (AAPP / AAPP0 )**2 .LE. ROOTEPS ) THEN
- IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN
- AAPP = SNRM2( M, A(1,p), 1 ) * WORK(p)
- ELSE
- T = ZERO
- AAPP = ZERO
- CALL SLASSQ( M, A(1,p), 1, T, AAPP )
- AAPP = T * SQRT(AAPP) * WORK(p)
- END IF
- SVA(p) = AAPP
- END IF
+ IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS )
+ + THEN
+ IF( ( AAQQ.LT.ROOTBIG ) .AND.
+ + ( AAQQ.GT.ROOTSFMIN ) ) THEN
+ SVA( q ) = SNRM2( M, A( 1, q ), 1 )*
+ + WORK( q )
+ ELSE
+ T = ZERO
+ AAQQ = ZERO
+ CALL SLASSQ( M, A( 1, q ), 1, T,
+ + AAQQ )
+ SVA( q ) = T*SQRT( AAQQ )*WORK( q )
+ END IF
+ END IF
+ IF( ( AAPP / AAPP0 )**2.LE.ROOTEPS ) THEN
+ IF( ( AAPP.LT.ROOTBIG ) .AND.
+ + ( AAPP.GT.ROOTSFMIN ) ) THEN
+ AAPP = SNRM2( M, A( 1, p ), 1 )*
+ + WORK( p )
+ ELSE
+ T = ZERO
+ AAPP = ZERO
+ CALL SLASSQ( M, A( 1, p ), 1, T,
+ + AAPP )
+ AAPP = T*SQRT( AAPP )*WORK( p )
+ END IF
+ SVA( p ) = AAPP
+ END IF
* end of OK rotation
- ELSE
- NOTROT = NOTROT + 1
+ ELSE
+ NOTROT = NOTROT + 1
*[RTD] SKIPPED = SKIPPED + 1
- PSKIPPED = PSKIPPED + 1
- IJBLSK = IJBLSK + 1
- END IF
- ELSE
- NOTROT = NOTROT + 1
- PSKIPPED = PSKIPPED + 1
- IJBLSK = IJBLSK + 1
- END IF
+ PSKIPPED = PSKIPPED + 1
+ IJBLSK = IJBLSK + 1
+ END IF
+ ELSE
+ NOTROT = NOTROT + 1
+ PSKIPPED = PSKIPPED + 1
+ IJBLSK = IJBLSK + 1
+ END IF
*
- IF ( ( i .LE. SWBAND ) .AND. ( IJBLSK .GE. BLSKIP ) ) THEN
- SVA(p) = AAPP
- NOTROT = 0
- GO TO 2011
- END IF
- IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN
- AAPP = -AAPP
- NOTROT = 0
- GO TO 2203
- END IF
+ IF( ( i.LE.SWBAND ) .AND. ( IJBLSK.GE.BLSKIP ) )
+ + THEN
+ SVA( p ) = AAPP
+ NOTROT = 0
+ GO TO 2011
+ END IF
+ IF( ( i.LE.SWBAND ) .AND.
+ + ( PSKIPPED.GT.ROWSKIP ) ) THEN
+ AAPP = -AAPP
+ NOTROT = 0
+ GO TO 2203
+ END IF
*
- 2200 CONTINUE
+ 2200 CONTINUE
* end of the q-loop
- 2203 CONTINUE
+ 2203 CONTINUE
*
- SVA(p) = AAPP
+ SVA( p ) = AAPP
*
- ELSE
+ ELSE
*
- IF ( AAPP .EQ. ZERO ) NOTROT=NOTROT+MIN0(jgl+KBL-1,N)-jgl+1
- IF ( AAPP .LT. ZERO ) NOTROT = 0
+ IF( AAPP.EQ.ZERO )NOTROT = NOTROT +
+ + MIN0( jgl+KBL-1, N ) - jgl + 1
+ IF( AAPP.LT.ZERO )NOTROT = 0
*
- END IF
+ END IF
*
- 2100 CONTINUE
+ 2100 CONTINUE
* end of the p-loop
- 2010 CONTINUE
+ 2010 CONTINUE
* end of the jbc-loop
- 2011 CONTINUE
+ 2011 CONTINUE
*2011 bailed out of the jbc-loop
- DO 2012 p = igl, MIN0( igl + KBL - 1, N )
- SVA(p) = ABS(SVA(p))
- 2012 CONTINUE
+ DO 2012 p = igl, MIN0( igl+KBL-1, N )
+ SVA( p ) = ABS( SVA( p ) )
+ 2012 CONTINUE
***
- 2000 CONTINUE
+ 2000 CONTINUE
*2000 :: end of the ibr-loop
*
* .. update SVA(N)
- IF ((SVA(N) .LT. ROOTBIG).AND.(SVA(N) .GT. ROOTSFMIN)) THEN
- SVA(N) = SNRM2( M, A(1,N), 1 ) * WORK(N)
- ELSE
- T = ZERO
- AAPP = ZERO
- CALL SLASSQ( M, A(1,N), 1, T, AAPP )
- SVA(N) = T * SQRT(AAPP) * WORK(N)
- END IF
+ IF( ( SVA( N ).LT.ROOTBIG ) .AND. ( SVA( N ).GT.ROOTSFMIN ) )
+ + THEN
+ SVA( N ) = SNRM2( M, A( 1, N ), 1 )*WORK( N )
+ ELSE
+ T = ZERO
+ AAPP = ZERO
+ CALL SLASSQ( M, A( 1, N ), 1, T, AAPP )
+ SVA( N ) = T*SQRT( AAPP )*WORK( N )
+ END IF
*
* Additional steering devices
*
- IF ( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR.
- & ( ISWROT .LE. N ) ) )
- & SWBAND = i
+ IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR.
+ + ( ISWROT.LE.N ) ) )SWBAND = i
*
- IF ( (i .GT. SWBAND+1) .AND. (MXAAPQ .LT. SQRT(FLOAT(N))*TOL)
- & .AND. (FLOAT(N)*MXAAPQ*MXSINJ .LT. TOL) ) THEN
- GO TO 1994
- END IF
+ IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.SQRT( FLOAT( N ) )*
+ + TOL ) .AND. ( FLOAT( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN
+ GO TO 1994
+ END IF
*
- IF ( NOTROT .GE. EMPTSW ) GO TO 1994
+ IF( NOTROT.GE.EMPTSW )GO TO 1994
*
1993 CONTINUE
* end i=1:NSWEEP loop
N2 = 0
N4 = 0
DO 5991 p = 1, N - 1
- q = ISAMAX( N-p+1, SVA(p), 1 ) + p - 1
- IF ( p .NE. q ) THEN
- TEMP1 = SVA(p)
- SVA(p) = SVA(q)
- SVA(q) = TEMP1
- TEMP1 = WORK(p)
- WORK(p) = WORK(q)
- WORK(q) = TEMP1
- CALL SSWAP( M, A(1,p), 1, A(1,q), 1 )
- IF ( RSVEC ) CALL SSWAP( MVL, V(1,p), 1, V(1,q), 1 )
+ q = ISAMAX( N-p+1, SVA( p ), 1 ) + p - 1
+ IF( p.NE.q ) THEN
+ TEMP1 = SVA( p )
+ SVA( p ) = SVA( q )
+ SVA( q ) = TEMP1
+ TEMP1 = WORK( p )
+ WORK( p ) = WORK( q )
+ WORK( q ) = TEMP1
+ CALL SSWAP( M, A( 1, p ), 1, A( 1, q ), 1 )
+ IF( RSVEC )CALL SSWAP( MVL, V( 1, p ), 1, V( 1, q ), 1 )
END IF
- IF ( SVA(p) .NE. ZERO ) THEN
+ IF( SVA( p ).NE.ZERO ) THEN
N4 = N4 + 1
- IF ( SVA(p)*SCALE .GT. SFMIN ) N2 = N2 + 1
+ IF( SVA( p )*SCALE.GT.SFMIN )N2 = N2 + 1
END IF
5991 CONTINUE
- IF ( SVA(N) .NE. ZERO ) THEN
+ IF( SVA( N ).NE.ZERO ) THEN
N4 = N4 + 1
- IF ( SVA(N)*SCALE .GT. SFMIN ) N2 = N2 + 1
+ IF( SVA( N )*SCALE.GT.SFMIN )N2 = N2 + 1
END IF
*
* Normalize the left singular vectors.
*
- IF ( LSVEC .OR. UCTOL ) THEN
+ IF( LSVEC .OR. UCTOL ) THEN
DO 1998 p = 1, N2
- CALL SSCAL( M, WORK(p) / SVA(p), A(1,p), 1 )
+ CALL SSCAL( M, WORK( p ) / SVA( p ), A( 1, p ), 1 )
1998 CONTINUE
END IF
*
* Scale the product of Jacobi rotations (assemble the fast rotations).
*
- IF ( RSVEC ) THEN
- IF ( APPLV ) THEN
+ IF( RSVEC ) THEN
+ IF( APPLV ) THEN
DO 2398 p = 1, N
- CALL SSCAL( MVL, WORK(p), V(1,p), 1 )
+ CALL SSCAL( MVL, WORK( p ), V( 1, p ), 1 )
2398 CONTINUE
ELSE
DO 2399 p = 1, N
- TEMP1 = ONE / SNRM2(MVL, V(1,p), 1 )
- CALL SSCAL( MVL, TEMP1, V(1,p), 1 )
+ TEMP1 = ONE / SNRM2( MVL, V( 1, p ), 1 )
+ CALL SSCAL( MVL, TEMP1, V( 1, p ), 1 )
2399 CONTINUE
END IF
END IF
*
* Undo scaling, if necessary (and possible).
- IF ( ((SCALE.GT.ONE).AND.(SVA(1).LT.(BIG/SCALE)))
- & .OR.((SCALE.LT.ONE).AND.(SVA(N2).GT.(SFMIN/SCALE))) ) THEN
+ IF( ( ( SCALE.GT.ONE ) .AND. ( SVA( 1 ).LT.( BIG /
+ + SCALE ) ) ) .OR. ( ( SCALE.LT.ONE ) .AND. ( SVA( N2 ).GT.
+ + ( SFMIN / SCALE ) ) ) ) THEN
DO 2400 p = 1, N
- SVA(p) = SCALE*SVA(p)
+ SVA( p ) = SCALE*SVA( p )
2400 CONTINUE
SCALE = ONE
END IF
*
- WORK(1) = SCALE
+ WORK( 1 ) = SCALE
* The singular values of A are SCALE*SVA(1:N). If SCALE.NE.ONE
* then some of the singular values may overflow or underflow and
* the spectrum is given in this factored representation.
*
- WORK(2) = FLOAT(N4)
+ WORK( 2 ) = FLOAT( N4 )
* N4 is the number of computed nonzero singular values of A.
*
- WORK(3) = FLOAT(N2)
+ WORK( 3 ) = FLOAT( N2 )
* N2 is the number of singular values of A greater than SFMIN.
* If N2<N, SVA(N2:N) contains ZEROS and/or denormalized numbers
* that may carry some information.
*
- WORK(4) = FLOAT(i)
+ WORK( 4 ) = FLOAT( i )
* i is the index of the last sweep before declaring convergence.
*
- WORK(5) = MXAAPQ
+ WORK( 5 ) = MXAAPQ
* MXAAPQ is the largest absolute value of scaled pivots in the
* last sweep
*
- WORK(6) = MXSINJ
+ WORK( 6 ) = MXSINJ
* MXSINJ is the largest absolute value of the sines of Jacobi angles
* in the last sweep
*
* .. END OF SGESVJ
* ..
END
-*
SUBROUTINE SGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS,
- & SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )
+ + SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.2) --
*
* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the
* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0.
*
-* Scalar Arguments
-*
- IMPLICIT NONE
- INTEGER INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP
- REAL EPS, SFMIN, TOL
- CHARACTER*1 JOBV
-*
-* Array Arguments
-*
- REAL A( LDA, * ), SVA( N ), D( N ), V( LDV, * ),
- & WORK( LWORK )
+ IMPLICIT NONE
+* ..
+* .. Scalar Arguments ..
+ INTEGER INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP
+ REAL EPS, SFMIN, TOL
+ CHARACTER*1 JOBV
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), SVA( N ), D( N ), V( LDV, * ),
+ + WORK( LWORK )
* ..
*
* Purpose
-* ~~~~~~~
+* =======
+*
* SGSVJ0 is called from SGESVJ as a pre-processor and that is its main
* purpose. It applies Jacobi rotations in the same way as SGESVJ does, but
* it does not check convergence (stopping criterion). Few tuning
* drmac@math.hr. Thank you.
*
* Arguments
-* ~~~~~~~~~
+* =========
*
* JOBV (input) CHARACTER*1
* Specifies whether the output from this procedure is used
* = 0 : successful exit.
* < 0 : if INFO = -i, then the i-th argument had an illegal value
*
-* Local Parameters
- REAL ZERO, HALF, ONE, TWO
- PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0, TWO = 2.0E0 )
-
-* Local Scalars
- REAL AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG, BIGTHETA,
- & CS, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS, ROOTSFMIN,
- & ROOTTOL, SMALL, SN, T, TEMP1, THETA, THSIGN
- INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1, ISWROT,
- & jbc, jgl, KBL, LKAHEAD, MVL, NBL, NOTROT, p, PSKIPPED,
- & q, ROWSKIP, SWBAND
- LOGICAL APPLV, ROTOK, RSVEC
-
-* Local Arrays
- REAL FASTR(5)
-*
-* Intrinsic Functions
- INTRINSIC ABS, AMAX1, AMIN1, FLOAT, MIN0, SIGN, SQRT
-*
-* External Functions
- REAL SDOT, SNRM2
- INTEGER ISAMAX
- LOGICAL LSAME
- EXTERNAL ISAMAX, LSAME, SDOT, SNRM2
+* =====================================================================
*
-* External Subroutines
- EXTERNAL SAXPY, SCOPY, SLASCL, SLASSQ, SROTM, SSWAP
+* .. Local Parameters ..
+ REAL ZERO, HALF, ONE, TWO
+ PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0,
+ + TWO = 2.0E0 )
+* ..
+* .. Local Scalars ..
+ REAL AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,
+ + BIGTHETA, CS, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS,
+ + ROOTSFMIN, ROOTTOL, SMALL, SN, T, TEMP1, THETA,
+ + THSIGN
+ INTEGER BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,
+ + ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, NBL,
+ + NOTROT, p, PSKIPPED, q, ROWSKIP, SWBAND
+ LOGICAL APPLV, ROTOK, RSVEC
+* ..
+* .. Local Arrays ..
+ REAL FASTR( 5 )
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, AMAX1, AMIN1, FLOAT, MIN0, SIGN, SQRT
+* ..
+* .. External Functions ..
+ REAL SDOT, SNRM2
+ INTEGER ISAMAX
+ LOGICAL LSAME
+ EXTERNAL ISAMAX, LSAME, SDOT, SNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SLASCL, SLASSQ, SROTM, SSWAP
+* ..
+* .. Executable Statements ..
*
-* ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~|
+* Test the input parameters.
*
- APPLV = LSAME(JOBV,'A')
- RSVEC = LSAME(JOBV,'V')
- IF ( .NOT.( RSVEC .OR. APPLV .OR. LSAME(JOBV,'N'))) THEN
+ APPLV = LSAME( JOBV, 'A' )
+ RSVEC = LSAME( JOBV, 'V' )
+ IF( .NOT.( RSVEC .OR. APPLV .OR. LSAME( JOBV, 'N' ) ) ) THEN
INFO = -1
- ELSE IF ( M .LT. 0 ) THEN
+ ELSE IF( M.LT.0 ) THEN
INFO = -2
- ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M )) THEN
+ ELSE IF( ( N.LT.0 ) .OR. ( N.GT.M ) ) THEN
INFO = -3
- ELSE IF ( LDA .LT. M ) THEN
+ ELSE IF( LDA.LT.M ) THEN
INFO = -5
- ELSE IF ( MV .LT. 0 ) THEN
+ ELSE IF( MV.LT.0 ) THEN
INFO = -8
- ELSE IF ( LDV .LT. M ) THEN
+ ELSE IF( LDV.LT.M ) THEN
INFO = -10
- ELSE IF ( TOL .LE. EPS ) THEN
+ ELSE IF( TOL.LE.EPS ) THEN
INFO = -13
- ELSE IF ( NSWEEP .LT. 0 ) THEN
+ ELSE IF( NSWEEP.LT.0 ) THEN
INFO = -14
- ELSE IF ( LWORK .LT. M ) THEN
+ ELSE IF( LWORK.LT.M ) THEN
INFO = -16
ELSE
INFO = 0
END IF
*
* #:(
- IF ( INFO .NE. 0 ) THEN
+ IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGSVJ0', -INFO )
RETURN
END IF
*
- IF ( RSVEC ) THEN
+ IF( RSVEC ) THEN
MVL = N
- ELSE IF ( APPLV ) THEN
+ ELSE IF( APPLV ) THEN
MVL = MV
END IF
RSVEC = RSVEC .OR. APPLV
- ROOTEPS = SQRT(EPS)
- ROOTSFMIN = SQRT(SFMIN)
- SMALL = SFMIN / EPS
- BIG = ONE / SFMIN
- ROOTBIG = ONE / ROOTSFMIN
- BIGTHETA = ONE / ROOTEPS
- ROOTTOL = SQRT(TOL)
+ ROOTEPS = SQRT( EPS )
+ ROOTSFMIN = SQRT( SFMIN )
+ SMALL = SFMIN / EPS
+ BIG = ONE / SFMIN
+ ROOTBIG = ONE / ROOTSFMIN
+ BIGTHETA = ONE / ROOTEPS
+ ROOTTOL = SQRT( TOL )
*
*
-* -#- Row-cyclic Jacobi SVD algorithm with column pivoting -#-
+* .. Row-cyclic Jacobi SVD algorithm with column pivoting ..
*
- EMPTSW = ( N * ( N - 1 ) ) / 2
- NOTROT = 0
- FASTR(1) = ZERO
+ EMPTSW = ( N*( N-1 ) ) / 2
+ NOTROT = 0
+ FASTR( 1 ) = ZERO
*
-* -#- Row-cyclic pivot strategy with de Rijk's pivoting -#-
+* .. Row-cyclic pivot strategy with de Rijk's pivoting ..
*
SWBAND = 0
* parameters of the computer's memory.
*
NBL = N / KBL
- IF ( ( NBL * KBL ) .NE. N ) NBL = NBL + 1
+ IF( ( NBL*KBL ).NE.N )NBL = NBL + 1
BLSKIP = ( KBL**2 ) + 1
*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL.
DO 1993 i = 1, NSWEEP
* .. go go go ...
*
- MXAAPQ = ZERO
- MXSINJ = ZERO
- ISWROT = 0
+ MXAAPQ = ZERO
+ MXSINJ = ZERO
+ ISWROT = 0
*
- NOTROT = 0
- PSKIPPED = 0
+ NOTROT = 0
+ PSKIPPED = 0
*
- DO 2000 ibr = 1, NBL
+ DO 2000 ibr = 1, NBL
- igl = ( ibr - 1 ) * KBL + 1
+ igl = ( ibr-1 )*KBL + 1
*
- DO 1002 ir1 = 0, MIN0( LKAHEAD, NBL - ibr )
+ DO 1002 ir1 = 0, MIN0( LKAHEAD, NBL-ibr )
*
- igl = igl + ir1 * KBL
+ igl = igl + ir1*KBL
*
- DO 2001 p = igl, MIN0( igl + KBL - 1, N - 1)
+ DO 2001 p = igl, MIN0( igl+KBL-1, N-1 )
* .. de Rijk's pivoting
- q = ISAMAX( N-p+1, SVA(p), 1 ) + p - 1
- IF ( p .NE. q ) THEN
- CALL SSWAP( M, A(1,p), 1, A(1,q), 1 )
- IF ( RSVEC ) CALL SSWAP( MVL, V(1,p), 1, V(1,q), 1 )
- TEMP1 = SVA(p)
- SVA(p) = SVA(q)
- SVA(q) = TEMP1
- TEMP1 = D(p)
- D(p) = D(q)
- D(q) = TEMP1
- END IF
-*
- IF ( ir1 .EQ. 0 ) THEN
+ q = ISAMAX( N-p+1, SVA( p ), 1 ) + p - 1
+ IF( p.NE.q ) THEN
+ CALL SSWAP( M, A( 1, p ), 1, A( 1, q ), 1 )
+ IF( RSVEC )CALL SSWAP( MVL, V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ TEMP1 = SVA( p )
+ SVA( p ) = SVA( q )
+ SVA( q ) = TEMP1
+ TEMP1 = D( p )
+ D( p ) = D( q )
+ D( q ) = TEMP1
+ END IF
+*
+ IF( ir1.EQ.0 ) THEN
*
* Column norms are periodically updated by explicit
* norm computation.
* If properly implemented SNRM2 is available, the IF-THEN-ELSE
* below should read "AAPP = SNRM2( M, A(1,p), 1 ) * D(p)".
*
- IF ((SVA(p) .LT. ROOTBIG) .AND. (SVA(p) .GT. ROOTSFMIN)) THEN
- SVA(p) = SNRM2( M, A(1,p), 1 ) * D(p)
- ELSE
- TEMP1 = ZERO
- AAPP = ZERO
- CALL SLASSQ( M, A(1,p), 1, TEMP1, AAPP )
- SVA(p) = TEMP1 * SQRT(AAPP) * D(p)
- END IF
- AAPP = SVA(p)
- ELSE
- AAPP = SVA(p)
- END IF
+ IF( ( SVA( p ).LT.ROOTBIG ) .AND.
+ + ( SVA( p ).GT.ROOTSFMIN ) ) THEN
+ SVA( p ) = SNRM2( M, A( 1, p ), 1 )*D( p )
+ ELSE
+ TEMP1 = ZERO
+ AAPP = ZERO
+ CALL SLASSQ( M, A( 1, p ), 1, TEMP1, AAPP )
+ SVA( p ) = TEMP1*SQRT( AAPP )*D( p )
+ END IF
+ AAPP = SVA( p )
+ ELSE
+ AAPP = SVA( p )
+ END IF
*
- IF ( AAPP .GT. ZERO ) THEN
+ IF( AAPP.GT.ZERO ) THEN
*
- PSKIPPED = 0
+ PSKIPPED = 0
*
- DO 2002 q = p + 1, MIN0( igl + KBL - 1, N )
+ DO 2002 q = p + 1, MIN0( igl+KBL-1, N )
*
- AAQQ = SVA(q)
+ AAQQ = SVA( q )
- IF ( AAQQ .GT. ZERO ) THEN
-*
- AAPP0 = AAPP
- IF ( AAQQ .GE. ONE ) THEN
- ROTOK = ( SMALL*AAPP ) .LE. AAQQ
- IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN
- AAPQ = ( SDOT(M, A(1,p), 1, A(1,q), 1 ) *
- & D(p) * D(q) / AAQQ ) / AAPP
- ELSE
- CALL SCOPY( M, A(1,p), 1, WORK, 1 )
- CALL SLASCL( 'G', 0, 0, AAPP, D(p), M,
- & 1, WORK, LDA, IERR )
- AAPQ = SDOT( M, WORK,1, A(1,q),1 )*D(q) / AAQQ
- END IF
- ELSE
- ROTOK = AAPP .LE. ( AAQQ / SMALL )
- IF ( AAPP .GT. ( SMALL / AAQQ ) ) THEN
- AAPQ = ( SDOT( M, A(1,p), 1, A(1,q), 1 ) *
- & D(p) * D(q) / AAQQ ) / AAPP
- ELSE
- CALL SCOPY( M, A(1,q), 1, WORK, 1 )
- CALL SLASCL( 'G', 0, 0, AAQQ, D(q), M,
- & 1, WORK, LDA, IERR )
- AAPQ = SDOT( M, WORK,1, A(1,p),1 )*D(p) / AAPP
- END IF
- END IF
+ IF( AAQQ.GT.ZERO ) THEN
+*
+ AAPP0 = AAPP
+ IF( AAQQ.GE.ONE ) THEN
+ ROTOK = ( SMALL*AAPP ).LE.AAQQ
+ IF( AAPP.LT.( BIG / AAQQ ) ) THEN
+ AAPQ = ( SDOT( M, A( 1, p ), 1, A( 1,
+ + q ), 1 )*D( p )*D( q ) / AAQQ )
+ + / AAPP
+ ELSE
+ CALL SCOPY( M, A( 1, p ), 1, WORK, 1 )
+ CALL SLASCL( 'G', 0, 0, AAPP, D( p ),
+ + M, 1, WORK, LDA, IERR )
+ AAPQ = SDOT( M, WORK, 1, A( 1, q ),
+ + 1 )*D( q ) / AAQQ
+ END IF
+ ELSE
+ ROTOK = AAPP.LE.( AAQQ / SMALL )
+ IF( AAPP.GT.( SMALL / AAQQ ) ) THEN
+ AAPQ = ( SDOT( M, A( 1, p ), 1, A( 1,
+ + q ), 1 )*D( p )*D( q ) / AAQQ )
+ + / AAPP
+ ELSE
+ CALL SCOPY( M, A( 1, q ), 1, WORK, 1 )
+ CALL SLASCL( 'G', 0, 0, AAQQ, D( q ),
+ + M, 1, WORK, LDA, IERR )
+ AAPQ = SDOT( M, WORK, 1, A( 1, p ),
+ + 1 )*D( p ) / AAPP
+ END IF
+ END IF
*
- MXAAPQ = AMAX1( MXAAPQ, ABS(AAPQ) )
+ MXAAPQ = AMAX1( MXAAPQ, ABS( AAPQ ) )
*
* TO rotate or NOT to rotate, THAT is the question ...
*
- IF ( ABS( AAPQ ) .GT. TOL ) THEN
+ IF( ABS( AAPQ ).GT.TOL ) THEN
*
* .. rotate
* ROTATED = ROTATED + ONE
*
- IF ( ir1 .EQ. 0 ) THEN
- NOTROT = 0
- PSKIPPED = 0
- ISWROT = ISWROT + 1
- END IF
+ IF( ir1.EQ.0 ) THEN
+ NOTROT = 0
+ PSKIPPED = 0
+ ISWROT = ISWROT + 1
+ END IF
*
- IF ( ROTOK ) THEN
+ IF( ROTOK ) THEN
*
- AQOAP = AAQQ / AAPP
- APOAQ = AAPP / AAQQ
- THETA = - HALF * ABS( AQOAP - APOAQ ) / AAPQ
+ AQOAP = AAQQ / AAPP
+ APOAQ = AAPP / AAQQ
+ THETA = -HALF*ABS( AQOAP-APOAQ ) / AAPQ
*
- IF ( ABS( THETA ) .GT. BIGTHETA ) THEN
+ IF( ABS( THETA ).GT.BIGTHETA ) THEN
*
- T = HALF / THETA
- FASTR(3) = T * D(p) / D(q)
- FASTR(4) = - T * D(q) / D(p)
- CALL SROTM( M, A(1,p), 1, A(1,q), 1, FASTR )
- IF ( RSVEC )
- & CALL SROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR )
- SVA(q) = AAQQ*SQRT( AMAX1(ZERO,ONE + T*APOAQ*AAPQ) )
- AAPP = AAPP*SQRT( ONE - T*AQOAP*AAPQ )
- MXSINJ = AMAX1( MXSINJ, ABS(T) )
+ T = HALF / THETA
+ FASTR( 3 ) = T*D( p ) / D( q )
+ FASTR( 4 ) = -T*D( q ) / D( p )
+ CALL SROTM( M, A( 1, p ), 1,
+ + A( 1, q ), 1, FASTR )
+ IF( RSVEC )CALL SROTM( MVL,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1,
+ + FASTR )
+ SVA( q ) = AAQQ*SQRT( AMAX1( ZERO,
+ + ONE+T*APOAQ*AAPQ ) )
+ AAPP = AAPP*SQRT( ONE-T*AQOAP*AAPQ )
+ MXSINJ = AMAX1( MXSINJ, ABS( T ) )
*
- ELSE
+ ELSE
*
* .. choose correct signum for THETA and rotate
*
- THSIGN = - SIGN(ONE,AAPQ)
- T = ONE / ( THETA + THSIGN*SQRT(ONE+THETA*THETA) )
- CS = SQRT( ONE / ( ONE + T*T ) )
- SN = T * CS
-*
- MXSINJ = AMAX1( MXSINJ, ABS(SN) )
- SVA(q) = AAQQ*SQRT( AMAX1(ZERO, ONE+T*APOAQ*AAPQ) )
- AAPP = AAPP*SQRT( AMAX1(ZERO, ONE-T*AQOAP*AAPQ) )
-*
- APOAQ = D(p) / D(q)
- AQOAP = D(q) / D(p)
- IF ( D(p) .GE. ONE ) THEN
- IF ( D(q) .GE. ONE ) THEN
- FASTR(3) = T * APOAQ
- FASTR(4) = - T * AQOAP
- D(p) = D(p) * CS
- D(q) = D(q) * CS
- CALL SROTM( M, A(1,p),1, A(1,q),1, FASTR )
- IF ( RSVEC )
- & CALL SROTM( MVL, V(1,p),1, V(1,q),1, FASTR )
- ELSE
- CALL SAXPY( M, -T*AQOAP, A(1,q),1, A(1,p),1 )
- CALL SAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 )
- D(p) = D(p) * CS
- D(q) = D(q) / CS
- IF ( RSVEC ) THEN
- CALL SAXPY(MVL, -T*AQOAP, V(1,q),1,V(1,p),1)
- CALL SAXPY(MVL,CS*SN*APOAQ, V(1,p),1,V(1,q),1)
- END IF
- END IF
- ELSE
- IF ( D(q) .GE. ONE ) THEN
- CALL SAXPY( M, T*APOAQ, A(1,p),1, A(1,q),1 )
- CALL SAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 )
- D(p) = D(p) / CS
- D(q) = D(q) * CS
- IF ( RSVEC ) THEN
- CALL SAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1)
- CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1)
- END IF
- ELSE
- IF ( D(p) .GE. D(q) ) THEN
- CALL SAXPY( M,-T*AQOAP, A(1,q),1,A(1,p),1 )
- CALL SAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 )
- D(p) = D(p) * CS
- D(q) = D(q) / CS
- IF ( RSVEC ) THEN
- CALL SAXPY(MVL, -T*AQOAP, V(1,q),1,V(1,p),1)
- CALL SAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1)
- END IF
- ELSE
- CALL SAXPY( M, T*APOAQ, A(1,p),1,A(1,q),1)
- CALL SAXPY( M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1)
- D(p) = D(p) / CS
- D(q) = D(q) * CS
- IF ( RSVEC ) THEN
- CALL SAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1)
- CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1)
- END IF
- END IF
- END IF
- ENDIF
- END IF
-*
- ELSE
+ THSIGN = -SIGN( ONE, AAPQ )
+ T = ONE / ( THETA+THSIGN*
+ + SQRT( ONE+THETA*THETA ) )
+ CS = SQRT( ONE / ( ONE+T*T ) )
+ SN = T*CS
+*
+ MXSINJ = AMAX1( MXSINJ, ABS( SN ) )
+ SVA( q ) = AAQQ*SQRT( AMAX1( ZERO,
+ + ONE+T*APOAQ*AAPQ ) )
+ AAPP = AAPP*SQRT( AMAX1( ZERO,
+ + ONE-T*AQOAP*AAPQ ) )
+*
+ APOAQ = D( p ) / D( q )
+ AQOAP = D( q ) / D( p )
+ IF( D( p ).GE.ONE ) THEN
+ IF( D( q ).GE.ONE ) THEN
+ FASTR( 3 ) = T*APOAQ
+ FASTR( 4 ) = -T*AQOAP
+ D( p ) = D( p )*CS
+ D( q ) = D( q )*CS
+ CALL SROTM( M, A( 1, p ), 1,
+ + A( 1, q ), 1,
+ + FASTR )
+ IF( RSVEC )CALL SROTM( MVL,
+ + V( 1, p ), 1, V( 1, q ),
+ + 1, FASTR )
+ ELSE
+ CALL SAXPY( M, -T*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ CALL SAXPY( M, CS*SN*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ D( p ) = D( p )*CS
+ D( q ) = D( q ) / CS
+ IF( RSVEC ) THEN
+ CALL SAXPY( MVL, -T*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ CALL SAXPY( MVL,
+ + CS*SN*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ END IF
+ END IF
+ ELSE
+ IF( D( q ).GE.ONE ) THEN
+ CALL SAXPY( M, T*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ CALL SAXPY( M, -CS*SN*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ D( p ) = D( p ) / CS
+ D( q ) = D( q )*CS
+ IF( RSVEC ) THEN
+ CALL SAXPY( MVL, T*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ CALL SAXPY( MVL,
+ + -CS*SN*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ END IF
+ ELSE
+ IF( D( p ).GE.D( q ) ) THEN
+ CALL SAXPY( M, -T*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ CALL SAXPY( M, CS*SN*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ D( p ) = D( p )*CS
+ D( q ) = D( q ) / CS
+ IF( RSVEC ) THEN
+ CALL SAXPY( MVL,
+ + -T*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ CALL SAXPY( MVL,
+ + CS*SN*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ END IF
+ ELSE
+ CALL SAXPY( M, T*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ CALL SAXPY( M,
+ + -CS*SN*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ D( p ) = D( p ) / CS
+ D( q ) = D( q )*CS
+ IF( RSVEC ) THEN
+ CALL SAXPY( MVL,
+ + T*APOAQ, V( 1, p ),
+ + 1, V( 1, q ), 1 )
+ CALL SAXPY( MVL,
+ + -CS*SN*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ END IF
+ END IF
+ END IF
+ END IF
+ END IF
+*
+ ELSE
* .. have to use modified Gram-Schmidt like transformation
- CALL SCOPY( M, A(1,p), 1, WORK, 1 )
- CALL SLASCL( 'G',0,0,AAPP,ONE,M,1,WORK,LDA,IERR )
- CALL SLASCL( 'G',0,0,AAQQ,ONE,M,1, A(1,q),LDA,IERR )
- TEMP1 = -AAPQ * D(p) / D(q)
- CALL SAXPY ( M, TEMP1, WORK, 1, A(1,q), 1 )
- CALL SLASCL( 'G',0,0,ONE,AAQQ,M,1, A(1,q),LDA,IERR )
- SVA(q) = AAQQ*SQRT( AMAX1( ZERO, ONE - AAPQ*AAPQ ) )
- MXSINJ = AMAX1( MXSINJ, SFMIN )
- END IF
+ CALL SCOPY( M, A( 1, p ), 1, WORK, 1 )
+ CALL SLASCL( 'G', 0, 0, AAPP, ONE, M,
+ + 1, WORK, LDA, IERR )
+ CALL SLASCL( 'G', 0, 0, AAQQ, ONE, M,
+ + 1, A( 1, q ), LDA, IERR )
+ TEMP1 = -AAPQ*D( p ) / D( q )
+ CALL SAXPY( M, TEMP1, WORK, 1,
+ + A( 1, q ), 1 )
+ CALL SLASCL( 'G', 0, 0, ONE, AAQQ, M,
+ + 1, A( 1, q ), LDA, IERR )
+ SVA( q ) = AAQQ*SQRT( AMAX1( ZERO,
+ + ONE-AAPQ*AAPQ ) )
+ MXSINJ = AMAX1( MXSINJ, SFMIN )
+ END IF
* END IF ROTOK THEN ... ELSE
*
* In the case of cancellation in updating SVA(q), SVA(p)
* recompute SVA(q), SVA(p).
- IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS ) THEN
- IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN
- SVA(q) = SNRM2( M, A(1,q), 1 ) * D(q)
- ELSE
- T = ZERO
- AAQQ = ZERO
- CALL SLASSQ( M, A(1,q), 1, T, AAQQ )
- SVA(q) = T * SQRT(AAQQ) * D(q)
- END IF
- END IF
- IF ( ( AAPP / AAPP0) .LE. ROOTEPS ) THEN
- IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN
- AAPP = SNRM2( M, A(1,p), 1 ) * D(p)
- ELSE
- T = ZERO
- AAPP = ZERO
- CALL SLASSQ( M, A(1,p), 1, T, AAPP )
- AAPP = T * SQRT(AAPP) * D(p)
- END IF
- SVA(p) = AAPP
- END IF
-*
- ELSE
+ IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS )
+ + THEN
+ IF( ( AAQQ.LT.ROOTBIG ) .AND.
+ + ( AAQQ.GT.ROOTSFMIN ) ) THEN
+ SVA( q ) = SNRM2( M, A( 1, q ), 1 )*
+ + D( q )
+ ELSE
+ T = ZERO
+ AAQQ = ZERO
+ CALL SLASSQ( M, A( 1, q ), 1, T,
+ + AAQQ )
+ SVA( q ) = T*SQRT( AAQQ )*D( q )
+ END IF
+ END IF
+ IF( ( AAPP / AAPP0 ).LE.ROOTEPS ) THEN
+ IF( ( AAPP.LT.ROOTBIG ) .AND.
+ + ( AAPP.GT.ROOTSFMIN ) ) THEN
+ AAPP = SNRM2( M, A( 1, p ), 1 )*
+ + D( p )
+ ELSE
+ T = ZERO
+ AAPP = ZERO
+ CALL SLASSQ( M, A( 1, p ), 1, T,
+ + AAPP )
+ AAPP = T*SQRT( AAPP )*D( p )
+ END IF
+ SVA( p ) = AAPP
+ END IF
+*
+ ELSE
* A(:,p) and A(:,q) already numerically orthogonal
- IF ( ir1 .EQ. 0 ) NOTROT = NOTROT + 1
- PSKIPPED = PSKIPPED + 1
- END IF
- ELSE
+ IF( ir1.EQ.0 )NOTROT = NOTROT + 1
+ PSKIPPED = PSKIPPED + 1
+ END IF
+ ELSE
* A(:,q) is zero column
- IF ( ir1. EQ. 0 ) NOTROT = NOTROT + 1
- PSKIPPED = PSKIPPED + 1
- END IF
+ IF( ir1.EQ.0 )NOTROT = NOTROT + 1
+ PSKIPPED = PSKIPPED + 1
+ END IF
*
- IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN
- IF ( ir1 .EQ. 0 ) AAPP = - AAPP
- NOTROT = 0
- GO TO 2103
- END IF
+ IF( ( i.LE.SWBAND ) .AND.
+ + ( PSKIPPED.GT.ROWSKIP ) ) THEN
+ IF( ir1.EQ.0 )AAPP = -AAPP
+ NOTROT = 0
+ GO TO 2103
+ END IF
*
- 2002 CONTINUE
+ 2002 CONTINUE
* END q-LOOP
*
- 2103 CONTINUE
+ 2103 CONTINUE
* bailed out of q-loop
- SVA(p) = AAPP
+ SVA( p ) = AAPP
- ELSE
- SVA(p) = AAPP
- IF ( ( ir1 .EQ. 0 ) .AND. (AAPP .EQ. ZERO) )
- & NOTROT=NOTROT+MIN0(igl+KBL-1,N)-p
- END IF
+ ELSE
+ SVA( p ) = AAPP
+ IF( ( ir1.EQ.0 ) .AND. ( AAPP.EQ.ZERO ) )
+ + NOTROT = NOTROT + MIN0( igl+KBL-1, N ) - p
+ END IF
*
- 2001 CONTINUE
+ 2001 CONTINUE
* end of the p-loop
* end of doing the block ( ibr, ibr )
- 1002 CONTINUE
+ 1002 CONTINUE
* end of ir1-loop
*
*........................................................
* ... go to the off diagonal blocks
*
- igl = ( ibr - 1 ) * KBL + 1
+ igl = ( ibr-1 )*KBL + 1
*
- DO 2010 jbc = ibr + 1, NBL
+ DO 2010 jbc = ibr + 1, NBL
*
- jgl = ( jbc - 1 ) * KBL + 1
+ jgl = ( jbc-1 )*KBL + 1
*
* doing the block at ( ibr, jbc )
*
- IJBLSK = 0
- DO 2100 p = igl, MIN0( igl + KBL - 1, N )
-*
- AAPP = SVA(p)
-*
- IF ( AAPP .GT. ZERO ) THEN
-*
- PSKIPPED = 0
-*
- DO 2200 q = jgl, MIN0( jgl + KBL - 1, N )
-*
- AAQQ = SVA(q)
-*
- IF ( AAQQ .GT. ZERO ) THEN
- AAPP0 = AAPP
-*
-* -#- M x 2 Jacobi SVD -#-
-*
-* -#- Safe Gram matrix computation -#-
-*
- IF ( AAQQ .GE. ONE ) THEN
- IF ( AAPP .GE. AAQQ ) THEN
- ROTOK = ( SMALL*AAPP ) .LE. AAQQ
- ELSE
- ROTOK = ( SMALL*AAQQ ) .LE. AAPP
- END IF
- IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN
- AAPQ = ( SDOT(M, A(1,p), 1, A(1,q), 1 ) *
- & D(p) * D(q) / AAQQ ) / AAPP
- ELSE
- CALL SCOPY( M, A(1,p), 1, WORK, 1 )
- CALL SLASCL( 'G', 0, 0, AAPP, D(p), M,
- & 1, WORK, LDA, IERR )
- AAPQ = SDOT( M, WORK, 1, A(1,q), 1 ) *
- & D(q) / AAQQ
- END IF
- ELSE
- IF ( AAPP .GE. AAQQ ) THEN
- ROTOK = AAPP .LE. ( AAQQ / SMALL )
- ELSE
- ROTOK = AAQQ .LE. ( AAPP / SMALL )
- END IF
- IF ( AAPP .GT. ( SMALL / AAQQ ) ) THEN
- AAPQ = ( SDOT( M, A(1,p), 1, A(1,q), 1 ) *
- & D(p) * D(q) / AAQQ ) / AAPP
- ELSE
- CALL SCOPY( M, A(1,q), 1, WORK, 1 )
- CALL SLASCL( 'G', 0, 0, AAQQ, D(q), M, 1,
- & WORK, LDA, IERR )
- AAPQ = SDOT(M,WORK,1,A(1,p),1) * D(p) / AAPP
- END IF
- END IF
+ IJBLSK = 0
+ DO 2100 p = igl, MIN0( igl+KBL-1, N )
+*
+ AAPP = SVA( p )
+*
+ IF( AAPP.GT.ZERO ) THEN
+*
+ PSKIPPED = 0
+*
+ DO 2200 q = jgl, MIN0( jgl+KBL-1, N )
+*
+ AAQQ = SVA( q )
+*
+ IF( AAQQ.GT.ZERO ) THEN
+ AAPP0 = AAPP
+*
+* .. M x 2 Jacobi SVD ..
+*
+* .. Safe Gram matrix computation ..
+*
+ IF( AAQQ.GE.ONE ) THEN
+ IF( AAPP.GE.AAQQ ) THEN
+ ROTOK = ( SMALL*AAPP ).LE.AAQQ
+ ELSE
+ ROTOK = ( SMALL*AAQQ ).LE.AAPP
+ END IF
+ IF( AAPP.LT.( BIG / AAQQ ) ) THEN
+ AAPQ = ( SDOT( M, A( 1, p ), 1, A( 1,
+ + q ), 1 )*D( p )*D( q ) / AAQQ )
+ + / AAPP
+ ELSE
+ CALL SCOPY( M, A( 1, p ), 1, WORK, 1 )
+ CALL SLASCL( 'G', 0, 0, AAPP, D( p ),
+ + M, 1, WORK, LDA, IERR )
+ AAPQ = SDOT( M, WORK, 1, A( 1, q ),
+ + 1 )*D( q ) / AAQQ
+ END IF
+ ELSE
+ IF( AAPP.GE.AAQQ ) THEN
+ ROTOK = AAPP.LE.( AAQQ / SMALL )
+ ELSE
+ ROTOK = AAQQ.LE.( AAPP / SMALL )
+ END IF
+ IF( AAPP.GT.( SMALL / AAQQ ) ) THEN
+ AAPQ = ( SDOT( M, A( 1, p ), 1, A( 1,
+ + q ), 1 )*D( p )*D( q ) / AAQQ )
+ + / AAPP
+ ELSE
+ CALL SCOPY( M, A( 1, q ), 1, WORK, 1 )
+ CALL SLASCL( 'G', 0, 0, AAQQ, D( q ),
+ + M, 1, WORK, LDA, IERR )
+ AAPQ = SDOT( M, WORK, 1, A( 1, p ),
+ + 1 )*D( p ) / AAPP
+ END IF
+ END IF
*
- MXAAPQ = AMAX1( MXAAPQ, ABS(AAPQ) )
+ MXAAPQ = AMAX1( MXAAPQ, ABS( AAPQ ) )
*
* TO rotate or NOT to rotate, THAT is the question ...
*
- IF ( ABS( AAPQ ) .GT. TOL ) THEN
- NOTROT = 0
+ IF( ABS( AAPQ ).GT.TOL ) THEN
+ NOTROT = 0
* ROTATED = ROTATED + 1
- PSKIPPED = 0
- ISWROT = ISWROT + 1
-*
- IF ( ROTOK ) THEN
-*
- AQOAP = AAQQ / AAPP
- APOAQ = AAPP / AAQQ
- THETA = - HALF * ABS( AQOAP - APOAQ ) / AAPQ
- IF ( AAQQ .GT. AAPP0 ) THETA = - THETA
-*
- IF ( ABS( THETA ) .GT. BIGTHETA ) THEN
- T = HALF / THETA
- FASTR(3) = T * D(p) / D(q)
- FASTR(4) = -T * D(q) / D(p)
- CALL SROTM( M, A(1,p), 1, A(1,q), 1, FASTR )
- IF ( RSVEC )
- & CALL SROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR )
- SVA(q) = AAQQ*SQRT( AMAX1(ZERO,ONE + T*APOAQ*AAPQ) )
- AAPP = AAPP*SQRT( AMAX1(ZERO,ONE - T*AQOAP*AAPQ) )
- MXSINJ = AMAX1( MXSINJ, ABS(T) )
- ELSE
+ PSKIPPED = 0
+ ISWROT = ISWROT + 1
+*
+ IF( ROTOK ) THEN
+*
+ AQOAP = AAQQ / AAPP
+ APOAQ = AAPP / AAQQ
+ THETA = -HALF*ABS( AQOAP-APOAQ ) / AAPQ
+ IF( AAQQ.GT.AAPP0 )THETA = -THETA
+*
+ IF( ABS( THETA ).GT.BIGTHETA ) THEN
+ T = HALF / THETA
+ FASTR( 3 ) = T*D( p ) / D( q )
+ FASTR( 4 ) = -T*D( q ) / D( p )
+ CALL SROTM( M, A( 1, p ), 1,
+ + A( 1, q ), 1, FASTR )
+ IF( RSVEC )CALL SROTM( MVL,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1,
+ + FASTR )
+ SVA( q ) = AAQQ*SQRT( AMAX1( ZERO,
+ + ONE+T*APOAQ*AAPQ ) )
+ AAPP = AAPP*SQRT( AMAX1( ZERO,
+ + ONE-T*AQOAP*AAPQ ) )
+ MXSINJ = AMAX1( MXSINJ, ABS( T ) )
+ ELSE
*
* .. choose correct signum for THETA and rotate
*
- THSIGN = - SIGN(ONE,AAPQ)
- IF ( AAQQ .GT. AAPP0 ) THSIGN = - THSIGN
- T = ONE / ( THETA + THSIGN*SQRT(ONE+THETA*THETA) )
- CS = SQRT( ONE / ( ONE + T*T ) )
- SN = T * CS
- MXSINJ = AMAX1( MXSINJ, ABS(SN) )
- SVA(q) = AAQQ*SQRT( AMAX1(ZERO, ONE+T*APOAQ*AAPQ) )
- AAPP = AAPP*SQRT( ONE - T*AQOAP*AAPQ)
-*
- APOAQ = D(p) / D(q)
- AQOAP = D(q) / D(p)
- IF ( D(p) .GE. ONE ) THEN
-*
- IF ( D(q) .GE. ONE ) THEN
- FASTR(3) = T * APOAQ
- FASTR(4) = - T * AQOAP
- D(p) = D(p) * CS
- D(q) = D(q) * CS
- CALL SROTM( M, A(1,p),1, A(1,q),1, FASTR )
- IF ( RSVEC )
- & CALL SROTM( MVL, V(1,p),1, V(1,q),1, FASTR )
- ELSE
- CALL SAXPY( M, -T*AQOAP, A(1,q),1, A(1,p),1 )
- CALL SAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 )
- IF ( RSVEC ) THEN
- CALL SAXPY( MVL, -T*AQOAP, V(1,q),1, V(1,p),1 )
- CALL SAXPY( MVL,CS*SN*APOAQ,V(1,p),1, V(1,q),1 )
- END IF
- D(p) = D(p) * CS
- D(q) = D(q) / CS
- END IF
- ELSE
- IF ( D(q) .GE. ONE ) THEN
- CALL SAXPY( M, T*APOAQ, A(1,p),1, A(1,q),1 )
- CALL SAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 )
- IF ( RSVEC ) THEN
- CALL SAXPY(MVL,T*APOAQ, V(1,p),1, V(1,q),1 )
- CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1, V(1,p),1 )
- END IF
- D(p) = D(p) / CS
- D(q) = D(q) * CS
- ELSE
- IF ( D(p) .GE. D(q) ) THEN
- CALL SAXPY( M,-T*AQOAP, A(1,q),1,A(1,p),1 )
- CALL SAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 )
- D(p) = D(p) * CS
- D(q) = D(q) / CS
- IF ( RSVEC ) THEN
- CALL SAXPY( MVL, -T*AQOAP, V(1,q),1,V(1,p),1)
- CALL SAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1)
- END IF
- ELSE
- CALL SAXPY(M, T*APOAQ, A(1,p),1,A(1,q),1)
- CALL SAXPY(M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1)
- D(p) = D(p) / CS
- D(q) = D(q) * CS
- IF ( RSVEC ) THEN
- CALL SAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1)
- CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1)
- END IF
- END IF
- END IF
- ENDIF
- END IF
-*
- ELSE
- IF ( AAPP .GT. AAQQ ) THEN
- CALL SCOPY( M, A(1,p), 1, WORK, 1 )
- CALL SLASCL('G',0,0,AAPP,ONE,M,1,WORK,LDA,IERR)
- CALL SLASCL('G',0,0,AAQQ,ONE,M,1, A(1,q),LDA,IERR)
- TEMP1 = -AAPQ * D(p) / D(q)
- CALL SAXPY(M,TEMP1,WORK,1,A(1,q),1)
- CALL SLASCL('G',0,0,ONE,AAQQ,M,1,A(1,q),LDA,IERR)
- SVA(q) = AAQQ*SQRT(AMAX1(ZERO, ONE - AAPQ*AAPQ))
- MXSINJ = AMAX1( MXSINJ, SFMIN )
- ELSE
- CALL SCOPY( M, A(1,q), 1, WORK, 1 )
- CALL SLASCL('G',0,0,AAQQ,ONE,M,1,WORK,LDA,IERR)
- CALL SLASCL('G',0,0,AAPP,ONE,M,1, A(1,p),LDA,IERR)
- TEMP1 = -AAPQ * D(q) / D(p)
- CALL SAXPY(M,TEMP1,WORK,1,A(1,p),1)
- CALL SLASCL('G',0,0,ONE,AAPP,M,1,A(1,p),LDA,IERR)
- SVA(p) = AAPP*SQRT(AMAX1(ZERO, ONE - AAPQ*AAPQ))
- MXSINJ = AMAX1( MXSINJ, SFMIN )
- END IF
- END IF
+ THSIGN = -SIGN( ONE, AAPQ )
+ IF( AAQQ.GT.AAPP0 )THSIGN = -THSIGN
+ T = ONE / ( THETA+THSIGN*
+ + SQRT( ONE+THETA*THETA ) )
+ CS = SQRT( ONE / ( ONE+T*T ) )
+ SN = T*CS
+ MXSINJ = AMAX1( MXSINJ, ABS( SN ) )
+ SVA( q ) = AAQQ*SQRT( AMAX1( ZERO,
+ + ONE+T*APOAQ*AAPQ ) )
+ AAPP = AAPP*SQRT( ONE-T*AQOAP*AAPQ )
+*
+ APOAQ = D( p ) / D( q )
+ AQOAP = D( q ) / D( p )
+ IF( D( p ).GE.ONE ) THEN
+*
+ IF( D( q ).GE.ONE ) THEN
+ FASTR( 3 ) = T*APOAQ
+ FASTR( 4 ) = -T*AQOAP
+ D( p ) = D( p )*CS
+ D( q ) = D( q )*CS
+ CALL SROTM( M, A( 1, p ), 1,
+ + A( 1, q ), 1,
+ + FASTR )
+ IF( RSVEC )CALL SROTM( MVL,
+ + V( 1, p ), 1, V( 1, q ),
+ + 1, FASTR )
+ ELSE
+ CALL SAXPY( M, -T*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ CALL SAXPY( M, CS*SN*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ IF( RSVEC ) THEN
+ CALL SAXPY( MVL, -T*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ CALL SAXPY( MVL,
+ + CS*SN*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ END IF
+ D( p ) = D( p )*CS
+ D( q ) = D( q ) / CS
+ END IF
+ ELSE
+ IF( D( q ).GE.ONE ) THEN
+ CALL SAXPY( M, T*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ CALL SAXPY( M, -CS*SN*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ IF( RSVEC ) THEN
+ CALL SAXPY( MVL, T*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ CALL SAXPY( MVL,
+ + -CS*SN*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ END IF
+ D( p ) = D( p ) / CS
+ D( q ) = D( q )*CS
+ ELSE
+ IF( D( p ).GE.D( q ) ) THEN
+ CALL SAXPY( M, -T*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ CALL SAXPY( M, CS*SN*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ D( p ) = D( p )*CS
+ D( q ) = D( q ) / CS
+ IF( RSVEC ) THEN
+ CALL SAXPY( MVL,
+ + -T*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ CALL SAXPY( MVL,
+ + CS*SN*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ END IF
+ ELSE
+ CALL SAXPY( M, T*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ CALL SAXPY( M,
+ + -CS*SN*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ D( p ) = D( p ) / CS
+ D( q ) = D( q )*CS
+ IF( RSVEC ) THEN
+ CALL SAXPY( MVL,
+ + T*APOAQ, V( 1, p ),
+ + 1, V( 1, q ), 1 )
+ CALL SAXPY( MVL,
+ + -CS*SN*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ END IF
+ END IF
+ END IF
+ END IF
+ END IF
+*
+ ELSE
+ IF( AAPP.GT.AAQQ ) THEN
+ CALL SCOPY( M, A( 1, p ), 1, WORK,
+ + 1 )
+ CALL SLASCL( 'G', 0, 0, AAPP, ONE,
+ + M, 1, WORK, LDA, IERR )
+ CALL SLASCL( 'G', 0, 0, AAQQ, ONE,
+ + M, 1, A( 1, q ), LDA,
+ + IERR )
+ TEMP1 = -AAPQ*D( p ) / D( q )
+ CALL SAXPY( M, TEMP1, WORK, 1,
+ + A( 1, q ), 1 )
+ CALL SLASCL( 'G', 0, 0, ONE, AAQQ,
+ + M, 1, A( 1, q ), LDA,
+ + IERR )
+ SVA( q ) = AAQQ*SQRT( AMAX1( ZERO,
+ + ONE-AAPQ*AAPQ ) )
+ MXSINJ = AMAX1( MXSINJ, SFMIN )
+ ELSE
+ CALL SCOPY( M, A( 1, q ), 1, WORK,
+ + 1 )
+ CALL SLASCL( 'G', 0, 0, AAQQ, ONE,
+ + M, 1, WORK, LDA, IERR )
+ CALL SLASCL( 'G', 0, 0, AAPP, ONE,
+ + M, 1, A( 1, p ), LDA,
+ + IERR )
+ TEMP1 = -AAPQ*D( q ) / D( p )
+ CALL SAXPY( M, TEMP1, WORK, 1,
+ + A( 1, p ), 1 )
+ CALL SLASCL( 'G', 0, 0, ONE, AAPP,
+ + M, 1, A( 1, p ), LDA,
+ + IERR )
+ SVA( p ) = AAPP*SQRT( AMAX1( ZERO,
+ + ONE-AAPQ*AAPQ ) )
+ MXSINJ = AMAX1( MXSINJ, SFMIN )
+ END IF
+ END IF
* END IF ROTOK THEN ... ELSE
*
* In the case of cancellation in updating SVA(q)
* .. recompute SVA(q)
- IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS ) THEN
- IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN
- SVA(q) = SNRM2( M, A(1,q), 1 ) * D(q)
- ELSE
- T = ZERO
- AAQQ = ZERO
- CALL SLASSQ( M, A(1,q), 1, T, AAQQ )
- SVA(q) = T * SQRT(AAQQ) * D(q)
- END IF
- END IF
- IF ( (AAPP / AAPP0 )**2 .LE. ROOTEPS ) THEN
- IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN
- AAPP = SNRM2( M, A(1,p), 1 ) * D(p)
- ELSE
- T = ZERO
- AAPP = ZERO
- CALL SLASSQ( M, A(1,p), 1, T, AAPP )
- AAPP = T * SQRT(AAPP) * D(p)
- END IF
- SVA(p) = AAPP
- END IF
+ IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS )
+ + THEN
+ IF( ( AAQQ.LT.ROOTBIG ) .AND.
+ + ( AAQQ.GT.ROOTSFMIN ) ) THEN
+ SVA( q ) = SNRM2( M, A( 1, q ), 1 )*
+ + D( q )
+ ELSE
+ T = ZERO
+ AAQQ = ZERO
+ CALL SLASSQ( M, A( 1, q ), 1, T,
+ + AAQQ )
+ SVA( q ) = T*SQRT( AAQQ )*D( q )
+ END IF
+ END IF
+ IF( ( AAPP / AAPP0 )**2.LE.ROOTEPS ) THEN
+ IF( ( AAPP.LT.ROOTBIG ) .AND.
+ + ( AAPP.GT.ROOTSFMIN ) ) THEN
+ AAPP = SNRM2( M, A( 1, p ), 1 )*
+ + D( p )
+ ELSE
+ T = ZERO
+ AAPP = ZERO
+ CALL SLASSQ( M, A( 1, p ), 1, T,
+ + AAPP )
+ AAPP = T*SQRT( AAPP )*D( p )
+ END IF
+ SVA( p ) = AAPP
+ END IF
* end of OK rotation
- ELSE
- NOTROT = NOTROT + 1
- PSKIPPED = PSKIPPED + 1
- IJBLSK = IJBLSK + 1
- END IF
- ELSE
- NOTROT = NOTROT + 1
- PSKIPPED = PSKIPPED + 1
- IJBLSK = IJBLSK + 1
- END IF
+ ELSE
+ NOTROT = NOTROT + 1
+ PSKIPPED = PSKIPPED + 1
+ IJBLSK = IJBLSK + 1
+ END IF
+ ELSE
+ NOTROT = NOTROT + 1
+ PSKIPPED = PSKIPPED + 1
+ IJBLSK = IJBLSK + 1
+ END IF
*
- IF ( ( i .LE. SWBAND ) .AND. ( IJBLSK .GE. BLSKIP ) ) THEN
- SVA(p) = AAPP
- NOTROT = 0
- GO TO 2011
- END IF
- IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN
- AAPP = -AAPP
- NOTROT = 0
- GO TO 2203
- END IF
+ IF( ( i.LE.SWBAND ) .AND. ( IJBLSK.GE.BLSKIP ) )
+ + THEN
+ SVA( p ) = AAPP
+ NOTROT = 0
+ GO TO 2011
+ END IF
+ IF( ( i.LE.SWBAND ) .AND.
+ + ( PSKIPPED.GT.ROWSKIP ) ) THEN
+ AAPP = -AAPP
+ NOTROT = 0
+ GO TO 2203
+ END IF
*
- 2200 CONTINUE
+ 2200 CONTINUE
* end of the q-loop
- 2203 CONTINUE
+ 2203 CONTINUE
*
- SVA(p) = AAPP
+ SVA( p ) = AAPP
*
- ELSE
- IF ( AAPP .EQ. ZERO ) NOTROT=NOTROT+MIN0(jgl+KBL-1,N)-jgl+1
- IF ( AAPP .LT. ZERO ) NOTROT = 0
- END IF
+ ELSE
+ IF( AAPP.EQ.ZERO )NOTROT = NOTROT +
+ + MIN0( jgl+KBL-1, N ) - jgl + 1
+ IF( AAPP.LT.ZERO )NOTROT = 0
+ END IF
- 2100 CONTINUE
+ 2100 CONTINUE
* end of the p-loop
- 2010 CONTINUE
+ 2010 CONTINUE
* end of the jbc-loop
- 2011 CONTINUE
+ 2011 CONTINUE
*2011 bailed out of the jbc-loop
- DO 2012 p = igl, MIN0( igl + KBL - 1, N )
- SVA(p) = ABS(SVA(p))
- 2012 CONTINUE
+ DO 2012 p = igl, MIN0( igl+KBL-1, N )
+ SVA( p ) = ABS( SVA( p ) )
+ 2012 CONTINUE
*
- 2000 CONTINUE
+ 2000 CONTINUE
*2000 :: end of the ibr-loop
*
* .. update SVA(N)
- IF ((SVA(N) .LT. ROOTBIG).AND.(SVA(N) .GT. ROOTSFMIN)) THEN
- SVA(N) = SNRM2( M, A(1,N), 1 ) * D(N)
- ELSE
- T = ZERO
- AAPP = ZERO
- CALL SLASSQ( M, A(1,N), 1, T, AAPP )
- SVA(N) = T * SQRT(AAPP) * D(N)
- END IF
+ IF( ( SVA( N ).LT.ROOTBIG ) .AND. ( SVA( N ).GT.ROOTSFMIN ) )
+ + THEN
+ SVA( N ) = SNRM2( M, A( 1, N ), 1 )*D( N )
+ ELSE
+ T = ZERO
+ AAPP = ZERO
+ CALL SLASSQ( M, A( 1, N ), 1, T, AAPP )
+ SVA( N ) = T*SQRT( AAPP )*D( N )
+ END IF
*
* Additional steering devices
*
- IF ( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR.
- & ( ISWROT .LE. N ) ) )
- & SWBAND = i
+ IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR.
+ + ( ISWROT.LE.N ) ) )SWBAND = i
*
- IF ((i.GT.SWBAND+1).AND. (MXAAPQ.LT.FLOAT(N)*TOL).AND.
- & (FLOAT(N)*MXAAPQ*MXSINJ.LT.TOL))THEN
- GO TO 1994
- END IF
+ IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.FLOAT( N )*TOL ) .AND.
+ + ( FLOAT( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN
+ GO TO 1994
+ END IF
*
- IF ( NOTROT .GE. EMPTSW ) GO TO 1994
+ IF( NOTROT.GE.EMPTSW )GO TO 1994
1993 CONTINUE
* end i=1:NSWEEP loop
*
* Sort the vector D.
DO 5991 p = 1, N - 1
- q = ISAMAX( N-p+1, SVA(p), 1 ) + p - 1
- IF ( p .NE. q ) THEN
- TEMP1 = SVA(p)
- SVA(p) = SVA(q)
- SVA(q) = TEMP1
- TEMP1 = D(p)
- D(p) = D(q)
- D(q) = TEMP1
- CALL SSWAP( M, A(1,p), 1, A(1,q), 1 )
- IF ( RSVEC ) CALL SSWAP( MVL, V(1,p), 1, V(1,q), 1 )
+ q = ISAMAX( N-p+1, SVA( p ), 1 ) + p - 1
+ IF( p.NE.q ) THEN
+ TEMP1 = SVA( p )
+ SVA( p ) = SVA( q )
+ SVA( q ) = TEMP1
+ TEMP1 = D( p )
+ D( p ) = D( q )
+ D( q ) = TEMP1
+ CALL SSWAP( M, A( 1, p ), 1, A( 1, q ), 1 )
+ IF( RSVEC )CALL SSWAP( MVL, V( 1, p ), 1, V( 1, q ), 1 )
END IF
5991 CONTINUE
*
* .. END OF SGSVJ0
* ..
END
-*
SUBROUTINE SGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV,
- & EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )
+ + EPS, SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )
*
* -- LAPACK routine (version 3.2) --
*
* computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the
* eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0.
*
-* -#- Scalar Arguments -#-
-*
- IMPLICIT NONE
- REAL EPS, SFMIN, TOL
- INTEGER INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP
- CHARACTER*1 JOBV
-*
-* -#- Array Arguments -#-
-*
- REAL A( LDA, * ), D( N ), SVA( N ), V( LDV, * ),
- & WORK( LWORK )
+ IMPLICIT NONE
+* ..
+* .. Scalar Arguments ..
+ REAL EPS, SFMIN, TOL
+ INTEGER INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP
+ CHARACTER*1 JOBV
+* ..
+* .. Array Arguments ..
+ REAL A( LDA, * ), D( N ), SVA( N ), V( LDV, * ),
+ + WORK( LWORK )
* ..
*
* Purpose
-* ~~~~~~~
+* =======
+*
* SGSVJ1 is called from SGESVJ as a pre-processor and that is its main
* purpose. It applies Jacobi rotations in the same way as SGESVJ does, but
* it targets only particular pivots and it does not check convergence
* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)
*
* Arguments
-* ~~~~~~~~~
+* =========
*
* JOBV (input) CHARACTER*1
* Specifies whether the output from this procedure is used
* = 0 : successful exit.
* < 0 : if INFO = -i, then the i-th argument had an illegal value
*
-* -#- Local Parameters -#-
-*
- REAL ZERO, HALF, ONE, TWO
- PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0, TWO = 2.0E0 )
-
-* -#- Local Scalars -#-
-*
- REAL AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG, BIGTHETA,
- & CS, LARGE, MXAAPQ, MXSINJ, ROOTBIG,ROOTEPS, ROOTSFMIN,
- & ROOTTOL, SMALL, SN, T, TEMP1, THETA, THSIGN
- INTEGER BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK, ISWROT, jbc,
- & jgl, KBL, MVL, NOTROT, nblc, nblr, p, PSKIPPED, q,
- & ROWSKIP, SWBAND
- LOGICAL APPLV, ROTOK, RSVEC
-*
-* Local Arrays
- REAL FASTR(5)
-*
-* Intrinsic Functions
- INTRINSIC ABS, AMAX1, FLOAT, MIN0, SIGN, SQRT
+* =====================================================================
*
-* External Functions
- REAL SDOT, SNRM2
- INTEGER ISAMAX
- LOGICAL LSAME
- EXTERNAL ISAMAX, LSAME, SDOT, SNRM2
-*
-* External Subroutines
- EXTERNAL SAXPY, SCOPY, SLASCL, SLASSQ, SROTM, SSWAP
+* .. Local Parameters ..
+ REAL ZERO, HALF, ONE, TWO
+ PARAMETER ( ZERO = 0.0E0, HALF = 0.5E0, ONE = 1.0E0,
+ + TWO = 2.0E0 )
+* ..
+* .. Local Scalars ..
+ REAL AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,
+ + BIGTHETA, CS, LARGE, MXAAPQ, MXSINJ, ROOTBIG,
+ + ROOTEPS, ROOTSFMIN, ROOTTOL, SMALL, SN, T,
+ + TEMP1, THETA, THSIGN
+ INTEGER BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK,
+ + ISWROT, jbc, jgl, KBL, MVL, NOTROT, nblc, nblr,
+ + p, PSKIPPED, q, ROWSKIP, SWBAND
+ LOGICAL APPLV, ROTOK, RSVEC
+* ..
+* .. Local Arrays ..
+ REAL FASTR( 5 )
+* ..
+* .. Intrinsic Functions ..
+ INTRINSIC ABS, AMAX1, FLOAT, MIN0, SIGN, SQRT
+* ..
+* .. External Functions ..
+ REAL SDOT, SNRM2
+ INTEGER ISAMAX
+ LOGICAL LSAME
+ EXTERNAL ISAMAX, LSAME, SDOT, SNRM2
+* ..
+* .. External Subroutines ..
+ EXTERNAL SAXPY, SCOPY, SLASCL, SLASSQ, SROTM, SSWAP
+* ..
+* .. Executable Statements ..
*
+* Test the input parameters.
*
- APPLV = LSAME(JOBV,'A')
- RSVEC = LSAME(JOBV,'V')
- IF ( .NOT.( RSVEC .OR. APPLV .OR. LSAME(JOBV,'N'))) THEN
+ APPLV = LSAME( JOBV, 'A' )
+ RSVEC = LSAME( JOBV, 'V' )
+ IF( .NOT.( RSVEC .OR. APPLV .OR. LSAME( JOBV, 'N' ) ) ) THEN
INFO = -1
- ELSE IF ( M .LT. 0 ) THEN
+ ELSE IF( M.LT.0 ) THEN
INFO = -2
- ELSE IF ( ( N .LT. 0 ) .OR. ( N .GT. M )) THEN
+ ELSE IF( ( N.LT.0 ) .OR. ( N.GT.M ) ) THEN
INFO = -3
- ELSE IF ( N1 .LT. 0 ) THEN
+ ELSE IF( N1.LT.0 ) THEN
INFO = -4
- ELSE IF ( LDA .LT. M ) THEN
+ ELSE IF( LDA.LT.M ) THEN
INFO = -6
- ELSE IF ( MV .LT. 0 ) THEN
+ ELSE IF( MV.LT.0 ) THEN
INFO = -9
- ELSE IF ( LDV .LT. M ) THEN
+ ELSE IF( LDV.LT.M ) THEN
INFO = -11
- ELSE IF ( TOL .LE. EPS ) THEN
+ ELSE IF( TOL.LE.EPS ) THEN
INFO = -14
- ELSE IF ( NSWEEP .LT. 0 ) THEN
+ ELSE IF( NSWEEP.LT.0 ) THEN
INFO = -15
- ELSE IF ( LWORK .LT. M ) THEN
+ ELSE IF( LWORK.LT.M ) THEN
INFO = -17
ELSE
INFO = 0
END IF
*
* #:(
- IF ( INFO .NE. 0 ) THEN
+ IF( INFO.NE.0 ) THEN
CALL XERBLA( 'SGSVJ1', -INFO )
RETURN
END IF
*
- IF ( RSVEC ) THEN
+ IF( RSVEC ) THEN
MVL = N
- ELSE IF ( APPLV ) THEN
+ ELSE IF( APPLV ) THEN
MVL = MV
END IF
RSVEC = RSVEC .OR. APPLV
- ROOTEPS = SQRT(EPS)
- ROOTSFMIN = SQRT(SFMIN)
- SMALL = SFMIN / EPS
- BIG = ONE / SFMIN
- ROOTBIG = ONE / ROOTSFMIN
- LARGE = BIG / SQRT(FLOAT(M*N))
- BIGTHETA = ONE / ROOTEPS
- ROOTTOL = SQRT(TOL)
+ ROOTEPS = SQRT( EPS )
+ ROOTSFMIN = SQRT( SFMIN )
+ SMALL = SFMIN / EPS
+ BIG = ONE / SFMIN
+ ROOTBIG = ONE / ROOTSFMIN
+ LARGE = BIG / SQRT( FLOAT( M*N ) )
+ BIGTHETA = ONE / ROOTEPS
+ ROOTTOL = SQRT( TOL )
*
-* -#- Initialize the right singular vector matrix -#-
+* .. Initialize the right singular vector matrix ..
*
* RSVEC = LSAME( JOBV, 'Y' )
*
- EMPTSW = N1 * ( N - N1 )
- NOTROT = 0
- FASTR(1) = ZERO
+ EMPTSW = N1*( N-N1 )
+ NOTROT = 0
+ FASTR( 1 ) = ZERO
*
-* -#- Row-cyclic pivot strategy with de Rijk's pivoting -#-
+* .. Row-cyclic pivot strategy with de Rijk's pivoting ..
*
- KBL = MIN0(8,N)
+ KBL = MIN0( 8, N )
NBLR = N1 / KBL
- IF ( ( NBLR * KBL ) .NE. N1 ) NBLR = NBLR + 1
+ IF( ( NBLR*KBL ).NE.N1 )NBLR = NBLR + 1
* .. the tiling is nblr-by-nblc [tiles]
- NBLC = ( N - N1 ) / KBL
- IF ( ( NBLC * KBL ) .NE. ( N - N1 ) ) NBLC = NBLC + 1
+ NBLC = ( N-N1 ) / KBL
+ IF( ( NBLC*KBL ).NE.( N-N1 ) )NBLC = NBLC + 1
BLSKIP = ( KBL**2 ) + 1
*[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL.
DO 1993 i = 1, NSWEEP
* .. go go go ...
*
- MXAAPQ = ZERO
- MXSINJ = ZERO
- ISWROT = 0
+ MXAAPQ = ZERO
+ MXSINJ = ZERO
+ ISWROT = 0
*
- NOTROT = 0
- PSKIPPED = 0
+ NOTROT = 0
+ PSKIPPED = 0
*
- DO 2000 ibr = 1, NBLR
+ DO 2000 ibr = 1, NBLR
- igl = ( ibr - 1 ) * KBL + 1
+ igl = ( ibr-1 )*KBL + 1
*
*
*........................................................
* ... go to the off diagonal blocks
- igl = ( ibr - 1 ) * KBL + 1
+ igl = ( ibr-1 )*KBL + 1
- DO 2010 jbc = 1, NBLC
+ DO 2010 jbc = 1, NBLC
- jgl = N1 + ( jbc - 1 ) * KBL + 1
+ jgl = N1 + ( jbc-1 )*KBL + 1
* doing the block at ( ibr, jbc )
- IJBLSK = 0
- DO 2100 p = igl, MIN0( igl + KBL - 1, N1 )
+ IJBLSK = 0
+ DO 2100 p = igl, MIN0( igl+KBL-1, N1 )
- AAPP = SVA(p)
+ AAPP = SVA( p )
- IF ( AAPP .GT. ZERO ) THEN
+ IF( AAPP.GT.ZERO ) THEN
- PSKIPPED = 0
+ PSKIPPED = 0
- DO 2200 q = jgl, MIN0( jgl + KBL - 1, N )
+ DO 2200 q = jgl, MIN0( jgl+KBL-1, N )
*
- AAQQ = SVA(q)
+ AAQQ = SVA( q )
- IF ( AAQQ .GT. ZERO ) THEN
- AAPP0 = AAPP
-*
-* -#- M x 2 Jacobi SVD -#-
-*
-* -#- Safe Gram matrix computation -#-
-*
- IF ( AAQQ .GE. ONE ) THEN
- IF ( AAPP .GE. AAQQ ) THEN
- ROTOK = ( SMALL*AAPP ) .LE. AAQQ
- ELSE
- ROTOK = ( SMALL*AAQQ ) .LE. AAPP
- END IF
- IF ( AAPP .LT. ( BIG / AAQQ ) ) THEN
- AAPQ = ( SDOT(M, A(1,p), 1, A(1,q), 1 ) *
- & D(p) * D(q) / AAQQ ) / AAPP
- ELSE
- CALL SCOPY( M, A(1,p), 1, WORK, 1 )
- CALL SLASCL( 'G', 0, 0, AAPP, D(p), M,
- & 1, WORK, LDA, IERR )
- AAPQ = SDOT( M, WORK, 1, A(1,q), 1 ) *
- & D(q) / AAQQ
- END IF
- ELSE
- IF ( AAPP .GE. AAQQ ) THEN
- ROTOK = AAPP .LE. ( AAQQ / SMALL )
- ELSE
- ROTOK = AAQQ .LE. ( AAPP / SMALL )
- END IF
- IF ( AAPP .GT. ( SMALL / AAQQ ) ) THEN
- AAPQ = ( SDOT( M, A(1,p), 1, A(1,q), 1 ) *
- & D(p) * D(q) / AAQQ ) / AAPP
- ELSE
- CALL SCOPY( M, A(1,q), 1, WORK, 1 )
- CALL SLASCL( 'G', 0, 0, AAQQ, D(q), M, 1,
- & WORK, LDA, IERR )
- AAPQ = SDOT(M,WORK,1,A(1,p),1) * D(p) / AAPP
- END IF
- END IF
+ IF( AAQQ.GT.ZERO ) THEN
+ AAPP0 = AAPP
+*
+* .. M x 2 Jacobi SVD ..
+*
+* .. Safe Gram matrix computation ..
+*
+ IF( AAQQ.GE.ONE ) THEN
+ IF( AAPP.GE.AAQQ ) THEN
+ ROTOK = ( SMALL*AAPP ).LE.AAQQ
+ ELSE
+ ROTOK = ( SMALL*AAQQ ).LE.AAPP
+ END IF
+ IF( AAPP.LT.( BIG / AAQQ ) ) THEN
+ AAPQ = ( SDOT( M, A( 1, p ), 1, A( 1,
+ + q ), 1 )*D( p )*D( q ) / AAQQ )
+ + / AAPP
+ ELSE
+ CALL SCOPY( M, A( 1, p ), 1, WORK, 1 )
+ CALL SLASCL( 'G', 0, 0, AAPP, D( p ),
+ + M, 1, WORK, LDA, IERR )
+ AAPQ = SDOT( M, WORK, 1, A( 1, q ),
+ + 1 )*D( q ) / AAQQ
+ END IF
+ ELSE
+ IF( AAPP.GE.AAQQ ) THEN
+ ROTOK = AAPP.LE.( AAQQ / SMALL )
+ ELSE
+ ROTOK = AAQQ.LE.( AAPP / SMALL )
+ END IF
+ IF( AAPP.GT.( SMALL / AAQQ ) ) THEN
+ AAPQ = ( SDOT( M, A( 1, p ), 1, A( 1,
+ + q ), 1 )*D( p )*D( q ) / AAQQ )
+ + / AAPP
+ ELSE
+ CALL SCOPY( M, A( 1, q ), 1, WORK, 1 )
+ CALL SLASCL( 'G', 0, 0, AAQQ, D( q ),
+ + M, 1, WORK, LDA, IERR )
+ AAPQ = SDOT( M, WORK, 1, A( 1, p ),
+ + 1 )*D( p ) / AAPP
+ END IF
+ END IF
- MXAAPQ = AMAX1( MXAAPQ, ABS(AAPQ) )
+ MXAAPQ = AMAX1( MXAAPQ, ABS( AAPQ ) )
* TO rotate or NOT to rotate, THAT is the question ...
*
- IF ( ABS( AAPQ ) .GT. TOL ) THEN
- NOTROT = 0
+ IF( ABS( AAPQ ).GT.TOL ) THEN
+ NOTROT = 0
* ROTATED = ROTATED + 1
- PSKIPPED = 0
- ISWROT = ISWROT + 1
+ PSKIPPED = 0
+ ISWROT = ISWROT + 1
*
- IF ( ROTOK ) THEN
+ IF( ROTOK ) THEN
*
- AQOAP = AAQQ / AAPP
- APOAQ = AAPP / AAQQ
- THETA = - HALF * ABS( AQOAP - APOAQ ) / AAPQ
- IF ( AAQQ .GT. AAPP0 ) THETA = - THETA
+ AQOAP = AAQQ / AAPP
+ APOAQ = AAPP / AAQQ
+ THETA = -HALF*ABS( AQOAP-APOAQ ) / AAPQ
+ IF( AAQQ.GT.AAPP0 )THETA = -THETA
- IF ( ABS( THETA ) .GT. BIGTHETA ) THEN
- T = HALF / THETA
- FASTR(3) = T * D(p) / D(q)
- FASTR(4) = -T * D(q) / D(p)
- CALL SROTM( M, A(1,p), 1, A(1,q), 1, FASTR )
- IF ( RSVEC )
- & CALL SROTM( MVL, V(1,p), 1, V(1,q), 1, FASTR )
- SVA(q) = AAQQ*SQRT( AMAX1(ZERO,ONE + T*APOAQ*AAPQ) )
- AAPP = AAPP*SQRT( AMAX1(ZERO,ONE - T*AQOAP*AAPQ) )
- MXSINJ = AMAX1( MXSINJ, ABS(T) )
- ELSE
+ IF( ABS( THETA ).GT.BIGTHETA ) THEN
+ T = HALF / THETA
+ FASTR( 3 ) = T*D( p ) / D( q )
+ FASTR( 4 ) = -T*D( q ) / D( p )
+ CALL SROTM( M, A( 1, p ), 1,
+ + A( 1, q ), 1, FASTR )
+ IF( RSVEC )CALL SROTM( MVL,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1,
+ + FASTR )
+ SVA( q ) = AAQQ*SQRT( AMAX1( ZERO,
+ + ONE+T*APOAQ*AAPQ ) )
+ AAPP = AAPP*SQRT( AMAX1( ZERO,
+ + ONE-T*AQOAP*AAPQ ) )
+ MXSINJ = AMAX1( MXSINJ, ABS( T ) )
+ ELSE
*
* .. choose correct signum for THETA and rotate
*
- THSIGN = - SIGN(ONE,AAPQ)
- IF ( AAQQ .GT. AAPP0 ) THSIGN = - THSIGN
- T = ONE / ( THETA + THSIGN*SQRT(ONE+THETA*THETA) )
- CS = SQRT( ONE / ( ONE + T*T ) )
- SN = T * CS
- MXSINJ = AMAX1( MXSINJ, ABS(SN) )
- SVA(q) = AAQQ*SQRT( AMAX1(ZERO, ONE+T*APOAQ*AAPQ) )
- AAPP = AAPP*SQRT( ONE - T*AQOAP*AAPQ)
+ THSIGN = -SIGN( ONE, AAPQ )
+ IF( AAQQ.GT.AAPP0 )THSIGN = -THSIGN
+ T = ONE / ( THETA+THSIGN*
+ + SQRT( ONE+THETA*THETA ) )
+ CS = SQRT( ONE / ( ONE+T*T ) )
+ SN = T*CS
+ MXSINJ = AMAX1( MXSINJ, ABS( SN ) )
+ SVA( q ) = AAQQ*SQRT( AMAX1( ZERO,
+ + ONE+T*APOAQ*AAPQ ) )
+ AAPP = AAPP*SQRT( ONE-T*AQOAP*AAPQ )
- APOAQ = D(p) / D(q)
- AQOAP = D(q) / D(p)
- IF ( D(p) .GE. ONE ) THEN
-*
- IF ( D(q) .GE. ONE ) THEN
- FASTR(3) = T * APOAQ
- FASTR(4) = - T * AQOAP
- D(p) = D(p) * CS
- D(q) = D(q) * CS
- CALL SROTM( M, A(1,p),1, A(1,q),1, FASTR )
- IF ( RSVEC )
- & CALL SROTM( MVL, V(1,p),1, V(1,q),1, FASTR )
- ELSE
- CALL SAXPY( M, -T*AQOAP, A(1,q),1, A(1,p),1 )
- CALL SAXPY( M, CS*SN*APOAQ, A(1,p),1, A(1,q),1 )
- IF ( RSVEC ) THEN
- CALL SAXPY( MVL, -T*AQOAP, V(1,q),1, V(1,p),1 )
- CALL SAXPY( MVL,CS*SN*APOAQ,V(1,p),1, V(1,q),1 )
- END IF
- D(p) = D(p) * CS
- D(q) = D(q) / CS
- END IF
- ELSE
- IF ( D(q) .GE. ONE ) THEN
- CALL SAXPY( M, T*APOAQ, A(1,p),1, A(1,q),1 )
- CALL SAXPY( M,-CS*SN*AQOAP, A(1,q),1, A(1,p),1 )
- IF ( RSVEC ) THEN
- CALL SAXPY(MVL,T*APOAQ, V(1,p),1, V(1,q),1 )
- CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1, V(1,p),1 )
- END IF
- D(p) = D(p) / CS
- D(q) = D(q) * CS
- ELSE
- IF ( D(p) .GE. D(q) ) THEN
- CALL SAXPY( M,-T*AQOAP, A(1,q),1,A(1,p),1 )
- CALL SAXPY( M,CS*SN*APOAQ,A(1,p),1,A(1,q),1 )
- D(p) = D(p) * CS
- D(q) = D(q) / CS
- IF ( RSVEC ) THEN
- CALL SAXPY( MVL, -T*AQOAP, V(1,q),1,V(1,p),1)
- CALL SAXPY(MVL,CS*SN*APOAQ,V(1,p),1,V(1,q),1)
- END IF
- ELSE
- CALL SAXPY(M, T*APOAQ, A(1,p),1,A(1,q),1)
- CALL SAXPY(M,-CS*SN*AQOAP,A(1,q),1,A(1,p),1)
- D(p) = D(p) / CS
- D(q) = D(q) * CS
- IF ( RSVEC ) THEN
- CALL SAXPY(MVL, T*APOAQ, V(1,p),1,V(1,q),1)
- CALL SAXPY(MVL,-CS*SN*AQOAP,V(1,q),1,V(1,p),1)
- END IF
- END IF
- END IF
- ENDIF
- END IF
+ APOAQ = D( p ) / D( q )
+ AQOAP = D( q ) / D( p )
+ IF( D( p ).GE.ONE ) THEN
+*
+ IF( D( q ).GE.ONE ) THEN
+ FASTR( 3 ) = T*APOAQ
+ FASTR( 4 ) = -T*AQOAP
+ D( p ) = D( p )*CS
+ D( q ) = D( q )*CS
+ CALL SROTM( M, A( 1, p ), 1,
+ + A( 1, q ), 1,
+ + FASTR )
+ IF( RSVEC )CALL SROTM( MVL,
+ + V( 1, p ), 1, V( 1, q ),
+ + 1, FASTR )
+ ELSE
+ CALL SAXPY( M, -T*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ CALL SAXPY( M, CS*SN*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ IF( RSVEC ) THEN
+ CALL SAXPY( MVL, -T*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ CALL SAXPY( MVL,
+ + CS*SN*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ END IF
+ D( p ) = D( p )*CS
+ D( q ) = D( q ) / CS
+ END IF
+ ELSE
+ IF( D( q ).GE.ONE ) THEN
+ CALL SAXPY( M, T*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ CALL SAXPY( M, -CS*SN*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ IF( RSVEC ) THEN
+ CALL SAXPY( MVL, T*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ CALL SAXPY( MVL,
+ + -CS*SN*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ END IF
+ D( p ) = D( p ) / CS
+ D( q ) = D( q )*CS
+ ELSE
+ IF( D( p ).GE.D( q ) ) THEN
+ CALL SAXPY( M, -T*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ CALL SAXPY( M, CS*SN*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ D( p ) = D( p )*CS
+ D( q ) = D( q ) / CS
+ IF( RSVEC ) THEN
+ CALL SAXPY( MVL,
+ + -T*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ CALL SAXPY( MVL,
+ + CS*SN*APOAQ,
+ + V( 1, p ), 1,
+ + V( 1, q ), 1 )
+ END IF
+ ELSE
+ CALL SAXPY( M, T*APOAQ,
+ + A( 1, p ), 1,
+ + A( 1, q ), 1 )
+ CALL SAXPY( M,
+ + -CS*SN*AQOAP,
+ + A( 1, q ), 1,
+ + A( 1, p ), 1 )
+ D( p ) = D( p ) / CS
+ D( q ) = D( q )*CS
+ IF( RSVEC ) THEN
+ CALL SAXPY( MVL,
+ + T*APOAQ, V( 1, p ),
+ + 1, V( 1, q ), 1 )
+ CALL SAXPY( MVL,
+ + -CS*SN*AQOAP,
+ + V( 1, q ), 1,
+ + V( 1, p ), 1 )
+ END IF
+ END IF
+ END IF
+ END IF
+ END IF
- ELSE
- IF ( AAPP .GT. AAQQ ) THEN
- CALL SCOPY( M, A(1,p), 1, WORK, 1 )
- CALL SLASCL('G',0,0,AAPP,ONE,M,1,WORK,LDA,IERR)
- CALL SLASCL('G',0,0,AAQQ,ONE,M,1, A(1,q),LDA,IERR)
- TEMP1 = -AAPQ * D(p) / D(q)
- CALL SAXPY(M,TEMP1,WORK,1,A(1,q),1)
- CALL SLASCL('G',0,0,ONE,AAQQ,M,1,A(1,q),LDA,IERR)
- SVA(q) = AAQQ*SQRT(AMAX1(ZERO, ONE - AAPQ*AAPQ))
- MXSINJ = AMAX1( MXSINJ, SFMIN )
- ELSE
- CALL SCOPY( M, A(1,q), 1, WORK, 1 )
- CALL SLASCL('G',0,0,AAQQ,ONE,M,1,WORK,LDA,IERR)
- CALL SLASCL('G',0,0,AAPP,ONE,M,1, A(1,p),LDA,IERR)
- TEMP1 = -AAPQ * D(q) / D(p)
- CALL SAXPY(M,TEMP1,WORK,1,A(1,p),1)
- CALL SLASCL('G',0,0,ONE,AAPP,M,1,A(1,p),LDA,IERR)
- SVA(p) = AAPP*SQRT(AMAX1(ZERO, ONE - AAPQ*AAPQ))
- MXSINJ = AMAX1( MXSINJ, SFMIN )
- END IF
- END IF
+ ELSE
+ IF( AAPP.GT.AAQQ ) THEN
+ CALL SCOPY( M, A( 1, p ), 1, WORK,
+ + 1 )
+ CALL SLASCL( 'G', 0, 0, AAPP, ONE,
+ + M, 1, WORK, LDA, IERR )
+ CALL SLASCL( 'G', 0, 0, AAQQ, ONE,
+ + M, 1, A( 1, q ), LDA,
+ + IERR )
+ TEMP1 = -AAPQ*D( p ) / D( q )
+ CALL SAXPY( M, TEMP1, WORK, 1,
+ + A( 1, q ), 1 )
+ CALL SLASCL( 'G', 0, 0, ONE, AAQQ,
+ + M, 1, A( 1, q ), LDA,
+ + IERR )
+ SVA( q ) = AAQQ*SQRT( AMAX1( ZERO,
+ + ONE-AAPQ*AAPQ ) )
+ MXSINJ = AMAX1( MXSINJ, SFMIN )
+ ELSE
+ CALL SCOPY( M, A( 1, q ), 1, WORK,
+ + 1 )
+ CALL SLASCL( 'G', 0, 0, AAQQ, ONE,
+ + M, 1, WORK, LDA, IERR )
+ CALL SLASCL( 'G', 0, 0, AAPP, ONE,
+ + M, 1, A( 1, p ), LDA,
+ + IERR )
+ TEMP1 = -AAPQ*D( q ) / D( p )
+ CALL SAXPY( M, TEMP1, WORK, 1,
+ + A( 1, p ), 1 )
+ CALL SLASCL( 'G', 0, 0, ONE, AAPP,
+ + M, 1, A( 1, p ), LDA,
+ + IERR )
+ SVA( p ) = AAPP*SQRT( AMAX1( ZERO,
+ + ONE-AAPQ*AAPQ ) )
+ MXSINJ = AMAX1( MXSINJ, SFMIN )
+ END IF
+ END IF
* END IF ROTOK THEN ... ELSE
*
* In the case of cancellation in updating SVA(q)
* .. recompute SVA(q)
- IF ( (SVA(q) / AAQQ )**2 .LE. ROOTEPS ) THEN
- IF ((AAQQ .LT. ROOTBIG).AND.(AAQQ .GT. ROOTSFMIN)) THEN
- SVA(q) = SNRM2( M, A(1,q), 1 ) * D(q)
- ELSE
- T = ZERO
- AAQQ = ZERO
- CALL SLASSQ( M, A(1,q), 1, T, AAQQ )
- SVA(q) = T * SQRT(AAQQ) * D(q)
- END IF
- END IF
- IF ( (AAPP / AAPP0 )**2 .LE. ROOTEPS ) THEN
- IF ((AAPP .LT. ROOTBIG).AND.(AAPP .GT. ROOTSFMIN)) THEN
- AAPP = SNRM2( M, A(1,p), 1 ) * D(p)
- ELSE
- T = ZERO
- AAPP = ZERO
- CALL SLASSQ( M, A(1,p), 1, T, AAPP )
- AAPP = T * SQRT(AAPP) * D(p)
- END IF
- SVA(p) = AAPP
- END IF
+ IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS )
+ + THEN
+ IF( ( AAQQ.LT.ROOTBIG ) .AND.
+ + ( AAQQ.GT.ROOTSFMIN ) ) THEN
+ SVA( q ) = SNRM2( M, A( 1, q ), 1 )*
+ + D( q )
+ ELSE
+ T = ZERO
+ AAQQ = ZERO
+ CALL SLASSQ( M, A( 1, q ), 1, T,
+ + AAQQ )
+ SVA( q ) = T*SQRT( AAQQ )*D( q )
+ END IF
+ END IF
+ IF( ( AAPP / AAPP0 )**2.LE.ROOTEPS ) THEN
+ IF( ( AAPP.LT.ROOTBIG ) .AND.
+ + ( AAPP.GT.ROOTSFMIN ) ) THEN
+ AAPP = SNRM2( M, A( 1, p ), 1 )*
+ + D( p )
+ ELSE
+ T = ZERO
+ AAPP = ZERO
+ CALL SLASSQ( M, A( 1, p ), 1, T,
+ + AAPP )
+ AAPP = T*SQRT( AAPP )*D( p )
+ END IF
+ SVA( p ) = AAPP
+ END IF
* end of OK rotation
- ELSE
- NOTROT = NOTROT + 1
+ ELSE
+ NOTROT = NOTROT + 1
* SKIPPED = SKIPPED + 1
- PSKIPPED = PSKIPPED + 1
- IJBLSK = IJBLSK + 1
- END IF
- ELSE
- NOTROT = NOTROT + 1
- PSKIPPED = PSKIPPED + 1
- IJBLSK = IJBLSK + 1
- END IF
+ PSKIPPED = PSKIPPED + 1
+ IJBLSK = IJBLSK + 1
+ END IF
+ ELSE
+ NOTROT = NOTROT + 1
+ PSKIPPED = PSKIPPED + 1
+ IJBLSK = IJBLSK + 1
+ END IF
* IF ( NOTROT .GE. EMPTSW ) GO TO 2011
- IF ( ( i .LE. SWBAND ) .AND. ( IJBLSK .GE. BLSKIP ) ) THEN
- SVA(p) = AAPP
- NOTROT = 0
- GO TO 2011
- END IF
- IF ( ( i .LE. SWBAND ) .AND. ( PSKIPPED .GT. ROWSKIP ) ) THEN
- AAPP = -AAPP
- NOTROT = 0
- GO TO 2203
- END IF
+ IF( ( i.LE.SWBAND ) .AND. ( IJBLSK.GE.BLSKIP ) )
+ + THEN
+ SVA( p ) = AAPP
+ NOTROT = 0
+ GO TO 2011
+ END IF
+ IF( ( i.LE.SWBAND ) .AND.
+ + ( PSKIPPED.GT.ROWSKIP ) ) THEN
+ AAPP = -AAPP
+ NOTROT = 0
+ GO TO 2203
+ END IF
*
- 2200 CONTINUE
+ 2200 CONTINUE
* end of the q-loop
- 2203 CONTINUE
+ 2203 CONTINUE
- SVA(p) = AAPP
+ SVA( p ) = AAPP
*
- ELSE
- IF ( AAPP .EQ. ZERO ) NOTROT=NOTROT+MIN0(jgl+KBL-1,N)-jgl+1
- IF ( AAPP .LT. ZERO ) NOTROT = 0
+ ELSE
+ IF( AAPP.EQ.ZERO )NOTROT = NOTROT +
+ + MIN0( jgl+KBL-1, N ) - jgl + 1
+ IF( AAPP.LT.ZERO )NOTROT = 0
*** IF ( NOTROT .GE. EMPTSW ) GO TO 2011
- END IF
+ END IF
- 2100 CONTINUE
+ 2100 CONTINUE
* end of the p-loop
- 2010 CONTINUE
+ 2010 CONTINUE
* end of the jbc-loop
- 2011 CONTINUE
+ 2011 CONTINUE
*2011 bailed out of the jbc-loop
- DO 2012 p = igl, MIN0( igl + KBL - 1, N )
- SVA(p) = ABS(SVA(p))
- 2012 CONTINUE
+ DO 2012 p = igl, MIN0( igl+KBL-1, N )
+ SVA( p ) = ABS( SVA( p ) )
+ 2012 CONTINUE
*** IF ( NOTROT .GE. EMPTSW ) GO TO 1994
- 2000 CONTINUE
+ 2000 CONTINUE
*2000 :: end of the ibr-loop
*
* .. update SVA(N)
- IF ((SVA(N) .LT. ROOTBIG).AND.(SVA(N) .GT. ROOTSFMIN)) THEN
- SVA(N) = SNRM2( M, A(1,N), 1 ) * D(N)
- ELSE
- T = ZERO
- AAPP = ZERO
- CALL SLASSQ( M, A(1,N), 1, T, AAPP )
- SVA(N) = T * SQRT(AAPP) * D(N)
- END IF
+ IF( ( SVA( N ).LT.ROOTBIG ) .AND. ( SVA( N ).GT.ROOTSFMIN ) )
+ + THEN
+ SVA( N ) = SNRM2( M, A( 1, N ), 1 )*D( N )
+ ELSE
+ T = ZERO
+ AAPP = ZERO
+ CALL SLASSQ( M, A( 1, N ), 1, T, AAPP )
+ SVA( N ) = T*SQRT( AAPP )*D( N )
+ END IF
*
* Additional steering devices
*
- IF ( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR.
- & ( ISWROT .LE. N ) ) )
- & SWBAND = i
+ IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR.
+ + ( ISWROT.LE.N ) ) )SWBAND = i
- IF ((i.GT.SWBAND+1).AND. (MXAAPQ.LT.FLOAT(N)*TOL).AND.
- & (FLOAT(N)*MXAAPQ*MXSINJ.LT.TOL))THEN
- GO TO 1994
- END IF
+ IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.FLOAT( N )*TOL ) .AND.
+ + ( FLOAT( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN
+ GO TO 1994
+ END IF
*
- IF ( NOTROT .GE. EMPTSW ) GO TO 1994
+ IF( NOTROT.GE.EMPTSW )GO TO 1994
1993 CONTINUE
* end i=1:NSWEEP loop
* Sort the vector D
*
DO 5991 p = 1, N - 1
- q = ISAMAX( N-p+1, SVA(p), 1 ) + p - 1
- IF ( p .NE. q ) THEN
- TEMP1 = SVA(p)
- SVA(p) = SVA(q)
- SVA(q) = TEMP1
- TEMP1 = D(p)
- D(p) = D(q)
- D(q) = TEMP1
- CALL SSWAP( M, A(1,p), 1, A(1,q), 1 )
- IF ( RSVEC ) CALL SSWAP( MVL, V(1,p), 1, V(1,q), 1 )
+ q = ISAMAX( N-p+1, SVA( p ), 1 ) + p - 1
+ IF( p.NE.q ) THEN
+ TEMP1 = SVA( p )
+ SVA( p ) = SVA( q )
+ SVA( q ) = TEMP1
+ TEMP1 = D( p )
+ D( p ) = D( q )
+ D( q ) = TEMP1
+ CALL SSWAP( M, A( 1, p ), 1, A( 1, q ), 1 )
+ IF( RSVEC )CALL SSWAP( MVL, V( 1, p ), 1, V( 1, q ), 1 )
END IF
5991 CONTINUE
*
* .. END OF SGSVJ1
* ..
END
-*
* entry is considered "symbolic" if all multiplications involved
* in computing that entry have at least one zero multiplicand.
*
-* Parameters
+* Arguments
* ==========
*
* TRANS - INTEGER
*
*
* Level 2 Blas routine.
-* ..
+*
+* =====================================================================
+*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER IWORK( * ), IPIV( * )
REAL AB( LDAB, * ), AFB( LDAFB, * ), WORK( * ),
$ C( * )
+* ..
+*
+* Purpose
+* =======
*
* SLA_GERCOND Estimates the Skeel condition number of op(A) * op2(C)
* where op2 is determined by CMODE as follows
* is computed by computing scaling factors R such that
* diag(R)*A*op2(C) is row equilibrated and computing the standard
* infinity-norm condition number.
-* WORK is a real workspace of size 5*N, and
-* IWORK is an integer workspace of size N.
-* ..
+*
+* Arguments
+* ==========
+*
+* WORK real workspace of size 5*N.
+*
+* IWORK integer workspace of size N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
LOGICAL NOTRANS
INTEGER KASE, I, J, KD
REAL C( * ), AYB(*), RCOND, BERR_OUT(*),
$ ERRS_N( NRHS, * ), ERRS_C( NRHS, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
CHARACTER TRANS
INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE
* .. Array Arguments ..
REAL AB( LDAB, * ), AFB( LDAFB, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER I, J, KD
REAL AMAX, UMAX, RPVGRW
* entry is considered "symbolic" if all multiplications involved
* in computing that entry have at least one zero multiplicand.
*
-* Parameters
+* Arguments
* ==========
*
* TRANS - INTEGER
*
* Level 2 Blas routine.
*
-* ..
+* =====================================================================
+*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
INTEGER IPIV( * ), IWORK( * )
REAL A( LDA, * ), AF( LDAF, * ), WORK( * ),
$ C( * )
+* ..
+*
+* Purpose
+* =======
*
* SLA_GERCOND estimates the Skeel condition number of op(A) * op2(C)
* where op2 is determined by CMODE as follows
* is computed by computing scaling factors R such that
* diag(R)*A*op2(C) is row equilibrated and computing the standard
* infinity-norm condition number.
-* WORK is a REAL workspace of size 3*N, and
-* IWORK is an INTEGER workspace of size N.
-* ..
+*
+* Arguments
+* ==========
+*
+* WORK REAL workspace of size 3*N.
+*
+* IWORK INTEGER workspace of size N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
LOGICAL NOTRANS
INTEGER KASE, I, J
REAL C( * ), AYB( * ), RCOND, BERR_OUT( * ),
$ ERRS_N( NRHS, * ), ERRS_C( NRHS, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
CHARACTER TRANS
INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE
* .. Array Arguments ..
REAL AYB( N, NRHS ), BERR( NRHS )
REAL RES( N, NRHS )
+* ..
+*
+* Purpose
+* =======
*
-* SLA_LIN_BERR computes componentwise relative backward error from
+* SLA_LIN_BERR computes component-wise relative backward error from
* the formula
* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )
-* where abs(Z) is the componentwise absolute value of the matrix
+* where abs(Z) is the component-wise absolute value of the matrix
* or vector Z.
-* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
REAL TMP
INTEGER I, J
* ..
* .. Array Arguments ..
INTEGER IWORK( * )
+* ..
+*
+* Purpose
+* =======
*
* SLA_PORCOND Estimates the Skeel condition number of op(A) * op2(C)
* where op2 is determined by CMODE as follows
* is computed by computing scaling factors R such that
* diag(R)*A*op2(C) is row equilibrated and computing the standard
* infinity-norm condition number.
-* WORK is a real workspace of size 3*N, and
-* IWORK is an integer workspace of size N.
-* ..
+*
+* Arguments
+* ==========
+*
+* WORK real workspace of size 3*N, and
+*
+* IWORK integer workspace of size N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER KASE, I, J
REAL AINVNM, TMP
REAL C( * ), AYB(*), RCOND, BERR_OUT( * ),
$ ERRS_N( NRHS, * ), ERRS_C( NRHS, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE
REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,
* .. Array Arguments ..
REAL A( LDA, * ), AF( LDAF, * ), WORK( * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER I, J
REAL AMAX, UMAX, RPVGRW
* .. Array Arguments ..
REAL A( LDA, * ), AF( LDAF, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER I, J
REAL AMAX, UMAX, RPVGRW
* entry is considered "symbolic" if all multiplications involved
* in computing that entry have at least one zero multiplicand.
*
-* Parameters
+* Arguments
* ==========
*
* UPLO - INTEGER
* Y. INCY must not be zero.
* Unchanged on exit.
*
+* Further Details
+* ===============
*
* Level 2 Blas routine.
*
* -- Modified for the absolute-value product, April 2006
* Jason Riedy, UC Berkeley
*
-* ..
+* =====================================================================
+*
* .. Parameters ..
REAL ONE, ZERO
PARAMETER ( ONE = 1.0E+0, ZERO = 0.0E+0 )
* .. Array Arguments
INTEGER IWORK( * ), IPIV( * )
REAL A( LDA, * ), AF( LDAF, * ), WORK( * ), C( * )
+* ..
+*
+* Purpose
+* =======
*
* SLA_SYRCOND estimates the Skeel condition number of op(A) * op2(C)
* where op2 is determined by CMODE as follows
* is computed by computing scaling factors R such that
* diag(R)*A*op2(C) is row equilibrated and computing the standard
* infinity-norm condition number.
-* WORK is a real workspace of size 3*N, and
-* IWORK is an integer workspace of size N.
-* ..
+*
+* Arguments
+* ==========
+*
+* WORK real workspace of size 3*N.
+*
+* IWORK integer workspace of size N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
CHARACTER NORMIN
INTEGER KASE, I, J
REAL C( * ), AYB( * ), RCOND, BERR_OUT( * ),
$ ERRS_N( NRHS, * ), ERRS_C( NRHS, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE
REAL YK, DYK, YMIN, NORMY, NORMX, NORMDX, DXRAT,
INTEGER IPIV( * )
REAL A( LDA, * ), AF( LDAF, * ), WORK( * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER NCOLS, I, J, K, KP
REAL AMAX, UMAX, RPVGRW, TMP
*
* W (input) REAL array, length N
* The vector to be added.
-* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
REAL S
INTEGER I
* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
* WORK is not referenced.
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Rectangular Full Packed (RFP) Format when N is
* even. We give an example where N = 6.
* positive definite, and the factorization could not be
* completed.
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Rectangular Full Packed (RFP) Format when N is
* even. We give an example where N = 6.
* > 0: if INFO = i, the (i,i) element of the factor U or L is
* zero, and the inverse could not be computed.
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Rectangular Full Packed (RFP) Format when N is
* even. We give an example where N = 6.
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Rectangular Full Packed (RFP) Format when N is
* even. We give an example where N = 6.
* Computer Science Division Technical Report No. UCB/CSD-97-971,
* UC Berkeley, May 1997.
*
-* Notes:
+* Further Details
* 1.SSTEMR works only on machines which follow IEEE-754
* floating-point standard in their handling of infinities and NaNs.
* This permits the use of efficient inner loops avoiding a check for
* max( 1, m ).
* Unchanged on exit.
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Rectangular Full Packed (RFP) Format when N is
* even. We give an example where N = 6.
* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
* matrix is singular and its inverse can not be computed.
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Rectangular Full Packed (RFP) Format when N is
* even. We give an example where N = 6.
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Rectangular Full Packed (RFP) Format when N is
* even. We give an example where N = 6.
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Rectangular Full Packed (RFP) Format when N is
* even. We give an example where N = 6.
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Rectangular Full Packed (RFP) Format when N is
* even. We give an example where N = 6.
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Rectangular Full Packed (RFP) Format when N is
* even. We give an example where N = 6.
SUBROUTINE XERBLA_ARRAY(SRNAME_ARRAY, SRNAME_LEN, INFO)
-!
-! -- LAPACK auxiliary routine (version 3.0) --
-! Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
-! September 19, 2006
-!
+*
+* -- LAPACK auxiliary routine (version 3.0) --
+* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
+* September 19, 2006
+*
IMPLICIT NONE
-! .. Scalar Arguments ..
+* .. Scalar Arguments ..
INTEGER SRNAME_LEN, INFO
-! ..
-! .. Array Arguments ..
+* ..
+* .. Array Arguments ..
CHARACTER(1) SRNAME_ARRAY(SRNAME_LEN)
-! ..
-!
-! Purpose
-! =======
-!
-! XERBLA_ARRAY assists other languages in calling XERBLA, the LAPACK
-! and BLAS error handler. Rather than taking a Fortran string argument
-! as the function's name, XERBLA_ARRAY takes an array of single
-! characters along with the array's length. XERBLA_ARRAY then copies
-! up to 32 characters of that array into a Fortran string and passes
-! that to XERBLA. If called with a non-positive SRNAME_LEN,
-! XERBLA_ARRAY will call XERBLA with a string of all blank characters.
-!
-! Say some macro or other device makes XERBLA_ARRAY available to C99
-! by a name lapack_xerbla and with a common Fortran calling convention.
-! Then a C99 program could invoke XERBLA via:
-! {
-! int flen = strlen(__func__);
-! lapack_xerbla(__func__, &flen, &info);
-! }
-!
-! Providing XERBLA_ARRAY is not necessary for intercepting LAPACK
-! errors. XERBLA_ARRAY calls XERBLA.
-!
-! Arguments
-! =========
-!
-! SRNAME_ARRAY (input) CHARACTER(1) array, dimension (SRNAME_LEN)
-! The name of the routine which called XERBLA_ARRAY.
-!
-! SRNAME_LEN (input) INTEGER
-! The length of the name in SRNAME_ARRAY.
-!
-! INFO (input) INTEGER
-! The position of the invalid parameter in the parameter list
-! of the calling routine.
-!
-! =====================================================================
-!
-! ..
-! .. Local Scalars ..
+* ..
+*
+* Purpose
+* =======
+*
+* XERBLA_ARRAY assists other languages in calling XERBLA, the LAPACK
+* and BLAS error handler. Rather than taking a Fortran string argument
+* as the function's name, XERBLA_ARRAY takes an array of single
+* characters along with the array's length. XERBLA_ARRAY then copies
+* up to 32 characters of that array into a Fortran string and passes
+* that to XERBLA. If called with a non-positive SRNAME_LEN,
+* XERBLA_ARRAY will call XERBLA with a string of all blank characters.
+*
+* Say some macro or other device makes XERBLA_ARRAY available to C99
+* by a name lapack_xerbla and with a common Fortran calling convention.
+* Then a C99 program could invoke XERBLA via:
+* {
+* int flen = strlen(__func__);
+* lapack_xerbla(__func__, &flen, &info);
+* }
+*
+* Providing XERBLA_ARRAY is not necessary for intercepting LAPACK
+* errors. XERBLA_ARRAY calls XERBLA.
+*
+* Arguments
+* =========
+*
+* SRNAME_ARRAY (input) CHARACTER(1) array, dimension (SRNAME_LEN)
+* The name of the routine which called XERBLA_ARRAY.
+*
+* SRNAME_LEN (input) INTEGER
+* The length of the name in SRNAME_ARRAY.
+*
+* INFO (input) INTEGER
+* The position of the invalid parameter in the parameter list
+* of the calling routine.
+*
+* =====================================================================
+*
+* ..
+* .. Local Scalars ..
INTEGER I
-! ..
-! .. Local Arrays ..
+* ..
+* .. Local Arrays ..
CHARACTER*32 SRNAME
-! ..
-! .. Intrinsic Functions ..
+* ..
+* .. Intrinsic Functions ..
INTRINSIC MIN, LEN
-! ..
-! .. External Functions ..
+* ..
+* .. External Functions ..
EXTERNAL XERBLA
-! ..
-! .. Executable Statements ..
+* ..
+* .. Executable Statements ..
SRNAME = ''
DO I = 1, MIN( SRNAME_LEN, LEN( SRNAME ) )
SRNAME( I:I ) = SRNAME_ARRAY( I )
* entry is considered "symbolic" if all multiplications involved
* in computing that entry have at least one zero multiplicand.
*
-* Parameters
+* Arguments
* ==========
*
* TRANS - INTEGER
*
* Level 2 Blas routine.
*
-* ..
+*
+* =====================================================================
+*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * ), WORK( * )
DOUBLE PRECISION C( * ), RWORK( * )
*
+*
+* Purpose
+* =======
+*
* ZLA_GBRCOND_C Computes the infinity norm condition number of
* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.
-* WORK is a COMPLEX*16 workspace of size 2*N, and
-* RWORK is a DOUBLE PRECISION workspace of size 3*N.
-* ..
+*
+* Arguments
+* =========
+*
+* C DOUBLE PRECISION vector.
+*
+* WORK COMPLEX*16 workspace of size 2*N.
+*
+* RWORK DOUBLE PRECISION workspace of size 3*N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
LOGICAL NOTRANS
INTEGER KASE, I, J
$ X( * )
DOUBLE PRECISION RWORK( * )
*
+*
+* Purpose
+* =======
+*
* ZLA_GBRCOND_X Computes the infinity norm condition number of
* op(A) * diag(X) where X is a COMPLEX*16 vector.
-* WORK is a COMPLEX*16 workspace of size 2*N, and
-* RWORK is a DOUBLE PRECISION workspace of size 3*N.
-* ..
+*
+* Arguments
+* =========
+*
+* X COMPLEX*16 vector.
+*
+* WORK COMPLEX*16 workspace of size 2*N.
+*
+* RWORK DOUBLE PRECISION workspace of size 3*N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
LOGICAL NOTRANS
INTEGER KASE, I, J
DOUBLE PRECISION C( * ), AYB(*), RCOND, BERR_OUT( * ),
$ ERRS_N( NRHS, * ), ERRS_C( NRHS, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
CHARACTER TRANS
INTEGER CNT, I, J, M, X_STATE, Z_STATE, Y_PREC_STATE
* .. Array Arguments ..
COMPLEX*16 AB( LDAB, * ), AFB( LDAFB, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER I, J, KD
DOUBLE PRECISION AMAX, UMAX, RPVGRW
* entry is considered "symbolic" if all multiplications involved
* in computing that entry have at least one zero multiplicand.
*
-* Parameters
+* Arguments
* ==========
*
* TRANS - INTEGER
*
* Level 2 Blas routine.
*
-* ..
+*
+* =====================================================================
+*
* .. Parameters ..
COMPLEX*16 ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * )
DOUBLE PRECISION C( * ), RWORK( * )
+* ..
+*
+* Purpose
+* =======
*
* ZLA_GERCOND_C computes the infinity norm condition number of
* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.
-* WORK is a COMPLEX*16 workspace of size 2*N, and
-* RWORK is a DOUBLE PRECISION workspace of size 3*N.
-* ..
+*
+* Arguments
+* =========
+*
+* C DOUBLE PRECISION vector.
+*
+* WORK COMPLEX*16 workspace of size 2*N.
+*
+* RWORK DOUBLE PRECISION workspace of size 3*N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
LOGICAL NOTRANS
INTEGER KASE, I, J
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * )
DOUBLE PRECISION RWORK( * )
+* ..
+*
+* Purpose
+* =======
*
* ZLA_GERCOND_X computes the infinity norm condition number of
* op(A) * diag(X) where X is a COMPLEX*16 vector.
-* WORK is a COMPLEX*16 workspace of size 2*N, and
-* RWORK is a DOUBLE PRECISION workspace of size 3*N.
-* ..
+*
+* Arguments
+* =========
+*
+* C COMPLEX*16 vector.
+*
+* WORK COMPLEX*16 workspace of size 2*N.
+*
+* RWORK DOUBLE PRECISION workspace of size 3*N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
LOGICAL NOTRANS
INTEGER KASE
DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ),
$ ERRS_N( NRHS, * ), ERRS_C( NRHS, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
CHARACTER TRANS
INTEGER CNT, I, J, X_STATE, Z_STATE, Y_PREC_STATE
* entry is considered "symbolic" if all multiplications involved
* in computing that entry have at least one zero multiplicand.
*
-* Parameters
+* Arguments
* ==========
*
* UPLO - INTEGER
* Y. INCY must not be zero.
* Unchanged on exit.
*
+* Further Details
+* ===============
*
* Level 2 Blas routine.
*
* -- Modified for the absolute-value product, April 2006
* Jason Riedy, UC Berkeley
*
-* ..
+* =====================================================================
+*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * )
DOUBLE PRECISION C ( * ), RWORK( * )
+* ..
+*
+* Purpose
+* =======
*
* ZLA_HERCOND_C computes the infinity norm condition number of
* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.
-* WORK is a COMPLEX*16 workspace of size 2*N, and
-* RWORK is a DOUBLE PRECISION workspace of size 3*N.
-* ..
+*
+* Arguments
+* =========
+*
+* C DOUBLE PRECISION vector.
+*
+* WORK COMPLEX*16 workspace of size 2*N.
+*
+* RWORK DOUBLE PRECISION workspace of size 3*N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER KASE, I, J
DOUBLE PRECISION AINVNM, ANORM, TMP
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * )
DOUBLE PRECISION RWORK( * )
+* ..
+*
+* Purpose
+* =======
*
* ZLA_HERCOND_X computes the infinity norm condition number of
* op(A) * diag(X) where X is a COMPLEX*16 vector.
-* WORK is a COMPLEX*16 workspace of size 2*N, and
-* RWORK is a DOUBLE PRECISION workspace of size 3*N.
-* ..
+*
+* Arguments
+* =========
+*
+* C COMPLEX*16 vector.
+*
+* WORK COMPLEX*16 workspace of size 2*N.
+*
+* RWORK DOUBLE PRECISION workspace of size 3*N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER KASE, I, J
DOUBLE PRECISION AINVNM, ANORM, TMP
DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ),
$ ERRS_N( NRHS, * ), ERRS_C( NRHS, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,
$ Y_PREC_STATE
COMPLEX*16 A( LDA, * ), AF( LDAF, * )
DOUBLE PRECISION WORK( * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER NCOLS, I, J, K, KP
DOUBLE PRECISION AMAX, UMAX, RPVGRW, TMP
* .. Array Arguments ..
DOUBLE PRECISION AYB( N, NRHS ), BERR( NRHS )
COMPLEX*16 RES( N, NRHS )
+* ..
+*
+* Purpose
+* =======
*
* ZLA_LIN_BERR computes componentwise relative backward error from
* the formula
* max(i) ( abs(R(i)) / ( abs(op(A_s))*abs(Y) + abs(B_s) )(i) )
* where abs(Z) is the componentwise absolute value of the matrix
* or vector Z.
-* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
DOUBLE PRECISION TMP
INTEGER I, J
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * )
DOUBLE PRECISION C( * ), RWORK( * )
+* ..
+*
+* Purpose
+* =======
*
* DLA_PORCOND_C Computes the infinity norm condition number of
* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector
-* WORK is a COMPLEX*16 workspace of size 2*N, and
-* RWORK is a DOUBLE PRECISION workspace of size 3*N.
-* ..
+*
+* Arguments
+* =========
+*
+* C DOUBLE PRECISION vector.
+*
+* WORK COMPLEX*16 workspace of size 2*N.
+*
+* RWORK DOUBLE PRECISION workspace of size 3*N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER KASE
DOUBLE PRECISION AINVNM, ANORM, TMP
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * )
DOUBLE PRECISION RWORK( * )
+* ..
+*
+* Purpose
+* =======
*
* ZLA_PORCOND_X Computes the infinity norm condition number of
* op(A) * diag(X) where X is a COMPLEX*16 vector.
-* WORK is a COMPLEX*16 workspace of size 2*N, and
-* RWORK is a DOUBLE PRECISION workspace of size 3*N.
-* ..
+*
+* Arguments
+* =========
+*
+* C COMPLEX*16 vector.
+*
+* WORK COMPLEX*16 workspace of size 2*N.
+*
+* RWORK DOUBLE PRECISION workspace of size 3*N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER KASE, I, J
DOUBLE PRECISION AINVNM, ANORM, TMP
DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ),
$ ERRS_N( NRHS, * ), ERRS_C( NRHS, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,
$ Y_PREC_STATE
COMPLEX*16 A( LDA, * ), AF( LDAF, * )
DOUBLE PRECISION WORK( * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION AMAX, UMAX, RPVGRW
* .. Array Arguments ..
COMPLEX*16 A( LDA, * ), AF( LDAF, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER I, J
DOUBLE PRECISION AMAX, UMAX, RPVGRW
* entry is considered "symbolic" if all multiplications involved
* in computing that entry have at least one zero multiplicand.
*
-* Parameters
+* Arguments
* ==========
*
* UPLO - INTEGER
* Y. INCY must not be zero.
* Unchanged on exit.
*
+* Further Details
+* ===============
*
* Level 2 Blas routine.
*
* -- Modified for the absolute-value product, April 2006
* Jason Riedy, UC Berkeley
*
-* ..
+* =====================================================================
+*
* .. Parameters ..
DOUBLE PRECISION ONE, ZERO
PARAMETER ( ONE = 1.0D+0, ZERO = 0.0D+0 )
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * )
DOUBLE PRECISION C( * ), RWORK( * )
+* ..
+*
+* Purpose
+* =======
*
* ZLA_SYRCOND_C Computes the infinity norm condition number of
* op(A) * inv(diag(C)) where C is a DOUBLE PRECISION vector.
-* WORK is a COMPLEX*16 workspace of size 2*N, and
-* RWORK is a DOUBLE PRECISION workspace of size 3*N.
-* ..
+*
+* Arguments
+* =========
+*
+* C DOUBLE PRECISION vector.
+*
+* WORK COMPLEX*16 workspace of size 2*N.
+*
+* RWORK DOUBLE PRECISION workspace of size 3*N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER KASE
DOUBLE PRECISION AINVNM, ANORM, TMP
INTEGER IPIV( * )
COMPLEX*16 A( LDA, * ), AF( LDAF, * ), WORK( * ), X( * )
DOUBLE PRECISION RWORK( * )
+* ..
+*
+* Purpose
+* =======
*
* ZLA_SYRCOND_X Computes the infinity norm condition number of
* op(A) * diag(X) where X is a COMPLEX*16 vector.
-* WORK is a COMPLEX*16 workspace of size 2*N, and
-* RWORK is a DOUBLE PRECISION workspace of size 3*N.
-* ..
+*
+* Arguments
+* =========
+*
+* C COMPLEX*16 vector.
+*
+* WORK COMPLEX*16 workspace of size 2*N.
+*
+* RWORK DOUBLE PRECISION workspace of size 3*N.
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER KASE
DOUBLE PRECISION AINVNM, ANORM, TMP
DOUBLE PRECISION C( * ), AYB( * ), RCOND, BERR_OUT( * ),
$ ERRS_N( NRHS, * ), ERRS_C( NRHS, * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER UPLO2, CNT, I, J, X_STATE, Z_STATE,
$ Y_PREC_STATE
DOUBLE PRECISION WORK( * )
INTEGER IPIV( * )
* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
INTEGER NCOLS, I, J, K, KP
DOUBLE PRECISION AMAX, UMAX, RPVGRW, TMP
*
* W (input) COMPLEX*16 array, length N
* The vector to be added.
-* ..
+*
+* =====================================================================
+*
* .. Local Scalars ..
COMPLEX*16 S
INTEGER I
* where LWORK >= N when NORM = 'I' or '1' or 'O'; otherwise,
* WORK is not referenced.
*
-* Note:
-* =====
+* Further Details
+* ===============
*
* We first consider Standard Packed Format when N is even.
* We give an example where N = 6.
* > 0: if INFO = i, the (i,i) element of the factor U or L is
* zero, and the inverse could not be computed.
*
-* Note:
-* =====
+* Further Details
+* ===============
*
* We first consider Standard Packed Format when N is even.
* We give an example where N = 6.
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
-* Note:
-* =====
+* Further Details
+* ===============
*
* We first consider Standard Packed Format when N is even.
* We give an example where N = 6.
* Computer Science Division Technical Report No. UCB/CSD-97-971,
* UC Berkeley, May 1997.
*
-* Notes:
+* Further Details
* 1.ZSTEMR works only on machines which follow IEEE-754
* floating-point standard in their handling of infinities and NaNs.
* This permits the use of efficient inner loops avoiding a check for
* max( 1, m ).
* Unchanged on exit.
*
-* Notes:
-* ======
+* Further Details
+* ===============
*
* We first consider Standard Packed Format when N is even.
* We give an example where N = 6.
* > 0: if INFO = i, A(i,i) is exactly zero. The triangular
* matrix is singular and its inverse can not be computed.
*
-* Notes:
-* ======
+* Further Details
+* ===============
*
* We first consider Standard Packed Format when N is even.
* We give an example where N = 6.
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
-* Notes:
-* ======
+* Further Details
+* ===============
*
* We first consider Standard Packed Format when N is even.
* We give an example where N = 6.
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
-* Notes:
-* ======
+* Further Details
+* ===============
*
* We first consider Standard Packed Format when N is even.
* We give an example where N = 6.
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
-* Notes:
-* ======
+* Further Details
+* ===============
*
* We first consider Standard Packed Format when N is even.
* We give an example where N = 6.
* = 0: successful exit
* < 0: if INFO = -i, the i-th argument had an illegal value
*
-* Notes
-* =====
+* Further Details
+* ===============
*
* We first consider Standard Packed Format when N is even.
* We give an example where N = 6.
projects / platform / upstream / lapack.git / commitdiff