LAPACK: SRC/dgsvj0.f Source File

00001       SUBROUTINE DGSVJ0( JOBV, M, N, A, LDA, D, SVA, MV, V, LDV, EPS,
00002      +                   SFMIN, TOL, NSWEEP, WORK, LWORK, INFO )
00003 *
00004 *  -- LAPACK routine (version 3.2.2)                                    --
00005 *
00006 *  -- Contributed by Zlatko Drmac of the University of Zagreb and     --
00007 *  -- Kresimir Veselic of the Fernuniversitaet Hagen                  --
00008 *  -- June 2010                                                       --
00009 *
00010 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00011 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00012 *
00013 * This routine is also part of SIGMA (version 1.23, October 23. 2008.)
00014 * SIGMA is a library of algorithms for highly accurate algorithms for
00015 * computation of SVD, PSVD, QSVD, (H,K)-SVD, and for solution of the
00016 * eigenvalue problems Hx = lambda M x, H M x = lambda x with H, M > 0.
00017 *
00018       IMPLICIT NONE
00019 *     .. Scalar Arguments ..
00020       INTEGER            INFO, LDA, LDV, LWORK, M, MV, N, NSWEEP
00021       DOUBLE PRECISION   EPS, SFMIN, TOL
00022       CHARACTER*1        JOBV
00023 *     ..
00024 *     .. Array Arguments ..
00025       DOUBLE PRECISION   A( LDA, * ), SVA( N ), D( N ), V( LDV, * ),
00026      +                   WORK( LWORK )
00027 *     ..
00028 *
00029 *  Purpose
00030 *  =======
00031 *
00032 *  DGSVJ0 is called from DGESVJ as a pre-processor and that is its main
00033 *  purpose. It applies Jacobi rotations in the same way as DGESVJ does, but
00034 *  it does not check convergence (stopping criterion). Few tuning
00035 *  parameters (marked by [TP]) are available for the implementer.
00036 *
00037 *  Further Details
00038 *  ~~~~~~~~~~~~~~~
00039 *  DGSVJ0 is used just to enable SGESVJ to call a simplified version of
00040 *  itself to work on a submatrix of the original matrix.
00041 *
00042 *  Contributors
00043 *  ~~~~~~~~~~~~
00044 *  Zlatko Drmac (Zagreb, Croatia) and Kresimir Veselic (Hagen, Germany)
00045 *
00046 *  Bugs, Examples and Comments
00047 *  ~~~~~~~~~~~~~~~~~~~~~~~~~~~
00048 *  Please report all bugs and send interesting test examples and comments to
00049 *  drmac@math.hr. Thank you.
00050 *
00051 *  Arguments
00052 *  =========
00053 *
00054 *  JOBV    (input) CHARACTER*1
00055 *          Specifies whether the output from this procedure is used
00056 *          to compute the matrix V:
00057 *          = 'V': the product of the Jacobi rotations is accumulated
00058 *                 by postmulyiplying the N-by-N array V.
00059 *                (See the description of V.)
00060 *          = 'A': the product of the Jacobi rotations is accumulated
00061 *                 by postmulyiplying the MV-by-N array V.
00062 *                (See the descriptions of MV and V.)
00063 *          = 'N': the Jacobi rotations are not accumulated.
00064 *
00065 *  M       (input) INTEGER
00066 *          The number of rows of the input matrix A.  M >= 0.
00067 *
00068 *  N       (input) INTEGER
00069 *          The number of columns of the input matrix A.
00070 *          M >= N >= 0.
00071 *
00072 *  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
00073 *          On entry, M-by-N matrix A, such that A*diag(D) represents
00074 *          the input matrix.
00075 *          On exit,
00076 *          A_onexit * D_onexit represents the input matrix A*diag(D)
00077 *          post-multiplied by a sequence of Jacobi rotations, where the
00078 *          rotation threshold and the total number of sweeps are given in
00079 *          TOL and NSWEEP, respectively.
00080 *          (See the descriptions of D, TOL and NSWEEP.)
00081 *
00082 *  LDA     (input) INTEGER
00083 *          The leading dimension of the array A.  LDA >= max(1,M).
00084 *
00085 *  D       (input/workspace/output) DOUBLE PRECISION array, dimension (N)
00086 *          The array D accumulates the scaling factors from the fast scaled
00087 *          Jacobi rotations.
00088 *          On entry, A*diag(D) represents the input matrix.
00089 *          On exit, A_onexit*diag(D_onexit) represents the input matrix
00090 *          post-multiplied by a sequence of Jacobi rotations, where the
00091 *          rotation threshold and the total number of sweeps are given in
00092 *          TOL and NSWEEP, respectively.
00093 *          (See the descriptions of A, TOL and NSWEEP.)
00094 *
00095 *  SVA     (input/workspace/output) DOUBLE PRECISION array, dimension (N)
00096 *          On entry, SVA contains the Euclidean norms of the columns of
00097 *          the matrix A*diag(D).
00098 *          On exit, SVA contains the Euclidean norms of the columns of
00099 *          the matrix onexit*diag(D_onexit).
00100 *
00101 *  MV      (input) INTEGER
00102 *          If JOBV .EQ. 'A', then MV rows of V are post-multipled by a
00103 *                           sequence of Jacobi rotations.
00104 *          If JOBV = 'N',   then MV is not referenced.
00105 *
00106 *  V       (input/output) DOUBLE PRECISION array, dimension (LDV,N)
00107 *          If JOBV .EQ. 'V' then N rows of V are post-multipled by a
00108 *                           sequence of Jacobi rotations.
00109 *          If JOBV .EQ. 'A' then MV rows of V are post-multipled by a
00110 *                           sequence of Jacobi rotations.
00111 *          If JOBV = 'N',   then V is not referenced.
00112 *
00113 *  LDV     (input) INTEGER
00114 *          The leading dimension of the array V,  LDV >= 1.
00115 *          If JOBV = 'V', LDV .GE. N.
00116 *          If JOBV = 'A', LDV .GE. MV.
00117 *
00118 *  EPS     (input) DOUBLE PRECISION
00119 *          EPS = DLAMCH('Epsilon')
00120 *
00121 *  SFMIN   (input) DOUBLE PRECISION
00122 *          SFMIN = DLAMCH('Safe Minimum')
00123 *
00124 *  TOL     (input) DOUBLE PRECISION
00125 *          TOL is the threshold for Jacobi rotations. For a pair
00126 *          A(:,p), A(:,q) of pivot columns, the Jacobi rotation is
00127 *          applied only if DABS(COS(angle(A(:,p),A(:,q)))) .GT. TOL.
00128 *
00129 *  NSWEEP  (input) INTEGER
00130 *          NSWEEP is the number of sweeps of Jacobi rotations to be
00131 *          performed.
00132 *
00133 *  WORK    (workspace) DOUBLE PRECISION array, dimension (LWORK)
00134 *
00135 *  LWORK   (input) INTEGER
00136 *          LWORK is the dimension of WORK. LWORK .GE. M.
00137 *
00138 *  INFO    (output) INTEGER
00139 *          = 0 : successful exit.
00140 *          < 0 : if INFO = -i, then the i-th argument had an illegal value
00141 *
00142 *  =====================================================================
00143 *
00144 *     .. Local Parameters ..
00145       DOUBLE PRECISION   ZERO, HALF, ONE, TWO
00146       PARAMETER          ( ZERO = 0.0D0, HALF = 0.5D0, ONE = 1.0D0,
00147      +                   TWO = 2.0D0 )
00148 *     ..
00149 *     .. Local Scalars ..
00150       DOUBLE PRECISION   AAPP, AAPP0, AAPQ, AAQQ, APOAQ, AQOAP, BIG,
00151      +                   BIGTHETA, CS, MXAAPQ, MXSINJ, ROOTBIG, ROOTEPS,
00152      +                   ROOTSFMIN, ROOTTOL, SMALL, SN, T, TEMP1, THETA,
00153      +                   THSIGN
00154       INTEGER            BLSKIP, EMPTSW, i, ibr, IERR, igl, IJBLSK, ir1,
00155      +                   ISWROT, jbc, jgl, KBL, LKAHEAD, MVL, NBL,
00156      +                   NOTROT, p, PSKIPPED, q, ROWSKIP, SWBAND
00157       LOGICAL            APPLV, ROTOK, RSVEC
00158 *     ..
00159 *     .. Local Arrays ..
00160       DOUBLE PRECISION   FASTR( 5 )
00161 *     ..
00162 *     .. Intrinsic Functions ..
00163       INTRINSIC          DABS, DMAX1, DBLE, MIN0, DSIGN, DSQRT
00164 *     ..
00165 *     .. External Functions ..
00166       DOUBLE PRECISION   DDOT, DNRM2
00167       INTEGER            IDAMAX
00168       LOGICAL            LSAME
00169       EXTERNAL           IDAMAX, LSAME, DDOT, DNRM2
00170 *     ..
00171 *     .. External Subroutines ..
00172       EXTERNAL           DAXPY, DCOPY, DLASCL, DLASSQ, DROTM, DSWAP
00173 *     ..
00174 *     .. Executable Statements ..
00175 *
00176       APPLV = LSAME( JOBV, 'A' )
00177       RSVEC = LSAME( JOBV, 'V' )
00178       IF( .NOT.( RSVEC .OR. APPLV .OR. LSAME( JOBV, 'N' ) ) ) THEN
00179          INFO = -1
00180       ELSE IF( M.LT.0 ) THEN
00181          INFO = -2
00182       ELSE IF( ( N.LT.0 ) .OR. ( N.GT.M ) ) THEN
00183          INFO = -3
00184       ELSE IF( LDA.LT.M ) THEN
00185          INFO = -5
00186       ELSE IF( MV.LT.0 ) THEN
00187          INFO = -8
00188       ELSE IF( LDV.LT.M ) THEN
00189          INFO = -10
00190       ELSE IF( TOL.LE.EPS ) THEN
00191          INFO = -13
00192       ELSE IF( NSWEEP.LT.0 ) THEN
00193          INFO = -14
00194       ELSE IF( LWORK.LT.M ) THEN
00195          INFO = -16
00196       ELSE
00197          INFO = 0
00198       END IF
00199 *
00200 *     #:(
00201       IF( INFO.NE.0 ) THEN
00202          CALL XERBLA( 'DGSVJ0', -INFO )
00203          RETURN
00204       END IF
00205 *
00206       IF( RSVEC ) THEN
00207          MVL = N
00208       ELSE IF( APPLV ) THEN
00209          MVL = MV
00210       END IF
00211       RSVEC = RSVEC .OR. APPLV
00212 
00213       ROOTEPS = DSQRT( EPS )
00214       ROOTSFMIN = DSQRT( SFMIN )
00215       SMALL = SFMIN / EPS
00216       BIG = ONE / SFMIN
00217       ROOTBIG = ONE / ROOTSFMIN
00218       BIGTHETA = ONE / ROOTEPS
00219       ROOTTOL = DSQRT( TOL )
00220 *
00221 *
00222 *     -#- Row-cyclic Jacobi SVD algorithm with column pivoting -#-
00223 *
00224       EMPTSW = ( N*( N-1 ) ) / 2
00225       NOTROT = 0
00226       FASTR( 1 ) = ZERO
00227 *
00228 *     -#- Row-cyclic pivot strategy with de Rijk's pivoting -#-
00229 *
00230 
00231       SWBAND = 0
00232 *[TP] SWBAND is a tuning parameter. It is meaningful and effective
00233 *     if SGESVJ is used as a computational routine in the preconditioned
00234 *     Jacobi SVD algorithm SGESVJ. For sweeps i=1:SWBAND the procedure
00235 *     ......
00236 
00237       KBL = MIN0( 8, N )
00238 *[TP] KBL is a tuning parameter that defines the tile size in the
00239 *     tiling of the p-q loops of pivot pairs. In general, an optimal
00240 *     value of KBL depends on the matrix dimensions and on the
00241 *     parameters of the computer's memory.
00242 *
00243       NBL = N / KBL
00244       IF( ( NBL*KBL ).NE.N )NBL = NBL + 1
00245 
00246       BLSKIP = ( KBL**2 ) + 1
00247 *[TP] BLKSKIP is a tuning parameter that depends on SWBAND and KBL.
00248 
00249       ROWSKIP = MIN0( 5, KBL )
00250 *[TP] ROWSKIP is a tuning parameter.
00251 
00252       LKAHEAD = 1
00253 *[TP] LKAHEAD is a tuning parameter.
00254       SWBAND = 0
00255       PSKIPPED = 0
00256 *
00257       DO 1993 i = 1, NSWEEP
00258 *     .. go go go ...
00259 *
00260          MXAAPQ = ZERO
00261          MXSINJ = ZERO
00262          ISWROT = 0
00263 *
00264          NOTROT = 0
00265          PSKIPPED = 0
00266 *
00267          DO 2000 ibr = 1, NBL
00268 
00269             igl = ( ibr-1 )*KBL + 1
00270 *
00271             DO 1002 ir1 = 0, MIN0( LKAHEAD, NBL-ibr )
00272 *
00273                igl = igl + ir1*KBL
00274 *
00275                DO 2001 p = igl, MIN0( igl+KBL-1, N-1 )
00276 
00277 *     .. de Rijk's pivoting
00278                   q = IDAMAX( N-p+1, SVA( p ), 1 ) + p - 1
00279                   IF( p.NE.q ) THEN
00280                      CALL DSWAP( M, A( 1, p ), 1, A( 1, q ), 1 )
00281                      IF( RSVEC )CALL DSWAP( MVL, V( 1, p ), 1,
00282      +                                      V( 1, q ), 1 )
00283                      TEMP1 = SVA( p )
00284                      SVA( p ) = SVA( q )
00285                      SVA( q ) = TEMP1
00286                      TEMP1 = D( p )
00287                      D( p ) = D( q )
00288                      D( q ) = TEMP1
00289                   END IF
00290 *
00291                   IF( ir1.EQ.0 ) THEN
00292 *
00293 *        Column norms are periodically updated by explicit
00294 *        norm computation.
00295 *        Caveat:
00296 *        Some BLAS implementations compute DNRM2(M,A(1,p),1)
00297 *        as DSQRT(DDOT(M,A(1,p),1,A(1,p),1)), which may result in
00298 *        overflow for ||A(:,p)||_2 > DSQRT(overflow_threshold), and
00299 *        undeflow for ||A(:,p)||_2 < DSQRT(underflow_threshold).
00300 *        Hence, DNRM2 cannot be trusted, not even in the case when
00301 *        the true norm is far from the under(over)flow boundaries.
00302 *        If properly implemented DNRM2 is available, the IF-THEN-ELSE
00303 *        below should read "AAPP = DNRM2( M, A(1,p), 1 ) * D(p)".
00304 *
00305                      IF( ( SVA( p ).LT.ROOTBIG ) .AND.
00306      +                   ( SVA( p ).GT.ROOTSFMIN ) ) THEN
00307                         SVA( p ) = DNRM2( M, A( 1, p ), 1 )*D( p )
00308                      ELSE
00309                         TEMP1 = ZERO
00310                         AAPP = ZERO
00311                         CALL DLASSQ( M, A( 1, p ), 1, TEMP1, AAPP )
00312                         SVA( p ) = TEMP1*DSQRT( AAPP )*D( p )
00313                      END IF
00314                      AAPP = SVA( p )
00315                   ELSE
00316                      AAPP = SVA( p )
00317                   END IF
00318 
00319 *
00320                   IF( AAPP.GT.ZERO ) THEN
00321 *
00322                      PSKIPPED = 0
00323 *
00324                      DO 2002 q = p + 1, MIN0( igl+KBL-1, N )
00325 *
00326                         AAQQ = SVA( q )
00327 
00328                         IF( AAQQ.GT.ZERO ) THEN
00329 *
00330                            AAPP0 = AAPP
00331                            IF( AAQQ.GE.ONE ) THEN
00332                               ROTOK = ( SMALL*AAPP ).LE.AAQQ
00333                               IF( AAPP.LT.( BIG / AAQQ ) ) THEN
00334                                  AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1,
00335      +                                  q ), 1 )*D( p )*D( q ) / AAQQ )
00336      +                                  / AAPP
00337                               ELSE
00338                                  CALL DCOPY( M, A( 1, p ), 1, WORK, 1 )
00339                                  CALL DLASCL( 'G', 0, 0, AAPP, D( p ),
00340      +                                        M, 1, WORK, LDA, IERR )
00341                                  AAPQ = DDOT( M, WORK, 1, A( 1, q ),
00342      +                                  1 )*D( q ) / AAQQ
00343                               END IF
00344                            ELSE
00345                               ROTOK = AAPP.LE.( AAQQ / SMALL )
00346                               IF( AAPP.GT.( SMALL / AAQQ ) ) THEN
00347                                  AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1,
00348      +                                  q ), 1 )*D( p )*D( q ) / AAQQ )
00349      +                                  / AAPP
00350                               ELSE
00351                                  CALL DCOPY( M, A( 1, q ), 1, WORK, 1 )
00352                                  CALL DLASCL( 'G', 0, 0, AAQQ, D( q ),
00353      +                                        M, 1, WORK, LDA, IERR )
00354                                  AAPQ = DDOT( M, WORK, 1, A( 1, p ),
00355      +                                  1 )*D( p ) / AAPP
00356                               END IF
00357                            END IF
00358 *
00359                            MXAAPQ = DMAX1( MXAAPQ, DABS( AAPQ ) )
00360 *
00361 *        TO rotate or NOT to rotate, THAT is the question ...
00362 *
00363                            IF( DABS( AAPQ ).GT.TOL ) THEN
00364 *
00365 *           .. rotate
00366 *           ROTATED = ROTATED + ONE
00367 *
00368                               IF( ir1.EQ.0 ) THEN
00369                                  NOTROT = 0
00370                                  PSKIPPED = 0
00371                                  ISWROT = ISWROT + 1
00372                               END IF
00373 *
00374                               IF( ROTOK ) THEN
00375 *
00376                                  AQOAP = AAQQ / AAPP
00377                                  APOAQ = AAPP / AAQQ
00378                                  THETA = -HALF*DABS( AQOAP-APOAQ ) /
00379      +                                   AAPQ
00380 *
00381                                  IF( DABS( THETA ).GT.BIGTHETA ) THEN
00382 *
00383                                     T = HALF / THETA
00384                                     FASTR( 3 ) = T*D( p ) / D( q )
00385                                     FASTR( 4 ) = -T*D( q ) / D( p )
00386                                     CALL DROTM( M, A( 1, p ), 1,
00387      +                                          A( 1, q ), 1, FASTR )
00388                                     IF( RSVEC )CALL DROTM( MVL,
00389      +                                              V( 1, p ), 1,
00390      +                                              V( 1, q ), 1,
00391      +                                              FASTR )
00392                                     SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
00393      +                                         ONE+T*APOAQ*AAPQ ) )
00394                                     AAPP = AAPP*DSQRT( ONE-T*AQOAP*
00395      +                                     AAPQ )
00396                                     MXSINJ = DMAX1( MXSINJ, DABS( T ) )
00397 *
00398                                  ELSE
00399 *
00400 *                 .. choose correct signum for THETA and rotate
00401 *
00402                                     THSIGN = -DSIGN( ONE, AAPQ )
00403                                     T = ONE / ( THETA+THSIGN*
00404      +                                  DSQRT( ONE+THETA*THETA ) )
00405                                     CS = DSQRT( ONE / ( ONE+T*T ) )
00406                                     SN = T*CS
00407 *
00408                                     MXSINJ = DMAX1( MXSINJ, DABS( SN ) )
00409                                     SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
00410      +                                         ONE+T*APOAQ*AAPQ ) )
00411                                     AAPP = AAPP*DSQRT( DMAX1( ZERO,
00412      +                                     ONE-T*AQOAP*AAPQ ) )
00413 *
00414                                     APOAQ = D( p ) / D( q )
00415                                     AQOAP = D( q ) / D( p )
00416                                     IF( D( p ).GE.ONE ) THEN
00417                                        IF( D( q ).GE.ONE ) THEN
00418                                           FASTR( 3 ) = T*APOAQ
00419                                           FASTR( 4 ) = -T*AQOAP
00420                                           D( p ) = D( p )*CS
00421                                           D( q ) = D( q )*CS
00422                                           CALL DROTM( M, A( 1, p ), 1,
00423      +                                                A( 1, q ), 1,
00424      +                                                FASTR )
00425                                           IF( RSVEC )CALL DROTM( MVL,
00426      +                                        V( 1, p ), 1, V( 1, q ),
00427      +                                        1, FASTR )
00428                                        ELSE
00429                                           CALL DAXPY( M, -T*AQOAP,
00430      +                                                A( 1, q ), 1,
00431      +                                                A( 1, p ), 1 )
00432                                           CALL DAXPY( M, CS*SN*APOAQ,
00433      +                                                A( 1, p ), 1,
00434      +                                                A( 1, q ), 1 )
00435                                           D( p ) = D( p )*CS
00436                                           D( q ) = D( q ) / CS
00437                                           IF( RSVEC ) THEN
00438                                              CALL DAXPY( MVL, -T*AQOAP,
00439      +                                                   V( 1, q ), 1,
00440      +                                                   V( 1, p ), 1 )
00441                                              CALL DAXPY( MVL,
00442      +                                                   CS*SN*APOAQ,
00443      +                                                   V( 1, p ), 1,
00444      +                                                   V( 1, q ), 1 )
00445                                           END IF
00446                                        END IF
00447                                     ELSE
00448                                        IF( D( q ).GE.ONE ) THEN
00449                                           CALL DAXPY( M, T*APOAQ,
00450      +                                                A( 1, p ), 1,
00451      +                                                A( 1, q ), 1 )
00452                                           CALL DAXPY( M, -CS*SN*AQOAP,
00453      +                                                A( 1, q ), 1,
00454      +                                                A( 1, p ), 1 )
00455                                           D( p ) = D( p ) / CS
00456                                           D( q ) = D( q )*CS
00457                                           IF( RSVEC ) THEN
00458                                              CALL DAXPY( MVL, T*APOAQ,
00459      +                                                   V( 1, p ), 1,
00460      +                                                   V( 1, q ), 1 )
00461                                              CALL DAXPY( MVL,
00462      +                                                   -CS*SN*AQOAP,
00463      +                                                   V( 1, q ), 1,
00464      +                                                   V( 1, p ), 1 )
00465                                           END IF
00466                                        ELSE
00467                                           IF( D( p ).GE.D( q ) ) THEN
00468                                              CALL DAXPY( M, -T*AQOAP,
00469      +                                                   A( 1, q ), 1,
00470      +                                                   A( 1, p ), 1 )
00471                                              CALL DAXPY( M, CS*SN*APOAQ,
00472      +                                                   A( 1, p ), 1,
00473      +                                                   A( 1, q ), 1 )
00474                                              D( p ) = D( p )*CS
00475                                              D( q ) = D( q ) / CS
00476                                              IF( RSVEC ) THEN
00477                                                 CALL DAXPY( MVL,
00478      +                                               -T*AQOAP,
00479      +                                               V( 1, q ), 1,
00480      +                                               V( 1, p ), 1 )
00481                                                 CALL DAXPY( MVL,
00482      +                                               CS*SN*APOAQ,
00483      +                                               V( 1, p ), 1,
00484      +                                               V( 1, q ), 1 )
00485                                              END IF
00486                                           ELSE
00487                                              CALL DAXPY( M, T*APOAQ,
00488      +                                                   A( 1, p ), 1,
00489      +                                                   A( 1, q ), 1 )
00490                                              CALL DAXPY( M,
00491      +                                                   -CS*SN*AQOAP,
00492      +                                                   A( 1, q ), 1,
00493      +                                                   A( 1, p ), 1 )
00494                                              D( p ) = D( p ) / CS
00495                                              D( q ) = D( q )*CS
00496                                              IF( RSVEC ) THEN
00497                                                 CALL DAXPY( MVL,
00498      +                                               T*APOAQ, V( 1, p ),
00499      +                                               1, V( 1, q ), 1 )
00500                                                 CALL DAXPY( MVL,
00501      +                                               -CS*SN*AQOAP,
00502      +                                               V( 1, q ), 1,
00503      +                                               V( 1, p ), 1 )
00504                                              END IF
00505                                           END IF
00506                                        END IF
00507                                     END IF
00508                                  END IF
00509 *
00510                               ELSE
00511 *              .. have to use modified Gram-Schmidt like transformation
00512                                  CALL DCOPY( M, A( 1, p ), 1, WORK, 1 )
00513                                  CALL DLASCL( 'G', 0, 0, AAPP, ONE, M,
00514      +                                        1, WORK, LDA, IERR )
00515                                  CALL DLASCL( 'G', 0, 0, AAQQ, ONE, M,
00516      +                                        1, A( 1, q ), LDA, IERR )
00517                                  TEMP1 = -AAPQ*D( p ) / D( q )
00518                                  CALL DAXPY( M, TEMP1, WORK, 1,
00519      +                                       A( 1, q ), 1 )
00520                                  CALL DLASCL( 'G', 0, 0, ONE, AAQQ, M,
00521      +                                        1, A( 1, q ), LDA, IERR )
00522                                  SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
00523      +                                      ONE-AAPQ*AAPQ ) )
00524                                  MXSINJ = DMAX1( MXSINJ, SFMIN )
00525                               END IF
00526 *           END IF ROTOK THEN ... ELSE
00527 *
00528 *           In the case of cancellation in updating SVA(q), SVA(p)
00529 *           recompute SVA(q), SVA(p).
00530                               IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS )
00531      +                            THEN
00532                                  IF( ( AAQQ.LT.ROOTBIG ) .AND.
00533      +                               ( AAQQ.GT.ROOTSFMIN ) ) THEN
00534                                     SVA( q ) = DNRM2( M, A( 1, q ), 1 )*
00535      +                                         D( q )
00536                                  ELSE
00537                                     T = ZERO
00538                                     AAQQ = ZERO
00539                                     CALL DLASSQ( M, A( 1, q ), 1, T,
00540      +                                           AAQQ )
00541                                     SVA( q ) = T*DSQRT( AAQQ )*D( q )
00542                                  END IF
00543                               END IF
00544                               IF( ( AAPP / AAPP0 ).LE.ROOTEPS ) THEN
00545                                  IF( ( AAPP.LT.ROOTBIG ) .AND.
00546      +                               ( AAPP.GT.ROOTSFMIN ) ) THEN
00547                                     AAPP = DNRM2( M, A( 1, p ), 1 )*
00548      +                                     D( p )
00549                                  ELSE
00550                                     T = ZERO
00551                                     AAPP = ZERO
00552                                     CALL DLASSQ( M, A( 1, p ), 1, T,
00553      +                                           AAPP )
00554                                     AAPP = T*DSQRT( AAPP )*D( p )
00555                                  END IF
00556                                  SVA( p ) = AAPP
00557                               END IF
00558 *
00559                            ELSE
00560 *        A(:,p) and A(:,q) already numerically orthogonal
00561                               IF( ir1.EQ.0 )NOTROT = NOTROT + 1
00562                               PSKIPPED = PSKIPPED + 1
00563                            END IF
00564                         ELSE
00565 *        A(:,q) is zero column
00566                            IF( ir1.EQ.0 )NOTROT = NOTROT + 1
00567                            PSKIPPED = PSKIPPED + 1
00568                         END IF
00569 *
00570                         IF( ( i.LE.SWBAND ) .AND.
00571      +                      ( PSKIPPED.GT.ROWSKIP ) ) THEN
00572                            IF( ir1.EQ.0 )AAPP = -AAPP
00573                            NOTROT = 0
00574                            GO TO 2103
00575                         END IF
00576 *
00577  2002                CONTINUE
00578 *     END q-LOOP
00579 *
00580  2103                CONTINUE
00581 *     bailed out of q-loop
00582 
00583                      SVA( p ) = AAPP
00584 
00585                   ELSE
00586                      SVA( p ) = AAPP
00587                      IF( ( ir1.EQ.0 ) .AND. ( AAPP.EQ.ZERO ) )
00588      +                   NOTROT = NOTROT + MIN0( igl+KBL-1, N ) - p
00589                   END IF
00590 *
00591  2001          CONTINUE
00592 *     end of the p-loop
00593 *     end of doing the block ( ibr, ibr )
00594  1002       CONTINUE
00595 *     end of ir1-loop
00596 *
00597 *........................................................
00598 * ... go to the off diagonal blocks
00599 *
00600             igl = ( ibr-1 )*KBL + 1
00601 *
00602             DO 2010 jbc = ibr + 1, NBL
00603 *
00604                jgl = ( jbc-1 )*KBL + 1
00605 *
00606 *        doing the block at ( ibr, jbc )
00607 *
00608                IJBLSK = 0
00609                DO 2100 p = igl, MIN0( igl+KBL-1, N )
00610 *
00611                   AAPP = SVA( p )
00612 *
00613                   IF( AAPP.GT.ZERO ) THEN
00614 *
00615                      PSKIPPED = 0
00616 *
00617                      DO 2200 q = jgl, MIN0( jgl+KBL-1, N )
00618 *
00619                         AAQQ = SVA( q )
00620 *
00621                         IF( AAQQ.GT.ZERO ) THEN
00622                            AAPP0 = AAPP
00623 *
00624 *     -#- M x 2 Jacobi SVD -#-
00625 *
00626 *        -#- Safe Gram matrix computation -#-
00627 *
00628                            IF( AAQQ.GE.ONE ) THEN
00629                               IF( AAPP.GE.AAQQ ) THEN
00630                                  ROTOK = ( SMALL*AAPP ).LE.AAQQ
00631                               ELSE
00632                                  ROTOK = ( SMALL*AAQQ ).LE.AAPP
00633                               END IF
00634                               IF( AAPP.LT.( BIG / AAQQ ) ) THEN
00635                                  AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1,
00636      +                                  q ), 1 )*D( p )*D( q ) / AAQQ )
00637      +                                  / AAPP
00638                               ELSE
00639                                  CALL DCOPY( M, A( 1, p ), 1, WORK, 1 )
00640                                  CALL DLASCL( 'G', 0, 0, AAPP, D( p ),
00641      +                                        M, 1, WORK, LDA, IERR )
00642                                  AAPQ = DDOT( M, WORK, 1, A( 1, q ),
00643      +                                  1 )*D( q ) / AAQQ
00644                               END IF
00645                            ELSE
00646                               IF( AAPP.GE.AAQQ ) THEN
00647                                  ROTOK = AAPP.LE.( AAQQ / SMALL )
00648                               ELSE
00649                                  ROTOK = AAQQ.LE.( AAPP / SMALL )
00650                               END IF
00651                               IF( AAPP.GT.( SMALL / AAQQ ) ) THEN
00652                                  AAPQ = ( DDOT( M, A( 1, p ), 1, A( 1,
00653      +                                  q ), 1 )*D( p )*D( q ) / AAQQ )
00654      +                                  / AAPP
00655                               ELSE
00656                                  CALL DCOPY( M, A( 1, q ), 1, WORK, 1 )
00657                                  CALL DLASCL( 'G', 0, 0, AAQQ, D( q ),
00658      +                                        M, 1, WORK, LDA, IERR )
00659                                  AAPQ = DDOT( M, WORK, 1, A( 1, p ),
00660      +                                  1 )*D( p ) / AAPP
00661                               END IF
00662                            END IF
00663 *
00664                            MXAAPQ = DMAX1( MXAAPQ, DABS( AAPQ ) )
00665 *
00666 *        TO rotate or NOT to rotate, THAT is the question ...
00667 *
00668                            IF( DABS( AAPQ ).GT.TOL ) THEN
00669                               NOTROT = 0
00670 *           ROTATED  = ROTATED + 1
00671                               PSKIPPED = 0
00672                               ISWROT = ISWROT + 1
00673 *
00674                               IF( ROTOK ) THEN
00675 *
00676                                  AQOAP = AAQQ / AAPP
00677                                  APOAQ = AAPP / AAQQ
00678                                  THETA = -HALF*DABS( AQOAP-APOAQ ) /
00679      +                                   AAPQ
00680                                  IF( AAQQ.GT.AAPP0 )THETA = -THETA
00681 *
00682                                  IF( DABS( THETA ).GT.BIGTHETA ) THEN
00683                                     T = HALF / THETA
00684                                     FASTR( 3 ) = T*D( p ) / D( q )
00685                                     FASTR( 4 ) = -T*D( q ) / D( p )
00686                                     CALL DROTM( M, A( 1, p ), 1,
00687      +                                          A( 1, q ), 1, FASTR )
00688                                     IF( RSVEC )CALL DROTM( MVL,
00689      +                                              V( 1, p ), 1,
00690      +                                              V( 1, q ), 1,
00691      +                                              FASTR )
00692                                     SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
00693      +                                         ONE+T*APOAQ*AAPQ ) )
00694                                     AAPP = AAPP*DSQRT( DMAX1( ZERO,
00695      +                                     ONE-T*AQOAP*AAPQ ) )
00696                                     MXSINJ = DMAX1( MXSINJ, DABS( T ) )
00697                                  ELSE
00698 *
00699 *                 .. choose correct signum for THETA and rotate
00700 *
00701                                     THSIGN = -DSIGN( ONE, AAPQ )
00702                                     IF( AAQQ.GT.AAPP0 )THSIGN = -THSIGN
00703                                     T = ONE / ( THETA+THSIGN*
00704      +                                  DSQRT( ONE+THETA*THETA ) )
00705                                     CS = DSQRT( ONE / ( ONE+T*T ) )
00706                                     SN = T*CS
00707                                     MXSINJ = DMAX1( MXSINJ, DABS( SN ) )
00708                                     SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
00709      +                                         ONE+T*APOAQ*AAPQ ) )
00710                                     AAPP = AAPP*DSQRT( ONE-T*AQOAP*
00711      +                                     AAPQ )
00712 *
00713                                     APOAQ = D( p ) / D( q )
00714                                     AQOAP = D( q ) / D( p )
00715                                     IF( D( p ).GE.ONE ) THEN
00716 *
00717                                        IF( D( q ).GE.ONE ) THEN
00718                                           FASTR( 3 ) = T*APOAQ
00719                                           FASTR( 4 ) = -T*AQOAP
00720                                           D( p ) = D( p )*CS
00721                                           D( q ) = D( q )*CS
00722                                           CALL DROTM( M, A( 1, p ), 1,
00723      +                                                A( 1, q ), 1,
00724      +                                                FASTR )
00725                                           IF( RSVEC )CALL DROTM( MVL,
00726      +                                        V( 1, p ), 1, V( 1, q ),
00727      +                                        1, FASTR )
00728                                        ELSE
00729                                           CALL DAXPY( M, -T*AQOAP,
00730      +                                                A( 1, q ), 1,
00731      +                                                A( 1, p ), 1 )
00732                                           CALL DAXPY( M, CS*SN*APOAQ,
00733      +                                                A( 1, p ), 1,
00734      +                                                A( 1, q ), 1 )
00735                                           IF( RSVEC ) THEN
00736                                              CALL DAXPY( MVL, -T*AQOAP,
00737      +                                                   V( 1, q ), 1,
00738      +                                                   V( 1, p ), 1 )
00739                                              CALL DAXPY( MVL,
00740      +                                                   CS*SN*APOAQ,
00741      +                                                   V( 1, p ), 1,
00742      +                                                   V( 1, q ), 1 )
00743                                           END IF
00744                                           D( p ) = D( p )*CS
00745                                           D( q ) = D( q ) / CS
00746                                        END IF
00747                                     ELSE
00748                                        IF( D( q ).GE.ONE ) THEN
00749                                           CALL DAXPY( M, T*APOAQ,
00750      +                                                A( 1, p ), 1,
00751      +                                                A( 1, q ), 1 )
00752                                           CALL DAXPY( M, -CS*SN*AQOAP,
00753      +                                                A( 1, q ), 1,
00754      +                                                A( 1, p ), 1 )
00755                                           IF( RSVEC ) THEN
00756                                              CALL DAXPY( MVL, T*APOAQ,
00757      +                                                   V( 1, p ), 1,
00758      +                                                   V( 1, q ), 1 )
00759                                              CALL DAXPY( MVL,
00760      +                                                   -CS*SN*AQOAP,
00761      +                                                   V( 1, q ), 1,
00762      +                                                   V( 1, p ), 1 )
00763                                           END IF
00764                                           D( p ) = D( p ) / CS
00765                                           D( q ) = D( q )*CS
00766                                        ELSE
00767                                           IF( D( p ).GE.D( q ) ) THEN
00768                                              CALL DAXPY( M, -T*AQOAP,
00769      +                                                   A( 1, q ), 1,
00770      +                                                   A( 1, p ), 1 )
00771                                              CALL DAXPY( M, CS*SN*APOAQ,
00772      +                                                   A( 1, p ), 1,
00773      +                                                   A( 1, q ), 1 )
00774                                              D( p ) = D( p )*CS
00775                                              D( q ) = D( q ) / CS
00776                                              IF( RSVEC ) THEN
00777                                                 CALL DAXPY( MVL,
00778      +                                               -T*AQOAP,
00779      +                                               V( 1, q ), 1,
00780      +                                               V( 1, p ), 1 )
00781                                                 CALL DAXPY( MVL,
00782      +                                               CS*SN*APOAQ,
00783      +                                               V( 1, p ), 1,
00784      +                                               V( 1, q ), 1 )
00785                                              END IF
00786                                           ELSE
00787                                              CALL DAXPY( M, T*APOAQ,
00788      +                                                   A( 1, p ), 1,
00789      +                                                   A( 1, q ), 1 )
00790                                              CALL DAXPY( M,
00791      +                                                   -CS*SN*AQOAP,
00792      +                                                   A( 1, q ), 1,
00793      +                                                   A( 1, p ), 1 )
00794                                              D( p ) = D( p ) / CS
00795                                              D( q ) = D( q )*CS
00796                                              IF( RSVEC ) THEN
00797                                                 CALL DAXPY( MVL,
00798      +                                               T*APOAQ, V( 1, p ),
00799      +                                               1, V( 1, q ), 1 )
00800                                                 CALL DAXPY( MVL,
00801      +                                               -CS*SN*AQOAP,
00802      +                                               V( 1, q ), 1,
00803      +                                               V( 1, p ), 1 )
00804                                              END IF
00805                                           END IF
00806                                        END IF
00807                                     END IF
00808                                  END IF
00809 *
00810                               ELSE
00811                                  IF( AAPP.GT.AAQQ ) THEN
00812                                     CALL DCOPY( M, A( 1, p ), 1, WORK,
00813      +                                          1 )
00814                                     CALL DLASCL( 'G', 0, 0, AAPP, ONE,
00815      +                                           M, 1, WORK, LDA, IERR )
00816                                     CALL DLASCL( 'G', 0, 0, AAQQ, ONE,
00817      +                                           M, 1, A( 1, q ), LDA,
00818      +                                           IERR )
00819                                     TEMP1 = -AAPQ*D( p ) / D( q )
00820                                     CALL DAXPY( M, TEMP1, WORK, 1,
00821      +                                          A( 1, q ), 1 )
00822                                     CALL DLASCL( 'G', 0, 0, ONE, AAQQ,
00823      +                                           M, 1, A( 1, q ), LDA,
00824      +                                           IERR )
00825                                     SVA( q ) = AAQQ*DSQRT( DMAX1( ZERO,
00826      +                                         ONE-AAPQ*AAPQ ) )
00827                                     MXSINJ = DMAX1( MXSINJ, SFMIN )
00828                                  ELSE
00829                                     CALL DCOPY( M, A( 1, q ), 1, WORK,
00830      +                                          1 )
00831                                     CALL DLASCL( 'G', 0, 0, AAQQ, ONE,
00832      +                                           M, 1, WORK, LDA, IERR )
00833                                     CALL DLASCL( 'G', 0, 0, AAPP, ONE,
00834      +                                           M, 1, A( 1, p ), LDA,
00835      +                                           IERR )
00836                                     TEMP1 = -AAPQ*D( q ) / D( p )
00837                                     CALL DAXPY( M, TEMP1, WORK, 1,
00838      +                                          A( 1, p ), 1 )
00839                                     CALL DLASCL( 'G', 0, 0, ONE, AAPP,
00840      +                                           M, 1, A( 1, p ), LDA,
00841      +                                           IERR )
00842                                     SVA( p ) = AAPP*DSQRT( DMAX1( ZERO,
00843      +                                         ONE-AAPQ*AAPQ ) )
00844                                     MXSINJ = DMAX1( MXSINJ, SFMIN )
00845                                  END IF
00846                               END IF
00847 *           END IF ROTOK THEN ... ELSE
00848 *
00849 *           In the case of cancellation in updating SVA(q)
00850 *           .. recompute SVA(q)
00851                               IF( ( SVA( q ) / AAQQ )**2.LE.ROOTEPS )
00852      +                            THEN
00853                                  IF( ( AAQQ.LT.ROOTBIG ) .AND.
00854      +                               ( AAQQ.GT.ROOTSFMIN ) ) THEN
00855                                     SVA( q ) = DNRM2( M, A( 1, q ), 1 )*
00856      +                                         D( q )
00857                                  ELSE
00858                                     T = ZERO
00859                                     AAQQ = ZERO
00860                                     CALL DLASSQ( M, A( 1, q ), 1, T,
00861      +                                           AAQQ )
00862                                     SVA( q ) = T*DSQRT( AAQQ )*D( q )
00863                                  END IF
00864                               END IF
00865                               IF( ( AAPP / AAPP0 )**2.LE.ROOTEPS ) THEN
00866                                  IF( ( AAPP.LT.ROOTBIG ) .AND.
00867      +                               ( AAPP.GT.ROOTSFMIN ) ) THEN
00868                                     AAPP = DNRM2( M, A( 1, p ), 1 )*
00869      +                                     D( p )
00870                                  ELSE
00871                                     T = ZERO
00872                                     AAPP = ZERO
00873                                     CALL DLASSQ( M, A( 1, p ), 1, T,
00874      +                                           AAPP )
00875                                     AAPP = T*DSQRT( AAPP )*D( p )
00876                                  END IF
00877                                  SVA( p ) = AAPP
00878                               END IF
00879 *              end of OK rotation
00880                            ELSE
00881                               NOTROT = NOTROT + 1
00882                               PSKIPPED = PSKIPPED + 1
00883                               IJBLSK = IJBLSK + 1
00884                            END IF
00885                         ELSE
00886                            NOTROT = NOTROT + 1
00887                            PSKIPPED = PSKIPPED + 1
00888                            IJBLSK = IJBLSK + 1
00889                         END IF
00890 *
00891                         IF( ( i.LE.SWBAND ) .AND. ( IJBLSK.GE.BLSKIP ) )
00892      +                      THEN
00893                            SVA( p ) = AAPP
00894                            NOTROT = 0
00895                            GO TO 2011
00896                         END IF
00897                         IF( ( i.LE.SWBAND ) .AND.
00898      +                      ( PSKIPPED.GT.ROWSKIP ) ) THEN
00899                            AAPP = -AAPP
00900                            NOTROT = 0
00901                            GO TO 2203
00902                         END IF
00903 *
00904  2200                CONTINUE
00905 *        end of the q-loop
00906  2203                CONTINUE
00907 *
00908                      SVA( p ) = AAPP
00909 *
00910                   ELSE
00911                      IF( AAPP.EQ.ZERO )NOTROT = NOTROT +
00912      +                   MIN0( jgl+KBL-1, N ) - jgl + 1
00913                      IF( AAPP.LT.ZERO )NOTROT = 0
00914                   END IF
00915 
00916  2100          CONTINUE
00917 *     end of the p-loop
00918  2010       CONTINUE
00919 *     end of the jbc-loop
00920  2011       CONTINUE
00921 *2011 bailed out of the jbc-loop
00922             DO 2012 p = igl, MIN0( igl+KBL-1, N )
00923                SVA( p ) = DABS( SVA( p ) )
00924  2012       CONTINUE
00925 *
00926  2000    CONTINUE
00927 *2000 :: end of the ibr-loop
00928 *
00929 *     .. update SVA(N)
00930          IF( ( SVA( N ).LT.ROOTBIG ) .AND. ( SVA( N ).GT.ROOTSFMIN ) )
00931      +       THEN
00932             SVA( N ) = DNRM2( M, A( 1, N ), 1 )*D( N )
00933          ELSE
00934             T = ZERO
00935             AAPP = ZERO
00936             CALL DLASSQ( M, A( 1, N ), 1, T, AAPP )
00937             SVA( N ) = T*DSQRT( AAPP )*D( N )
00938          END IF
00939 *
00940 *     Additional steering devices
00941 *
00942          IF( ( i.LT.SWBAND ) .AND. ( ( MXAAPQ.LE.ROOTTOL ) .OR.
00943      +       ( ISWROT.LE.N ) ) )SWBAND = i
00944 *
00945          IF( ( i.GT.SWBAND+1 ) .AND. ( MXAAPQ.LT.DBLE( N )*TOL ) .AND.
00946      +       ( DBLE( N )*MXAAPQ*MXSINJ.LT.TOL ) ) THEN
00947             GO TO 1994
00948          END IF
00949 *
00950          IF( NOTROT.GE.EMPTSW )GO TO 1994
00951 
00952  1993 CONTINUE
00953 *     end i=1:NSWEEP loop
00954 * #:) Reaching this point means that the procedure has comleted the given
00955 *     number of iterations.
00956       INFO = NSWEEP - 1
00957       GO TO 1995
00958  1994 CONTINUE
00959 * #:) Reaching this point means that during the i-th sweep all pivots were
00960 *     below the given tolerance, causing early exit.
00961 *
00962       INFO = 0
00963 * #:) INFO = 0 confirms successful iterations.
00964  1995 CONTINUE
00965 *
00966 *     Sort the vector D.
00967       DO 5991 p = 1, N - 1
00968          q = IDAMAX( N-p+1, SVA( p ), 1 ) + p - 1
00969          IF( p.NE.q ) THEN
00970             TEMP1 = SVA( p )
00971             SVA( p ) = SVA( q )
00972             SVA( q ) = TEMP1
00973             TEMP1 = D( p )
00974             D( p ) = D( q )
00975             D( q ) = TEMP1
00976             CALL DSWAP( M, A( 1, p ), 1, A( 1, q ), 1 )
00977             IF( RSVEC )CALL DSWAP( MVL, V( 1, p ), 1, V( 1, q ), 1 )
00978          END IF
00979  5991 CONTINUE
00980 *
00981       RETURN
00982 *     ..
00983 *     .. END OF DGSVJ0
00984 *     ..
00985       END