[BACK]Return to zgsvj1.f CVS log [TXT] [DIR] Up to [local] / rpl / lapack / lapack

Diff for /rpl/lapack/lapack/zgsvj1.f between versions 1.2 and 1.9

version 1.2, 2016/08/27 15:27:13 version 1.9, 2023/08/07 08:39:22
Line 2 Line 2
 *  *
 *  =========== DOCUMENTATION ===========  *  =========== DOCUMENTATION ===========
 *  *
 * Online html documentation available at   * Online html documentation available at
 *            http://www.netlib.org/lapack/explore-html/   *            http://www.netlib.org/lapack/explore-html/
 *  *
 *> \htmlonly  *> \htmlonly
 *> Download ZGSVJ1 + dependencies   *> Download ZGSVJ1 + dependencies
 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dgsvj1.f">   *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zgsvj1.f">
 *> [TGZ]</a>   *> [TGZ]</a>
 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dgsvj1.f">   *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zgsvj1.f">
 *> [ZIP]</a>   *> [ZIP]</a>
 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dgsvj1.f">   *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zgsvj1.f">
 *> [TXT]</a>  *> [TXT]</a>
 *> \endhtmlonly   *> \endhtmlonly
 *  *
 *  Definition:  *  Definition:
 *  ===========  *  ===========
 *  *
 *       SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV,  *       SUBROUTINE ZGSVJ1( 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 )
 *   *
 *       .. Scalar Arguments ..  *       .. Scalar Arguments ..
 *       DOUBLE PRECISION   EPS, SFMIN, TOL  *       DOUBLE PRECISION   EPS, SFMIN, TOL
 *       INTEGER            INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP  *       INTEGER            INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP
 *       CHARACTER*1        JOBV  *       CHARACTER*1        JOBV
 *       ..  *       ..
 *       .. Array Arguments ..  *       .. Array Arguments ..
 *       COMPLEX*16     A( LDA, * ), D( N ), V( LDV, * ), WORK( LWORK )  *       COMPLEX*16         A( LDA, * ), D( N ), V( LDV, * ), WORK( LWORK )
 *       DOUBLE PRECISION           SVA( N )        *       DOUBLE PRECISION   SVA( N )
 *       ..  *       ..
 *    *
 *  *
 *> \par Purpose:  *> \par Purpose:
 *  =============  *  =============
Line 40 Line 40
 *> ZGSVJ1 is called from ZGESVJ as a pre-processor and that is its main  *> ZGSVJ1 is called from ZGESVJ as a pre-processor and that is its main
 *> purpose. It applies Jacobi rotations in the same way as ZGESVJ does, but  *> purpose. It applies Jacobi rotations in the same way as ZGESVJ does, but
 *> it targets only particular pivots and it does not check convergence  *> it targets only particular pivots and it does not check convergence
 *> (stopping criterion). Few tunning parameters (marked by [TP]) are  *> (stopping criterion). Few tuning parameters (marked by [TP]) are
 *> available for the implementer.  *> available for the implementer.
 *>  *>
 *> Further Details  *> Further Details
Line 61 Line 61
 *> In terms of the columns of A, the first N1 columns are rotated 'against'  *> In terms of the columns of A, the first N1 columns are rotated 'against'
 *> the remaining N-N1 columns, trying to increase the angle between the  *> the remaining N-N1 columns, trying to increase the angle between the
 *> corresponding subspaces. The off-diagonal block is N1-by(N-N1) and it is  *> corresponding subspaces. The off-diagonal block is N1-by(N-N1) and it is
 *> tiled using quadratic tiles of side KBL. Here, KBL is a tunning parmeter.  *> tiled using quadratic tiles of side KBL. Here, KBL is a tuning parameter.
 *> The number of sweeps is given in NSWEEP and the orthogonality threshold  *> The number of sweeps is given in NSWEEP and the orthogonality threshold
 *> is given in TOL.  *> is given in TOL.
 *> \endverbatim  *> \endverbatim
Line 147 Line 147
 *> \param[in] MV  *> \param[in] MV
 *> \verbatim  *> \verbatim
 *>          MV is INTEGER  *>          MV is INTEGER
 *>          If JOBV .EQ. 'A', then MV rows of V are post-multipled by a  *>          If JOBV = 'A', then MV rows of V are post-multipled by a
 *>                           sequence of Jacobi rotations.  *>                           sequence of Jacobi rotations.
 *>          If JOBV = 'N',   then MV is not referenced.  *>          If JOBV = 'N',   then MV is not referenced.
 *> \endverbatim  *> \endverbatim
Line 155 Line 155
 *> \param[in,out] V  *> \param[in,out] V
 *> \verbatim  *> \verbatim
 *>          V is COMPLEX*16 array, dimension (LDV,N)  *>          V is COMPLEX*16 array, dimension (LDV,N)
 *>          If JOBV .EQ. 'V' then N rows of V are post-multipled by a  *>          If JOBV = 'V' then N rows of V are post-multipled by a
 *>                           sequence of Jacobi rotations.  *>                           sequence of Jacobi rotations.
 *>          If JOBV .EQ. 'A' then MV rows of V are post-multipled by a  *>          If JOBV = 'A' then MV rows of V are post-multipled by a
 *>                           sequence of Jacobi rotations.  *>                           sequence of Jacobi rotations.
 *>          If JOBV = 'N',   then V is not referenced.  *>          If JOBV = 'N',   then V is not referenced.
 *> \endverbatim  *> \endverbatim
Line 166 Line 166
 *> \verbatim  *> \verbatim
 *>          LDV is INTEGER  *>          LDV is INTEGER
 *>          The leading dimension of the array V,  LDV >= 1.  *>          The leading dimension of the array V,  LDV >= 1.
 *>          If JOBV = 'V', LDV .GE. N.  *>          If JOBV = 'V', LDV >= N.
 *>          If JOBV = 'A', LDV .GE. MV.  *>          If JOBV = 'A', LDV >= MV.
 *> \endverbatim  *> \endverbatim
 *>  *>
 *> \param[in] EPS  *> \param[in] EPS
Line 187 Line 187
 *>          TOL is DOUBLE PRECISION  *>          TOL is DOUBLE PRECISION
 *>          TOL is the threshold for Jacobi rotations. For a pair  *>          TOL is the threshold for Jacobi rotations. For a pair
 *>          A(:,p), A(:,q) of pivot columns, the Jacobi rotation is  *>          A(:,p), A(:,q) of pivot columns, the Jacobi rotation is
 *>          applied only if ABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL.  *>          applied only if ABS(COS(angle(A(:,p),A(:,q)))) > TOL.
 *> \endverbatim  *> \endverbatim
 *>  *>
 *> \param[in] NSWEEP  *> \param[in] NSWEEP
Line 205 Line 205
 *> \param[in] LWORK  *> \param[in] LWORK
 *> \verbatim  *> \verbatim
 *>          LWORK is INTEGER  *>          LWORK is INTEGER
 *>          LWORK is the dimension of WORK. LWORK .GE. M.  *>          LWORK is the dimension of WORK. LWORK >= M.
 *> \endverbatim  *> \endverbatim
 *>  *>
 *> \param[out] INFO  *> \param[out] INFO
 *> \verbatim  *> \verbatim
 *>          INFO is INTEGER  *>          INFO is INTEGER
 *>          = 0 : successful exit.  *>          = 0:  successful exit.
 *>          < 0 : if INFO = -i, then the i-th argument had an illegal value  *>          < 0:  if INFO = -i, then the i-th argument had an illegal value
 *> \endverbatim  *> \endverbatim
 *  *
 *  Authors:  *  Authors:
 *  ========  *  ========
 *  *
 *> \author Univ. of Tennessee   *> \author Univ. of Tennessee
 *> \author Univ. of California Berkeley   *> \author Univ. of California Berkeley
 *> \author Univ. of Colorado Denver   *> \author Univ. of Colorado Denver
 *> \author NAG Ltd.   *> \author NAG Ltd.
 *  
 *> \date June 2016  
 *  *
 *> \ingroup complex16OTHERcomputational  *> \ingroup complex16OTHERcomputational
 *  *
 *> \par Contributors:  *> \par Contributor:
 *  ==================  *  ==================
 *>  *>
 *> Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)  *> Zlatko Drmac (Zagreb, Croatia)
 *  *
 *  =====================================================================  *  =====================================================================
       SUBROUTINE ZGSVJ1( JOBV, M, N, N1, A, LDA, D, SVA, MV, V, LDV,        SUBROUTINE ZGSVJ1( 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 computational routine (version 3.6.1) --  *  -- LAPACK computational routine --
 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --  *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--  *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
 *     June 2016  
 *  *
       IMPLICIT NONE         IMPLICIT NONE
 *     .. Scalar Arguments ..  *     .. Scalar Arguments ..
       DOUBLE PRECISION   EPS, SFMIN, TOL        DOUBLE PRECISION   EPS, SFMIN, TOL
       INTEGER            INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP        INTEGER            INFO, LDA, LDV, LWORK, M, MV, N, N1, NSWEEP
Line 249 Line 246
 *     ..  *     ..
 *     .. Array Arguments ..  *     .. Array Arguments ..
       COMPLEX*16         A( LDA, * ), D( N ), V( LDV, * ), WORK( LWORK )        COMPLEX*16         A( LDA, * ), D( N ), V( LDV, * ), WORK( LWORK )
       DOUBLE PRECISION   SVA( N )         DOUBLE PRECISION   SVA( N )
 *     ..  *     ..
 *  *
 *  =====================================================================  *  =====================================================================
Line 261 Line 258
 *     .. Local Scalars ..  *     .. Local Scalars ..
       COMPLEX*16         AAPQ, OMPQ        COMPLEX*16         AAPQ, OMPQ
       DOUBLE PRECISION   AAPP, AAPP0, AAPQ1, AAQQ, APOAQ, AQOAP, BIG,        DOUBLE PRECISION   AAPP, AAPP0, AAPQ1, AAQQ, APOAQ, AQOAP, BIG,
      $                   BIGTHETA, CS, LARGE, MXAAPQ, MXSINJ, ROOTBIG,       $                   BIGTHETA, CS, MXAAPQ, MXSINJ, ROOTBIG,
      $                   ROOTEPS, ROOTSFMIN, ROOTTOL, SMALL, SN, T,       $                   ROOTEPS, ROOTSFMIN, ROOTTOL, SMALL, SN, T,
      $                   TEMP1, THETA, THSIGN       $                   TEMP1, THETA, THSIGN
       INTEGER            BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK,        INTEGER            BLSKIP, EMPTSW, i, ibr, igl, IERR, IJBLSK,
Line 271 Line 268
 *     ..  *     ..
 *     ..  *     ..
 *     .. Intrinsic Functions ..  *     .. Intrinsic Functions ..
       INTRINSIC          ABS, DCONJG, DMAX1, DBLE, MIN0, DSIGN, DSQRT        INTRINSIC          ABS, CONJG, MAX, DBLE, MIN, SIGN, SQRT
 *     ..  *     ..
 *     .. External Functions ..  *     .. External Functions ..
       DOUBLE PRECISION   DZNRM2        DOUBLE PRECISION   DZNRM2
Line 281 Line 278
       EXTERNAL           IDAMAX, LSAME, ZDOTC, DZNRM2        EXTERNAL           IDAMAX, LSAME, ZDOTC, DZNRM2
 *     ..  *     ..
 *     .. External Subroutines ..  *     .. External Subroutines ..
 *     .. from BLAS        *     .. from BLAS
       EXTERNAL           ZCOPY, ZROT, ZSWAP        EXTERNAL           ZCOPY, ZROT, ZSWAP, ZAXPY
 *     .. from LAPACK  *     .. from LAPACK
       EXTERNAL           ZLASCL, ZLASSQ, XERBLA        EXTERNAL           ZLASCL, ZLASSQ, XERBLA
 *     ..  *     ..
Line 304 Line 301
          INFO = -6           INFO = -6
       ELSE IF( ( RSVEC.OR.APPLV ) .AND. ( MV.LT.0 ) ) THEN        ELSE IF( ( RSVEC.OR.APPLV ) .AND. ( MV.LT.0 ) ) THEN
          INFO = -9           INFO = -9
       ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR.         ELSE IF( ( RSVEC.AND.( LDV.LT.N ) ).OR.
      $         ( APPLV.AND.( LDV.LT.MV ) )  ) THEN       $         ( APPLV.AND.( LDV.LT.MV ) )  ) THEN
          INFO = -11           INFO = -11
       ELSE IF( TOL.LE.EPS ) THEN        ELSE IF( TOL.LE.EPS ) THEN
Line 330 Line 327
       END IF        END IF
       RSVEC = RSVEC .OR. APPLV        RSVEC = RSVEC .OR. APPLV
   
       ROOTEPS = DSQRT( EPS )        ROOTEPS = SQRT( EPS )
       ROOTSFMIN = DSQRT( SFMIN )        ROOTSFMIN = SQRT( SFMIN )
       SMALL = SFMIN / EPS        SMALL = SFMIN / EPS
       BIG = ONE / SFMIN        BIG = ONE / SFMIN
       ROOTBIG = ONE / ROOTSFMIN        ROOTBIG = ONE / ROOTSFMIN
       LARGE = BIG / DSQRT( DBLE( M*N ) )  *     LARGE = BIG / SQRT( DBLE( M*N ) )
       BIGTHETA = ONE / ROOTEPS        BIGTHETA = ONE / ROOTEPS
       ROOTTOL = DSQRT( TOL )        ROOTTOL = SQRT( TOL )
 *  *
 *     .. Initialize the right singular vector matrix ..  *     .. Initialize the right singular vector matrix ..
 *  *
Line 348 Line 345
 *  *
 *     .. Row-cyclic pivot strategy with de Rijk's pivoting ..  *     .. Row-cyclic pivot strategy with de Rijk's pivoting ..
 *  *
       KBL = MIN0( 8, N )        KBL = MIN( 8, N )
       NBLR = N1 / KBL        NBLR = N1 / KBL
       IF( ( NBLR*KBL ).NE.N1 )NBLR = NBLR + 1        IF( ( NBLR*KBL ).NE.N1 )NBLR = NBLR + 1
   
Line 359 Line 356
       BLSKIP = ( KBL**2 ) + 1        BLSKIP = ( KBL**2 ) + 1
 *[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL.  *[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.  *[TP] ROWSKIP is a tuning parameter.
       SWBAND = 0        SWBAND = 0
 *[TP] SWBAND is a tuning parameter. It is meaningful and effective  *[TP] SWBAND is a tuning parameter. It is meaningful and effective
Line 402 Line 399
             igl = ( ibr-1 )*KBL + 1              igl = ( ibr-1 )*KBL + 1
 *  *
 *            DO 2010 jbc = ibr + 1, NBL  *            DO 2010 jbc = ibr + 1, NBL
             DO 2010 jbc = 1, NBLC                  DO 2010 jbc = 1, NBLC
 *  *
                jgl = ( jbc-1 )*KBL + N1 + 1                 jgl = ( jbc-1 )*KBL + N1 + 1
 *  *
 *        doing the block at ( ibr, jbc )  *        doing the block at ( ibr, jbc )
 *  *
                IJBLSK = 0                 IJBLSK = 0
                DO 2100 p = igl, MIN0( igl+KBL-1, N1 )                 DO 2100 p = igl, MIN( 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, MIN( jgl+KBL-1, N )
 *  *
                         AAQQ = SVA( q )                          AAQQ = SVA( q )
                         IF( AAQQ.GT.ZERO ) THEN                          IF( AAQQ.GT.ZERO ) THEN
Line 433 Line 430
                                  ROTOK = ( SMALL*AAQQ ).LE.AAPP                                   ROTOK = ( SMALL*AAQQ ).LE.AAPP
                               END IF                                END IF
                               IF( AAPP.LT.( BIG / AAQQ ) ) THEN                                IF( AAPP.LT.( BIG / AAQQ ) ) THEN
                                  AAPQ = ( ZDOTC( M, A( 1, p ), 1,                                    AAPQ = ( ZDOTC( M, A( 1, p ), 1,
      $                                  A( 1, q ), 1 ) / AAQQ ) / AAPP       $                                  A( 1, q ), 1 ) / AAQQ ) / AAPP
                               ELSE                                ELSE
                                  CALL ZCOPY( M, A( 1, p ), 1,                                   CALL ZCOPY( M, A( 1, p ), 1,
Line 451 Line 448
                                  ROTOK = AAQQ.LE.( AAPP / SMALL )                                   ROTOK = AAQQ.LE.( AAPP / SMALL )
                               END IF                                END IF
                               IF( AAPP.GT.( SMALL / AAQQ ) ) THEN                                IF( AAPP.GT.( SMALL / AAQQ ) ) THEN
                                  AAPQ = ( ZDOTC( M, A( 1, p ), 1,                                    AAPQ = ( ZDOTC( M, A( 1, p ), 1,
      $                                   A( 1, q ), 1 ) / AAQQ ) / AAPP       $                                 A( 1, q ), 1 ) / MAX(AAQQ,AAPP) )
        $                                               / MIN(AAQQ,AAPP)
                               ELSE                                ELSE
                                  CALL ZCOPY( M, A( 1, q ), 1,                                   CALL ZCOPY( M, A( 1, q ), 1,
      $                                       WORK, 1 )       $                                       WORK, 1 )
Line 464 Line 462
                               END IF                                END IF
                            END IF                             END IF
 *  *
                            OMPQ = AAPQ / ABS(AAPQ)   *                           AAPQ = AAPQ * CONJG(CWORK(p))*CWORK(q)
 *                           AAPQ = AAPQ * DCONJG(CWORK(p))*CWORK(q)     
                            AAPQ1  = -ABS(AAPQ)                             AAPQ1  = -ABS(AAPQ)
                            MXAAPQ = DMAX1( MXAAPQ, -AAPQ1 )                             MXAAPQ = MAX( MXAAPQ, -AAPQ1 )
 *  *
 *        TO rotate or NOT to rotate, THAT is the question ...  *        TO rotate or NOT to rotate, THAT is the question ...
 *  *
                            IF( ABS( AAPQ1 ).GT.TOL ) THEN                             IF( ABS( AAPQ1 ).GT.TOL ) THEN
                                 OMPQ = AAPQ / ABS(AAPQ)
                               NOTROT = 0                                NOTROT = 0
 *[RTD]      ROTATED  = ROTATED + 1  *[RTD]      ROTATED  = ROTATED + 1
                               PSKIPPED = 0                                PSKIPPED = 0
Line 486 Line 484
 *  *
                                  IF( ABS( THETA ).GT.BIGTHETA ) THEN                                   IF( ABS( THETA ).GT.BIGTHETA ) THEN
                                     T  = HALF / THETA                                      T  = HALF / THETA
                                     CS = ONE                                       CS = ONE
                                     CALL ZROT( M, A(1,p), 1, A(1,q), 1,                                      CALL ZROT( M, A(1,p), 1, A(1,q), 1,
      $                                          CS, DCONJG(OMPQ)*T )       $                                          CS, CONJG(OMPQ)*T )
                                     IF( RSVEC ) THEN                                      IF( RSVEC ) THEN
                                         CALL ZROT( MVL, V(1,p), 1,                                           CALL ZROT( MVL, V(1,p), 1,
      $                                  V(1,q), 1, CS, DCONJG(OMPQ)*T )       $                                  V(1,q), 1, CS, CONJG(OMPQ)*T )
                                     END IF                                      END IF
                                     SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,                                      SVA( q ) = AAQQ*SQRT( MAX( ZERO,
      $                                         ONE+T*APOAQ*AAPQ1 ) )       $                                         ONE+T*APOAQ*AAPQ1 ) )
                                     AAPP = AAPP*DSQRT( DMAX1( ZERO,                                      AAPP = AAPP*SQRT( MAX( ZERO,
      $                                     ONE-T*AQOAP*AAPQ1 ) )       $                                     ONE-T*AQOAP*AAPQ1 ) )
                                     MXSINJ = DMAX1( MXSINJ, ABS( T ) )                                      MXSINJ = MAX( MXSINJ, ABS( T ) )
                                  ELSE                                   ELSE
 *  *
 *                 .. choose correct signum for THETA and rotate  *                 .. choose correct signum for THETA and rotate
 *  *
                                     THSIGN = -DSIGN( ONE, AAPQ1 )                                      THSIGN = -SIGN( ONE, AAPQ1 )
                                     IF( AAQQ.GT.AAPP0 )THSIGN = -THSIGN                                      IF( AAQQ.GT.AAPP0 )THSIGN = -THSIGN
                                     T = ONE / ( THETA+THSIGN*                                      T = ONE / ( THETA+THSIGN*
      $                                  DSQRT( ONE+THETA*THETA ) )       $                                  SQRT( ONE+THETA*THETA ) )
                                     CS = DSQRT( ONE / ( ONE+T*T ) )                                      CS = SQRT( ONE / ( ONE+T*T ) )
                                     SN = T*CS                                      SN = T*CS
                                     MXSINJ = DMAX1( MXSINJ, ABS( SN ) )                                      MXSINJ = MAX( MXSINJ, ABS( SN ) )
                                     SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,                                      SVA( q ) = AAQQ*SQRT( MAX( ZERO,
      $                                         ONE+T*APOAQ*AAPQ1 ) )       $                                         ONE+T*APOAQ*AAPQ1 ) )
                                     AAPP = AAPP*DSQRT( DMAX1( ZERO,                                        AAPP = AAPP*SQRT( MAX( ZERO,
      $                                         ONE-T*AQOAP*AAPQ1 ) )       $                                         ONE-T*AQOAP*AAPQ1 ) )
 *  *
                                     CALL ZROT( M, A(1,p), 1, A(1,q), 1,                                      CALL ZROT( M, A(1,p), 1, A(1,q), 1,
      $                                          CS, DCONJG(OMPQ)*SN )        $                                          CS, CONJG(OMPQ)*SN )
                                     IF( RSVEC ) THEN                                      IF( RSVEC ) THEN
                                         CALL ZROT( MVL, V(1,p), 1,                                           CALL ZROT( MVL, V(1,p), 1,
      $                                  V(1,q), 1, CS, DCONJG(OMPQ)*SN )       $                                  V(1,q), 1, CS, CONJG(OMPQ)*SN )
                                     END IF                                      END IF
                                  END IF                                   END IF
                                  D(p) = -D(q) * OMPQ                                   D(p) = -D(q) * OMPQ
Line 539 Line 537
                                     CALL ZLASCL( 'G', 0, 0, ONE, AAQQ,                                      CALL ZLASCL( 'G', 0, 0, ONE, AAQQ,
      $                                           M, 1, A( 1, q ), LDA,       $                                           M, 1, A( 1, q ), LDA,
      $                                           IERR )       $                                           IERR )
                                     SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,                                      SVA( q ) = AAQQ*SQRT( MAX( ZERO,
      $                                         ONE-AAPQ1*AAPQ1 ) )       $                                         ONE-AAPQ1*AAPQ1 ) )
                                     MXSINJ = DMAX1( MXSINJ, SFMIN )                                      MXSINJ = MAX( MXSINJ, SFMIN )
                                ELSE                                 ELSE
                                    CALL ZCOPY( M, A( 1, q ), 1,                                     CALL ZCOPY( M, A( 1, q ), 1,
      $                                          WORK, 1 )       $                                          WORK, 1 )
Line 551 Line 549
                                     CALL ZLASCL( 'G', 0, 0, AAPP, ONE,                                      CALL ZLASCL( 'G', 0, 0, AAPP, ONE,
      $                                           M, 1, A( 1, p ), LDA,       $                                           M, 1, A( 1, p ), LDA,
      $                                           IERR )       $                                           IERR )
                                     CALL ZAXPY( M, -DCONJG(AAPQ),                                       CALL ZAXPY( M, -CONJG(AAPQ),
      $                                   WORK, 1, A( 1, p ), 1 )       $                                   WORK, 1, A( 1, p ), 1 )
                                     CALL ZLASCL( 'G', 0, 0, ONE, AAPP,                                      CALL ZLASCL( 'G', 0, 0, ONE, AAPP,
      $                                           M, 1, A( 1, p ), LDA,       $                                           M, 1, A( 1, p ), LDA,
      $                                           IERR )       $                                           IERR )
                                     SVA( p ) = AAPP*DSQRT( DMAX1( ZERO,                                      SVA( p ) = AAPP*SQRT( MAX( ZERO,
      $                                         ONE-AAPQ1*AAPQ1 ) )       $                                         ONE-AAPQ1*AAPQ1 ) )
                                     MXSINJ = DMAX1( MXSINJ, SFMIN )                                      MXSINJ = MAX( MXSINJ, SFMIN )
                                END IF                                 END IF
                               END IF                                END IF
 *           END IF ROTOK THEN ... ELSE  *           END IF ROTOK THEN ... ELSE
Line 575 Line 573
                                     AAQQ = ONE                                      AAQQ = ONE
                                     CALL ZLASSQ( M, A( 1, q ), 1, T,                                      CALL ZLASSQ( M, A( 1, q ), 1, T,
      $                                           AAQQ )       $                                           AAQQ )
                                     SVA( q ) = T*DSQRT( AAQQ )                                      SVA( q ) = T*SQRT( AAQQ )
                                  END IF                                   END IF
                               END IF                                END IF
                               IF( ( AAPP / AAPP0 )**2.LE.ROOTEPS ) THEN                                IF( ( AAPP / AAPP0 )**2.LE.ROOTEPS ) THEN
Line 587 Line 585
                                     AAPP = ONE                                      AAPP = ONE
                                     CALL ZLASSQ( M, A( 1, p ), 1, T,                                      CALL ZLASSQ( M, A( 1, p ), 1, T,
      $                                           AAPP )       $                                           AAPP )
                                     AAPP = T*DSQRT( AAPP )                                      AAPP = T*SQRT( AAPP )
                                  END IF                                   END IF
                                  SVA( p ) = AAPP                                   SVA( p ) = AAPP
                               END IF                                END IF
Line 626 Line 624
                   ELSE                    ELSE
 *  *
                      IF( AAPP.EQ.ZERO )NOTROT = NOTROT +                       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                       IF( AAPP.LT.ZERO )NOTROT = 0
 *  *
                   END IF                    END IF
Line 637 Line 635
 *     end of the jbc-loop  *     end of the jbc-loop
  2011       CONTINUE   2011       CONTINUE
 *2011 bailed out of the jbc-loop  *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 ) = ABS( SVA( p ) )                 SVA( p ) = ABS( SVA( p ) )
  2012       CONTINUE   2012       CONTINUE
 ***  ***
Line 652 Line 650
             T = ZERO              T = ZERO
             AAPP = ONE              AAPP = ONE
             CALL ZLASSQ( M, A( 1, N ), 1, T, AAPP )              CALL ZLASSQ( M, A( 1, N ), 1, T, AAPP )
             SVA( N ) = T*DSQRT( AAPP )              SVA( N ) = T*SQRT( AAPP )
          END IF           END IF
 *  *
 *     Additional steering devices  *     Additional steering devices
Line 660 Line 658
          IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR.           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.DSQRT( DBLE( N ) )*           IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.SQRT( DBLE( N ) )*
      $       TOL ) .AND. ( DBLE( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN       $       TOL ) .AND. ( DBLE( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN
             GO TO 1994              GO TO 1994
          END IF           END IF
Removed from v.1.2  
changed lines
  Added in v.1.9

CVSweb interface <joel.bertrand@systella.fr>