--- rpl/lapack/lapack/dgsvj0.f 2010/08/07 13:21:03 1.1 +++ rpl/lapack/lapack/dgsvj0.f 2023/08/07 08:38:51 1.21 @@ -1,21 +1,225 @@ - SUBROUTINE DGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, - + SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) +*> \brief \b DGSVJ0 pre-processor for the routine dgesvj. +* +* =========== DOCUMENTATION =========== +* +* Online html documentation available at +* http://www.netlib.org/lapack/explore-html/ * -* -- LAPACK routine (version 3.2.2) -- +*> \htmlonly +*> Download DGSVJ0 + dependencies +*> +*> [TGZ] +*> +*> [ZIP] +*> +*> [TXT] +*> \endhtmlonly +* +* Definition: +* =========== +* +* SUBROUTINE DGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, +* SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) +* +* .. 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 ) +* .. +* +* +*> \par Purpose: +* ============= +*> +*> \verbatim +*> +*> 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 +*> parameters (marked by [TP]) are available for the implementer. +*> \endverbatim +* +* Arguments: +* ========== +* +*> \param[in] JOBV +*> \verbatim +*> JOBV is CHARACTER*1 +*> Specifies whether the output from this procedure is used +*> to compute the matrix V: +*> = 'V': the product of the Jacobi rotations is accumulated +*> by postmulyiplying the N-by-N array V. +*> (See the description of V.) +*> = 'A': the product of the Jacobi rotations is accumulated +*> by postmulyiplying the MV-by-N array V. +*> (See the descriptions of MV and V.) +*> = 'N': the Jacobi rotations are not accumulated. +*> \endverbatim +*> +*> \param[in] M +*> \verbatim +*> M is INTEGER +*> The number of rows of the input matrix A. M >= 0. +*> \endverbatim +*> +*> \param[in] N +*> \verbatim +*> N is INTEGER +*> The number of columns of the input matrix A. +*> M >= N >= 0. +*> \endverbatim +*> +*> \param[in,out] A +*> \verbatim +*> A is DOUBLE PRECISION array, dimension (LDA,N) +*> On entry, M-by-N matrix A, such that A*diag(D) represents +*> the input matrix. +*> On exit, +*> A_onexit * D_onexit represents the input matrix A*diag(D) +*> post-multiplied by a sequence of Jacobi rotations, where the +*> rotation threshold and the total number of sweeps are given in +*> TOL and NSWEEP, respectively. +*> (See the descriptions of D, TOL and NSWEEP.) +*> \endverbatim +*> +*> \param[in] LDA +*> \verbatim +*> LDA is INTEGER +*> The leading dimension of the array A. LDA >= max(1,M). +*> \endverbatim +*> +*> \param[in,out] D +*> \verbatim +*> D is DOUBLE PRECISION array, dimension (N) +*> The array D accumulates the scaling factors from the fast scaled +*> Jacobi rotations. +*> On entry, A*diag(D) represents the input matrix. +*> On exit, A_onexit*diag(D_onexit) represents the input matrix +*> post-multiplied by a sequence of Jacobi rotations, where the +*> rotation threshold and the total number of sweeps are given in +*> TOL and NSWEEP, respectively. +*> (See the descriptions of A, TOL and NSWEEP.) +*> \endverbatim +*> +*> \param[in,out] SVA +*> \verbatim +*> SVA is DOUBLE PRECISION array, dimension (N) +*> On entry, SVA contains the Euclidean norms of the columns of +*> the matrix A*diag(D). +*> On exit, SVA contains the Euclidean norms of the columns of +*> the matrix onexit*diag(D_onexit). +*> \endverbatim +*> +*> \param[in] MV +*> \verbatim +*> MV is INTEGER +*> If JOBV = 'A', then MV rows of V are post-multipled by a +*> sequence of Jacobi rotations. +*> If JOBV = 'N', then MV is not referenced. +*> \endverbatim +*> +*> \param[in,out] V +*> \verbatim +*> V is DOUBLE PRECISION array, dimension (LDV,N) +*> If JOBV = 'V' then N rows of V are post-multipled by a +*> sequence of Jacobi rotations. +*> If JOBV = 'A' then MV rows of V are post-multipled by a +*> sequence of Jacobi rotations. +*> If JOBV = 'N', then V is not referenced. +*> \endverbatim +*> +*> \param[in] LDV +*> \verbatim +*> LDV is INTEGER +*> The leading dimension of the array V, LDV >= 1. +*> If JOBV = 'V', LDV >= N. +*> If JOBV = 'A', LDV >= MV. +*> \endverbatim +*> +*> \param[in] EPS +*> \verbatim +*> EPS is DOUBLE PRECISION +*> EPS = DLAMCH('Epsilon') +*> \endverbatim +*> +*> \param[in] SFMIN +*> \verbatim +*> SFMIN is DOUBLE PRECISION +*> SFMIN = DLAMCH('Safe Minimum') +*> \endverbatim +*> +*> \param[in] TOL +*> \verbatim +*> TOL is DOUBLE PRECISION +*> TOL is the threshold for Jacobi rotations. For a pair +*> A(:,p), A(:,q) of pivot columns, the Jacobi rotation is +*> applied only if DABS(COS(angle(A(:,p),A(:,q)))) > TOL. +*> \endverbatim +*> +*> \param[in] NSWEEP +*> \verbatim +*> NSWEEP is INTEGER +*> NSWEEP is the number of sweeps of Jacobi rotations to be +*> performed. +*> \endverbatim +*> +*> \param[out] WORK +*> \verbatim +*> WORK is DOUBLE PRECISION array, dimension (LWORK) +*> \endverbatim +*> +*> \param[in] LWORK +*> \verbatim +*> LWORK is INTEGER +*> LWORK is the dimension of WORK. LWORK >= M. +*> \endverbatim +*> +*> \param[out] INFO +*> \verbatim +*> INFO is INTEGER +*> = 0: successful exit. +*> < 0: if INFO = -i, then the i-th argument had an illegal value +*> \endverbatim +* +* Authors: +* ======== +* +*> \author Univ. of Tennessee +*> \author Univ. of California Berkeley +*> \author Univ. of Colorado Denver +*> \author NAG Ltd. +* +*> \ingroup doubleOTHERcomputational +* +*> \par Further Details: +* ===================== +*> +*> DGSVJ0 is used just to enable DGESVJ to call a simplified version of +*> itself to work on a submatrix of the original matrix. +*> +*> \par Contributors: +* ================== +*> +*> Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) +*> +*> \par Bugs, Examples and Comments: +* ================================= +*> +*> Please report all bugs and send interesting test examples and comments to +*> drmac@math.hr. Thank you. * -* -- Contributed by Zlatko Drmac of the University of Zagreb and -- -* -- Kresimir Veselic of the Fernuniversitaet Hagen -- -* -- June 2010 -- +* ===================================================================== + SUBROUTINE DGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS, + $ SFMIN, TOL, NSWEEP, WORK, LWORK, INFO ) * +* -- LAPACK computational routine -- * -- LAPACK is a software package provided by Univ. of Tennessee, -- * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- * -* This routine is also part of SIGMA (version 1.23, October 23. 2008.) -* SIGMA is a library of algorithms for highly accurate algorithms for -* 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. -* - IMPLICIT NONE * .. Scalar Arguments .. INTEGER INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP DOUBLE PRECISION EPS, SFMIN, TOL @@ -23,144 +227,30 @@ * .. * .. Array Arguments .. DOUBLE PRECISION A( LDA, * ), SVA( N ), D( N ), V( LDV, * ), - + WORK( LWORK ) + $ 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 -* parameters (marked by [TP]) are available for the implementer. -* -* Further Details -* ~~~~~~~~~~~~~~~ -* DGSVJ0 is used just to enable SGESVJ to call a simplified version of -* itself to work on a submatrix of the original matrix. -* -* Contributors -* ~~~~~~~~~~~~ -* Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany) -* -* Bugs, Examples and Comments -* ~~~~~~~~~~~~~~~~~~~~~~~~~~~ -* Please report all bugs and send interesting test examples and comments to -* drmac@math.hr. Thank you. -* -* Arguments -* ========= -* -* JOBV (input) CHARACTER*1 -* Specifies whether the output from this procedure is used -* to compute the matrix V: -* = 'V': the product of the Jacobi rotations is accumulated -* by postmulyiplying the N-by-N array V. -* (See the description of V.) -* = 'A': the product of the Jacobi rotations is accumulated -* by postmulyiplying the MV-by-N array V. -* (See the descriptions of MV and V.) -* = 'N': the Jacobi rotations are not accumulated. -* -* M (input) INTEGER -* The number of rows of the input matrix A. M >= 0. -* -* N (input) INTEGER -* The number of columns of the input matrix A. -* M >= N >= 0. -* -* A (input/output) DOUBLE PRECISION array, dimension (LDA,N) -* On entry, M-by-N matrix A, such that A*diag(D) represents -* the input matrix. -* On exit, -* A_onexit * D_onexit represents the input matrix A*diag(D) -* post-multiplied by a sequence of Jacobi rotations, where the -* rotation threshold and the total number of sweeps are given in -* TOL and NSWEEP, respectively. -* (See the descriptions of D, TOL and NSWEEP.) -* -* LDA (input) INTEGER -* The leading dimension of the array A. LDA >= max(1,M). -* -* D (input/workspace/output) DOUBLE PRECISION array, dimension (N) -* The array D accumulates the scaling factors from the fast scaled -* Jacobi rotations. -* On entry, A*diag(D) represents the input matrix. -* On exit, A_onexit*diag(D_onexit) represents the input matrix -* post-multiplied by a sequence of Jacobi rotations, where the -* rotation threshold and the total number of sweeps are given in -* TOL and NSWEEP, respectively. -* (See the descriptions of A, TOL and NSWEEP.) -* -* SVA (input/workspace/output) DOUBLE PRECISION array, dimension (N) -* On entry, SVA contains the Euclidean norms of the columns of -* the matrix A*diag(D). -* On exit, SVA contains the Euclidean norms of the columns of -* the matrix onexit*diag(D_onexit). -* -* MV (input) INTEGER -* If JOBV .EQ. 'A', then MV rows of V are post-multipled by a -* sequence of Jacobi rotations. -* If JOBV = 'N', then MV is not referenced. -* -* V (input/output) DOUBLE PRECISION array, dimension (LDV,N) -* If JOBV .EQ. 'V' then N rows of V are post-multipled by a -* sequence of Jacobi rotations. -* If JOBV .EQ. 'A' then MV rows of V are post-multipled by a -* sequence of Jacobi rotations. -* If JOBV = 'N', then V is not referenced. -* -* LDV (input) INTEGER -* The leading dimension of the array V, LDV >= 1. -* If JOBV = 'V', LDV .GE. N. -* If JOBV = 'A', LDV .GE. MV. -* -* EPS (input) DOUBLE PRECISION -* EPS = DLAMCH('Epsilon') -* -* SFMIN (input) DOUBLE PRECISION -* SFMIN = DLAMCH('Safe Minimum') -* -* TOL (input) DOUBLE PRECISION -* TOL is the threshold for Jacobi rotations. For a pair -* A(:,p), A(:,q) of pivot columns, the Jacobi rotation is -* applied only if DABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL. -* -* NSWEEP (input) INTEGER -* NSWEEP is the number of sweeps of Jacobi rotations to be -* performed. -* -* WORK (workspace) DOUBLE PRECISION array, dimension (LWORK) -* -* LWORK (input) INTEGER -* LWORK is the dimension of WORK. LWORK .GE. M. -* -* INFO (output) INTEGER -* = 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 ) + DOUBLE PRECISION ZERO, HALF, ONE + PARAMETER ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.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 + $ 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 + $ 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 + INTRINSIC DABS, MAX, DBLE, MIN, DSIGN, DSQRT * .. * .. External Functions .. DOUBLE PRECISION DDOT, DNRM2 @@ -169,10 +259,13 @@ EXTERNAL IDAMAX, LSAME, DDOT, DNRM2 * .. * .. External Subroutines .. - EXTERNAL DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP + EXTERNAL DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP, + $ XERBLA * .. * .. Executable Statements .. * +* Test the input parameters. +* APPLV = LSAME( JOBV, 'A' ) RSVEC = LSAME( JOBV, 'V' ) IF( .NOT.( RSVEC .OR. APPLV .OR. LSAME( JOBV, 'N' ) ) ) THEN @@ -183,9 +276,10 @@ INFO = -3 ELSE IF( LDA.LT.M ) THEN INFO = -5 - ELSE IF( MV.LT.0 ) THEN + ELSE IF( ( RSVEC.OR.APPLV ) .AND. ( MV.LT.0 ) ) THEN INFO = -8 - ELSE IF( LDV.LT.M ) THEN + ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR. + $ ( APPLV.AND.( LDV.LT.MV ) ) ) THEN INFO = -10 ELSE IF( TOL.LE.EPS ) THEN INFO = -13 @@ -218,7 +312,6 @@ BIGTHETA = ONE / ROOTEPS ROOTTOL = DSQRT( TOL ) * -* * -#- Row-cyclic Jacobi SVD algorithm with column pivoting -#- * EMPTSW = ( N*( N-1 ) ) / 2 @@ -234,7 +327,7 @@ * Jacobi SVD algorithm SGESVJ. For sweeps i=1:SWBAND the procedure * ...... - KBL = MIN0( 8, N ) + KBL = MIN( 8, N ) *[TP] KBL is a tuning parameter that defines the tile size in the * tiling of the p-q loops of pivot pairs. In general, an optimal * value of KBL depends on the matrix dimensions and on the @@ -246,7 +339,7 @@ BLSKIP = ( KBL**2 ) + 1 *[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL. - ROWSKIP = MIN0( 5, KBL ) + ROWSKIP = MIN( 5, KBL ) *[TP] ROWSKIP is a tuning parameter. LKAHEAD = 1 @@ -268,18 +361,18 @@ igl = ( ibr-1 )*KBL + 1 * - DO 1002 ir1 = 0, MIN0( LKAHEAD, NBL-ibr ) + DO 1002 ir1 = 0, MIN( LKAHEAD, NBL-ibr ) * igl = igl + ir1*KBL * - DO 2001 p = igl, MIN0( igl+KBL-1, N-1 ) + DO 2001 p = igl, MIN( 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 ) + $ V( 1, q ), 1 ) TEMP1 = SVA( p ) SVA( p ) = SVA( q ) SVA( q ) = TEMP1 @@ -296,18 +389,18 @@ * Some BLAS implementations compute DNRM2(M,A(1,p),1) * as DSQRT(DDOT(M,A(1,p),1,A(1,p),1)), which may result in * overflow for ||A(:,p)||_2 > DSQRT(overflow_threshold), and -* undeflow for ||A(:,p)||_2 < DSQRT(underflow_threshold). +* underflow for ||A(:,p)||_2 < DSQRT(underflow_threshold). * Hence, DNRM2 cannot be trusted, not even in the case when * the true norm is far from the under(over)flow boundaries. * 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 ).GT.ROOTSFMIN ) ) THEN SVA( p ) = DNRM2( M, A( 1, p ), 1 )*D( p ) ELSE TEMP1 = ZERO - AAPP = ZERO + AAPP = ONE CALL DLASSQ( M, A( 1, p ), 1, TEMP1, AAPP ) SVA( p ) = TEMP1*DSQRT( AAPP )*D( p ) END IF @@ -321,7 +414,7 @@ * PSKIPPED = 0 * - DO 2002 q = p + 1, MIN0( igl+KBL-1, N ) + DO 2002 q = p + 1, MIN( igl+KBL-1, N ) * AAQQ = SVA( q ) @@ -332,31 +425,31 @@ 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 + $ 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 ) + $ M, 1, WORK, LDA, IERR ) AAPQ = DDOT( M, WORK, 1, A( 1, q ), - + 1 )*D( q ) / AAQQ + $ 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 + $ 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 ) + $ M, 1, WORK, LDA, IERR ) AAPQ = DDOT( M, WORK, 1, A( 1, p ), - + 1 )*D( p ) / AAPP + $ 1 )*D( p ) / AAPP END IF END IF * - MXAAPQ = DMAX1( MXAAPQ, DABS( AAPQ ) ) + MXAAPQ = MAX( MXAAPQ, DABS( AAPQ ) ) * * TO rotate or NOT to rotate, THAT is the question ... * @@ -375,8 +468,7 @@ * AQOAP = AAQQ / AAPP APOAQ = AAPP / AAQQ - THETA = -HALF*DABS( AQOAP-APOAQ ) / - + AAPQ + THETA = -HALF*DABS( AQOAP-APOAQ )/AAPQ * IF( DABS( THETA ).GT.BIGTHETA ) THEN * @@ -384,16 +476,16 @@ 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 ) + $ 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 ) ) + $ V( 1, p ), 1, + $ V( 1, q ), 1, + $ FASTR ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE+T*APOAQ*AAPQ ) ) + AAPP = AAPP*DSQRT( MAX( ZERO, + $ ONE-T*AQOAP*AAPQ ) ) + MXSINJ = MAX( MXSINJ, DABS( T ) ) * ELSE * @@ -401,15 +493,15 @@ * THSIGN = -DSIGN( ONE, AAPQ ) T = ONE / ( THETA+THSIGN* - + DSQRT( ONE+THETA*THETA ) ) + $ 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 ) ) + MXSINJ = MAX( MXSINJ, DABS( SN ) ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE+T*APOAQ*AAPQ ) ) + AAPP = AAPP*DSQRT( MAX( ZERO, + $ ONE-T*AQOAP*AAPQ ) ) * APOAQ = D( p ) / D( q ) AQOAP = D( q ) / D( p ) @@ -420,87 +512,87 @@ D( p ) = D( p )*CS D( q ) = D( q )*CS CALL DROTM( M, A( 1, p ), 1, - + A( 1, q ), 1, - + FASTR ) + $ A( 1, q ), 1, + $ FASTR ) IF( RSVEC )CALL DROTM( MVL, - + V( 1, p ), 1, V( 1, q ), - + 1, FASTR ) + $ V( 1, p ), 1, V( 1, q ), + $ 1, FASTR ) ELSE CALL DAXPY( M, -T*AQOAP, - + A( 1, q ), 1, - + A( 1, p ), 1 ) + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) CALL DAXPY( M, CS*SN*APOAQ, - + A( 1, p ), 1, - + A( 1, q ), 1 ) + $ 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 ) + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) CALL DAXPY( MVL, - + CS*SN*APOAQ, - + V( 1, p ), 1, - + V( 1, q ), 1 ) + $ 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 ) + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) CALL DAXPY( M, -CS*SN*AQOAP, - + A( 1, q ), 1, - + A( 1, p ), 1 ) + $ 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 ) + $ V( 1, p ), 1, + $ V( 1, q ), 1 ) CALL DAXPY( MVL, - + -CS*SN*AQOAP, - + V( 1, q ), 1, - + V( 1, p ), 1 ) + $ -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 ) + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) CALL DAXPY( M, CS*SN*APOAQ, - + A( 1, p ), 1, - + A( 1, q ), 1 ) + $ 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 ) + $ -T*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) CALL DAXPY( MVL, - + CS*SN*APOAQ, - + V( 1, p ), 1, - + V( 1, q ), 1 ) + $ 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 ) + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) CALL DAXPY( M, - + -CS*SN*AQOAP, - + A( 1, q ), 1, - + A( 1, p ), 1 ) + $ -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 ) + $ T*APOAQ, V( 1, p ), + $ 1, V( 1, q ), 1 ) CALL DAXPY( MVL, - + -CS*SN*AQOAP, - + V( 1, q ), 1, - + V( 1, p ), 1 ) + $ -CS*SN*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) END IF END IF END IF @@ -511,46 +603,46 @@ * .. 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 ) + $ 1, WORK, LDA, IERR ) CALL DLASCL( 'G', 0, 0, AAQQ, ONE, M, - + 1, A( 1, q ), LDA, IERR ) + $ 1, A( 1, q ), LDA, IERR ) TEMP1 = -AAPQ*D( p ) / D( q ) CALL DAXPY( M, TEMP1, WORK, 1, - + A( 1, q ), 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 ) + $ 1, A( 1, q ), LDA, IERR ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE-AAPQ*AAPQ ) ) + MXSINJ = MAX( 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 + $ THEN IF( ( AAQQ.LT.ROOTBIG ) .AND. - + ( AAQQ.GT.ROOTSFMIN ) ) THEN + $ ( AAQQ.GT.ROOTSFMIN ) ) THEN SVA( q ) = DNRM2( M, A( 1, q ), 1 )* - + D( q ) + $ D( q ) ELSE T = ZERO - AAQQ = ZERO + AAQQ = ONE CALL DLASSQ( M, A( 1, q ), 1, T, - + AAQQ ) + $ 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.GT.ROOTSFMIN ) ) THEN AAPP = DNRM2( M, A( 1, p ), 1 )* - + D( p ) + $ D( p ) ELSE T = ZERO - AAPP = ZERO + AAPP = ONE CALL DLASSQ( M, A( 1, p ), 1, T, - + AAPP ) + $ AAPP ) AAPP = T*DSQRT( AAPP )*D( p ) END IF SVA( p ) = AAPP @@ -568,7 +660,7 @@ END IF * IF( ( i.LE.SWBAND ) .AND. - + ( PSKIPPED.GT.ROWSKIP ) ) THEN + $ ( PSKIPPED.GT.ROWSKIP ) ) THEN IF( ir1.EQ.0 )AAPP = -AAPP NOTROT = 0 GO TO 2103 @@ -585,7 +677,7 @@ ELSE SVA( p ) = AAPP IF( ( ir1.EQ.0 ) .AND. ( AAPP.EQ.ZERO ) ) - + NOTROT = NOTROT + MIN0( igl+KBL-1, N ) - p + $ NOTROT = NOTROT + MIN( igl+KBL-1, N ) - p END IF * 2001 CONTINUE @@ -606,7 +698,7 @@ * doing the block at ( ibr, jbc ) * IJBLSK = 0 - DO 2100 p = igl, MIN0( igl+KBL-1, N ) + DO 2100 p = igl, MIN( igl+KBL-1, N ) * AAPP = SVA( p ) * @@ -614,7 +706,7 @@ * PSKIPPED = 0 * - DO 2200 q = jgl, MIN0( jgl+KBL-1, N ) + DO 2200 q = jgl, MIN( jgl+KBL-1, N ) * AAQQ = SVA( q ) * @@ -633,14 +725,14 @@ 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 + $ 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 ) + $ M, 1, WORK, LDA, IERR ) AAPQ = DDOT( M, WORK, 1, A( 1, q ), - + 1 )*D( q ) / AAQQ + $ 1 )*D( q ) / AAQQ END IF ELSE IF( AAPP.GE.AAQQ ) THEN @@ -650,18 +742,18 @@ 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 + $ 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 ) + $ M, 1, WORK, LDA, IERR ) AAPQ = DDOT( M, WORK, 1, A( 1, p ), - + 1 )*D( p ) / AAPP + $ 1 )*D( p ) / AAPP END IF END IF * - MXAAPQ = DMAX1( MXAAPQ, DABS( AAPQ ) ) + MXAAPQ = MAX( MXAAPQ, DABS( AAPQ ) ) * * TO rotate or NOT to rotate, THAT is the question ... * @@ -675,8 +767,7 @@ * AQOAP = AAQQ / AAPP APOAQ = AAPP / AAQQ - THETA = -HALF*DABS( AQOAP-APOAQ ) / - + AAPQ + THETA = -HALF*DABS( AQOAP-APOAQ )/AAPQ IF( AAQQ.GT.AAPP0 )THETA = -THETA * IF( DABS( THETA ).GT.BIGTHETA ) THEN @@ -684,16 +775,16 @@ 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 ) + $ 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 ) ) + $ V( 1, p ), 1, + $ V( 1, q ), 1, + $ FASTR ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE+T*APOAQ*AAPQ ) ) + AAPP = AAPP*DSQRT( MAX( ZERO, + $ ONE-T*AQOAP*AAPQ ) ) + MXSINJ = MAX( MXSINJ, DABS( T ) ) ELSE * * .. choose correct signum for THETA and rotate @@ -701,14 +792,14 @@ THSIGN = -DSIGN( ONE, AAPQ ) IF( AAQQ.GT.AAPP0 )THSIGN = -THSIGN T = ONE / ( THETA+THSIGN* - + DSQRT( ONE+THETA*THETA ) ) + $ 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 ) + MXSINJ = MAX( MXSINJ, DABS( SN ) ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE+T*APOAQ*AAPQ ) ) + AAPP = AAPP*DSQRT( MAX( ZERO, + $ ONE-T*AQOAP*AAPQ ) ) * APOAQ = D( p ) / D( q ) AQOAP = D( q ) / D( p ) @@ -720,26 +811,26 @@ D( p ) = D( p )*CS D( q ) = D( q )*CS CALL DROTM( M, A( 1, p ), 1, - + A( 1, q ), 1, - + FASTR ) + $ A( 1, q ), 1, + $ FASTR ) IF( RSVEC )CALL DROTM( MVL, - + V( 1, p ), 1, V( 1, q ), - + 1, FASTR ) + $ V( 1, p ), 1, V( 1, q ), + $ 1, FASTR ) ELSE CALL DAXPY( M, -T*AQOAP, - + A( 1, q ), 1, - + A( 1, p ), 1 ) + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) CALL DAXPY( M, CS*SN*APOAQ, - + A( 1, p ), 1, - + A( 1, q ), 1 ) + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) IF( RSVEC ) THEN CALL DAXPY( MVL, -T*AQOAP, - + V( 1, q ), 1, - + V( 1, p ), 1 ) + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) CALL DAXPY( MVL, - + CS*SN*APOAQ, - + V( 1, p ), 1, - + V( 1, q ), 1 ) + $ CS*SN*APOAQ, + $ V( 1, p ), 1, + $ V( 1, q ), 1 ) END IF D( p ) = D( p )*CS D( q ) = D( q ) / CS @@ -747,60 +838,60 @@ ELSE IF( D( q ).GE.ONE ) THEN CALL DAXPY( M, T*APOAQ, - + A( 1, p ), 1, - + A( 1, q ), 1 ) + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) CALL DAXPY( M, -CS*SN*AQOAP, - + A( 1, q ), 1, - + A( 1, p ), 1 ) + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) IF( RSVEC ) THEN CALL DAXPY( MVL, T*APOAQ, - + V( 1, p ), 1, - + V( 1, q ), 1 ) + $ V( 1, p ), 1, + $ V( 1, q ), 1 ) CALL DAXPY( MVL, - + -CS*SN*AQOAP, - + V( 1, q ), 1, - + V( 1, p ), 1 ) + $ -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 ) + $ A( 1, q ), 1, + $ A( 1, p ), 1 ) CALL DAXPY( M, CS*SN*APOAQ, - + A( 1, p ), 1, - + A( 1, q ), 1 ) + $ 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 ) + $ -T*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) CALL DAXPY( MVL, - + CS*SN*APOAQ, - + V( 1, p ), 1, - + V( 1, q ), 1 ) + $ 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 ) + $ A( 1, p ), 1, + $ A( 1, q ), 1 ) CALL DAXPY( M, - + -CS*SN*AQOAP, - + A( 1, q ), 1, - + A( 1, p ), 1 ) + $ -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 ) + $ T*APOAQ, V( 1, p ), + $ 1, V( 1, q ), 1 ) CALL DAXPY( MVL, - + -CS*SN*AQOAP, - + V( 1, q ), 1, - + V( 1, p ), 1 ) + $ -CS*SN*AQOAP, + $ V( 1, q ), 1, + $ V( 1, p ), 1 ) END IF END IF END IF @@ -810,38 +901,38 @@ ELSE IF( AAPP.GT.AAQQ ) THEN CALL DCOPY( M, A( 1, p ), 1, WORK, - + 1 ) + $ 1 ) CALL DLASCL( 'G', 0, 0, AAPP, ONE, - + M, 1, WORK, LDA, IERR ) + $ M, 1, WORK, LDA, IERR ) CALL DLASCL( 'G', 0, 0, AAQQ, ONE, - + M, 1, A( 1, q ), LDA, - + IERR ) + $ M, 1, A( 1, q ), LDA, + $ IERR ) TEMP1 = -AAPQ*D( p ) / D( q ) CALL DAXPY( M, TEMP1, WORK, 1, - + A( 1, q ), 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 ) + $ M, 1, A( 1, q ), LDA, + $ IERR ) + SVA( q ) = AAQQ*DSQRT( MAX( ZERO, + $ ONE-AAPQ*AAPQ ) ) + MXSINJ = MAX( MXSINJ, SFMIN ) ELSE CALL DCOPY( M, A( 1, q ), 1, WORK, - + 1 ) + $ 1 ) CALL DLASCL( 'G', 0, 0, AAQQ, ONE, - + M, 1, WORK, LDA, IERR ) + $ M, 1, WORK, LDA, IERR ) CALL DLASCL( 'G', 0, 0, AAPP, ONE, - + M, 1, A( 1, p ), LDA, - + IERR ) + $ M, 1, A( 1, p ), LDA, + $ IERR ) TEMP1 = -AAPQ*D( q ) / D( p ) CALL DAXPY( M, TEMP1, WORK, 1, - + A( 1, p ), 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 ) + $ M, 1, A( 1, p ), LDA, + $ IERR ) + SVA( p ) = AAPP*DSQRT( MAX( ZERO, + $ ONE-AAPQ*AAPQ ) ) + MXSINJ = MAX( MXSINJ, SFMIN ) END IF END IF * END IF ROTOK THEN ... ELSE @@ -849,29 +940,29 @@ * In the case of cancellation in updating SVA(q) * .. recompute SVA(q) IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS ) - + THEN + $ THEN IF( ( AAQQ.LT.ROOTBIG ) .AND. - + ( AAQQ.GT.ROOTSFMIN ) ) THEN + $ ( AAQQ.GT.ROOTSFMIN ) ) THEN SVA( q ) = DNRM2( M, A( 1, q ), 1 )* - + D( q ) + $ D( q ) ELSE T = ZERO - AAQQ = ZERO + AAQQ = ONE CALL DLASSQ( M, A( 1, q ), 1, T, - + AAQQ ) + $ 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.GT.ROOTSFMIN ) ) THEN AAPP = DNRM2( M, A( 1, p ), 1 )* - + D( p ) + $ D( p ) ELSE T = ZERO - AAPP = ZERO + AAPP = ONE CALL DLASSQ( M, A( 1, p ), 1, T, - + AAPP ) + $ AAPP ) AAPP = T*DSQRT( AAPP )*D( p ) END IF SVA( p ) = AAPP @@ -889,13 +980,13 @@ END IF * IF( ( i.LE.SWBAND ) .AND. ( IJBLSK.GE.BLSKIP ) ) - + THEN + $ THEN SVA( p ) = AAPP NOTROT = 0 GO TO 2011 END IF IF( ( i.LE.SWBAND ) .AND. - + ( PSKIPPED.GT.ROWSKIP ) ) THEN + $ ( PSKIPPED.GT.ROWSKIP ) ) THEN AAPP = -AAPP NOTROT = 0 GO TO 2203 @@ -909,7 +1000,7 @@ * ELSE IF( AAPP.EQ.ZERO )NOTROT = NOTROT + - + MIN0( jgl+KBL-1, N ) - jgl + 1 + $ MIN( jgl+KBL-1, N ) - jgl + 1 IF( AAPP.LT.ZERO )NOTROT = 0 END IF @@ -919,7 +1010,7 @@ * end of the jbc-loop 2011 CONTINUE *2011 bailed out of the jbc-loop - DO 2012 p = igl, MIN0( igl+KBL-1, N ) + DO 2012 p = igl, MIN( igl+KBL-1, N ) SVA( p ) = DABS( SVA( p ) ) 2012 CONTINUE * @@ -928,11 +1019,11 @@ * * .. update SVA(N) IF( ( SVA( N ).LT.ROOTBIG ) .AND. ( SVA( N ).GT.ROOTSFMIN ) ) - + THEN + $ THEN SVA( N ) = DNRM2( M, A( 1, N ), 1 )*D( N ) ELSE T = ZERO - AAPP = ZERO + AAPP = ONE CALL DLASSQ( M, A( 1, N ), 1, T, AAPP ) SVA( N ) = T*DSQRT( AAPP )*D( N ) END IF @@ -940,10 +1031,10 @@ * Additional steering devices * IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR. - + ( ISWROT.LE.N ) ) )SWBAND = i + $ ( ISWROT.LE.N ) ) )SWBAND = i * IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.DBLE( N )*TOL ) .AND. - + ( DBLE( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN + $ ( DBLE( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN GO TO 1994 END IF * @@ -951,7 +1042,7 @@ 1993 CONTINUE * end i=1:NSWEEP loop -* #:) Reaching this point means that the procedure has comleted the given +* #:) Reaching this point means that the procedure has completed the given * number of iterations. INFO = NSWEEP - 1 GO TO 1995