LAPACK  3.4.1
LAPACK: Linear Algebra PACKage
zlals0.f
Go to the documentation of this file.
00001 *> \brief \b ZLALS0
00002 *
00003 *  =========== DOCUMENTATION ===========
00004 *
00005 * Online html documentation available at 
00006 *            http://www.netlib.org/lapack/explore-html/ 
00007 *
00008 *> \htmlonly
00009 *> Download ZLALS0 + dependencies 
00010 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/zlals0.f"> 
00011 *> [TGZ]</a> 
00012 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/zlals0.f"> 
00013 *> [ZIP]</a> 
00014 *> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/zlals0.f"> 
00015 *> [TXT]</a>
00016 *> \endhtmlonly 
00017 *
00018 *  Definition:
00019 *  ===========
00020 *
00021 *       SUBROUTINE ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX,
00022 *                          PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
00023 *                          POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO )
00024 * 
00025 *       .. Scalar Arguments ..
00026 *       INTEGER            GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
00027 *      $                   LDGNUM, NL, NR, NRHS, SQRE
00028 *       DOUBLE PRECISION   C, S
00029 *       ..
00030 *       .. Array Arguments ..
00031 *       INTEGER            GIVCOL( LDGCOL, * ), PERM( * )
00032 *       DOUBLE PRECISION   DIFL( * ), DIFR( LDGNUM, * ),
00033 *      $                   GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ),
00034 *      $                   RWORK( * ), Z( * )
00035 *       COMPLEX*16         B( LDB, * ), BX( LDBX, * )
00036 *       ..
00037 *  
00038 *
00039 *> \par Purpose:
00040 *  =============
00041 *>
00042 *> \verbatim
00043 *>
00044 *> ZLALS0 applies back the multiplying factors of either the left or the
00045 *> right singular vector matrix of a diagonal matrix appended by a row
00046 *> to the right hand side matrix B in solving the least squares problem
00047 *> using the divide-and-conquer SVD approach.
00048 *>
00049 *> For the left singular vector matrix, three types of orthogonal
00050 *> matrices are involved:
00051 *>
00052 *> (1L) Givens rotations: the number of such rotations is GIVPTR; the
00053 *>      pairs of columns/rows they were applied to are stored in GIVCOL;
00054 *>      and the C- and S-values of these rotations are stored in GIVNUM.
00055 *>
00056 *> (2L) Permutation. The (NL+1)-st row of B is to be moved to the first
00057 *>      row, and for J=2:N, PERM(J)-th row of B is to be moved to the
00058 *>      J-th row.
00059 *>
00060 *> (3L) The left singular vector matrix of the remaining matrix.
00061 *>
00062 *> For the right singular vector matrix, four types of orthogonal
00063 *> matrices are involved:
00064 *>
00065 *> (1R) The right singular vector matrix of the remaining matrix.
00066 *>
00067 *> (2R) If SQRE = 1, one extra Givens rotation to generate the right
00068 *>      null space.
00069 *>
00070 *> (3R) The inverse transformation of (2L).
00071 *>
00072 *> (4R) The inverse transformation of (1L).
00073 *> \endverbatim
00074 *
00075 *  Arguments:
00076 *  ==========
00077 *
00078 *> \param[in] ICOMPQ
00079 *> \verbatim
00080 *>          ICOMPQ is INTEGER
00081 *>         Specifies whether singular vectors are to be computed in
00082 *>         factored form:
00083 *>         = 0: Left singular vector matrix.
00084 *>         = 1: Right singular vector matrix.
00085 *> \endverbatim
00086 *>
00087 *> \param[in] NL
00088 *> \verbatim
00089 *>          NL is INTEGER
00090 *>         The row dimension of the upper block. NL >= 1.
00091 *> \endverbatim
00092 *>
00093 *> \param[in] NR
00094 *> \verbatim
00095 *>          NR is INTEGER
00096 *>         The row dimension of the lower block. NR >= 1.
00097 *> \endverbatim
00098 *>
00099 *> \param[in] SQRE
00100 *> \verbatim
00101 *>          SQRE is INTEGER
00102 *>         = 0: the lower block is an NR-by-NR square matrix.
00103 *>         = 1: the lower block is an NR-by-(NR+1) rectangular matrix.
00104 *>
00105 *>         The bidiagonal matrix has row dimension N = NL + NR + 1,
00106 *>         and column dimension M = N + SQRE.
00107 *> \endverbatim
00108 *>
00109 *> \param[in] NRHS
00110 *> \verbatim
00111 *>          NRHS is INTEGER
00112 *>         The number of columns of B and BX. NRHS must be at least 1.
00113 *> \endverbatim
00114 *>
00115 *> \param[in,out] B
00116 *> \verbatim
00117 *>          B is COMPLEX*16 array, dimension ( LDB, NRHS )
00118 *>         On input, B contains the right hand sides of the least
00119 *>         squares problem in rows 1 through M. On output, B contains
00120 *>         the solution X in rows 1 through N.
00121 *> \endverbatim
00122 *>
00123 *> \param[in] LDB
00124 *> \verbatim
00125 *>          LDB is INTEGER
00126 *>         The leading dimension of B. LDB must be at least
00127 *>         max(1,MAX( M, N ) ).
00128 *> \endverbatim
00129 *>
00130 *> \param[out] BX
00131 *> \verbatim
00132 *>          BX is COMPLEX*16 array, dimension ( LDBX, NRHS )
00133 *> \endverbatim
00134 *>
00135 *> \param[in] LDBX
00136 *> \verbatim
00137 *>          LDBX is INTEGER
00138 *>         The leading dimension of BX.
00139 *> \endverbatim
00140 *>
00141 *> \param[in] PERM
00142 *> \verbatim
00143 *>          PERM is INTEGER array, dimension ( N )
00144 *>         The permutations (from deflation and sorting) applied
00145 *>         to the two blocks.
00146 *> \endverbatim
00147 *>
00148 *> \param[in] GIVPTR
00149 *> \verbatim
00150 *>          GIVPTR is INTEGER
00151 *>         The number of Givens rotations which took place in this
00152 *>         subproblem.
00153 *> \endverbatim
00154 *>
00155 *> \param[in] GIVCOL
00156 *> \verbatim
00157 *>          GIVCOL is INTEGER array, dimension ( LDGCOL, 2 )
00158 *>         Each pair of numbers indicates a pair of rows/columns
00159 *>         involved in a Givens rotation.
00160 *> \endverbatim
00161 *>
00162 *> \param[in] LDGCOL
00163 *> \verbatim
00164 *>          LDGCOL is INTEGER
00165 *>         The leading dimension of GIVCOL, must be at least N.
00166 *> \endverbatim
00167 *>
00168 *> \param[in] GIVNUM
00169 *> \verbatim
00170 *>          GIVNUM is DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
00171 *>         Each number indicates the C or S value used in the
00172 *>         corresponding Givens rotation.
00173 *> \endverbatim
00174 *>
00175 *> \param[in] LDGNUM
00176 *> \verbatim
00177 *>          LDGNUM is INTEGER
00178 *>         The leading dimension of arrays DIFR, POLES and
00179 *>         GIVNUM, must be at least K.
00180 *> \endverbatim
00181 *>
00182 *> \param[in] POLES
00183 *> \verbatim
00184 *>          POLES is DOUBLE PRECISION array, dimension ( LDGNUM, 2 )
00185 *>         On entry, POLES(1:K, 1) contains the new singular
00186 *>         values obtained from solving the secular equation, and
00187 *>         POLES(1:K, 2) is an array containing the poles in the secular
00188 *>         equation.
00189 *> \endverbatim
00190 *>
00191 *> \param[in] DIFL
00192 *> \verbatim
00193 *>          DIFL is DOUBLE PRECISION array, dimension ( K ).
00194 *>         On entry, DIFL(I) is the distance between I-th updated
00195 *>         (undeflated) singular value and the I-th (undeflated) old
00196 *>         singular value.
00197 *> \endverbatim
00198 *>
00199 *> \param[in] DIFR
00200 *> \verbatim
00201 *>          DIFR is DOUBLE PRECISION array, dimension ( LDGNUM, 2 ).
00202 *>         On entry, DIFR(I, 1) contains the distances between I-th
00203 *>         updated (undeflated) singular value and the I+1-th
00204 *>         (undeflated) old singular value. And DIFR(I, 2) is the
00205 *>         normalizing factor for the I-th right singular vector.
00206 *> \endverbatim
00207 *>
00208 *> \param[in] Z
00209 *> \verbatim
00210 *>          Z is DOUBLE PRECISION array, dimension ( K )
00211 *>         Contain the components of the deflation-adjusted updating row
00212 *>         vector.
00213 *> \endverbatim
00214 *>
00215 *> \param[in] K
00216 *> \verbatim
00217 *>          K is INTEGER
00218 *>         Contains the dimension of the non-deflated matrix,
00219 *>         This is the order of the related secular equation. 1 <= K <=N.
00220 *> \endverbatim
00221 *>
00222 *> \param[in] C
00223 *> \verbatim
00224 *>          C is DOUBLE PRECISION
00225 *>         C contains garbage if SQRE =0 and the C-value of a Givens
00226 *>         rotation related to the right null space if SQRE = 1.
00227 *> \endverbatim
00228 *>
00229 *> \param[in] S
00230 *> \verbatim
00231 *>          S is DOUBLE PRECISION
00232 *>         S contains garbage if SQRE =0 and the S-value of a Givens
00233 *>         rotation related to the right null space if SQRE = 1.
00234 *> \endverbatim
00235 *>
00236 *> \param[out] RWORK
00237 *> \verbatim
00238 *>          RWORK is DOUBLE PRECISION array, dimension
00239 *>         ( K*(1+NRHS) + 2*NRHS )
00240 *> \endverbatim
00241 *>
00242 *> \param[out] INFO
00243 *> \verbatim
00244 *>          INFO is INTEGER
00245 *>          = 0:  successful exit.
00246 *>          < 0:  if INFO = -i, the i-th argument had an illegal value.
00247 *> \endverbatim
00248 *
00249 *  Authors:
00250 *  ========
00251 *
00252 *> \author Univ. of Tennessee 
00253 *> \author Univ. of California Berkeley 
00254 *> \author Univ. of Colorado Denver 
00255 *> \author NAG Ltd. 
00256 *
00257 *> \date November 2011
00258 *
00259 *> \ingroup complex16OTHERcomputational
00260 *
00261 *> \par Contributors:
00262 *  ==================
00263 *>
00264 *>     Ming Gu and Ren-Cang Li, Computer Science Division, University of
00265 *>       California at Berkeley, USA \n
00266 *>     Osni Marques, LBNL/NERSC, USA \n
00267 *
00268 *  =====================================================================
00269       SUBROUTINE ZLALS0( ICOMPQ, NL, NR, SQRE, NRHS, B, LDB, BX, LDBX,
00270      $                   PERM, GIVPTR, GIVCOL, LDGCOL, GIVNUM, LDGNUM,
00271      $                   POLES, DIFL, DIFR, Z, K, C, S, RWORK, INFO )
00272 *
00273 *  -- LAPACK computational routine (version 3.4.0) --
00274 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00275 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00276 *     November 2011
00277 *
00278 *     .. Scalar Arguments ..
00279       INTEGER            GIVPTR, ICOMPQ, INFO, K, LDB, LDBX, LDGCOL,
00280      $                   LDGNUM, NL, NR, NRHS, SQRE
00281       DOUBLE PRECISION   C, S
00282 *     ..
00283 *     .. Array Arguments ..
00284       INTEGER            GIVCOL( LDGCOL, * ), PERM( * )
00285       DOUBLE PRECISION   DIFL( * ), DIFR( LDGNUM, * ),
00286      $                   GIVNUM( LDGNUM, * ), POLES( LDGNUM, * ),
00287      $                   RWORK( * ), Z( * )
00288       COMPLEX*16         B( LDB, * ), BX( LDBX, * )
00289 *     ..
00290 *
00291 *  =====================================================================
00292 *
00293 *     .. Parameters ..
00294       DOUBLE PRECISION   ONE, ZERO, NEGONE
00295       PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0, NEGONE = -1.0D0 )
00296 *     ..
00297 *     .. Local Scalars ..
00298       INTEGER            I, J, JCOL, JROW, M, N, NLP1
00299       DOUBLE PRECISION   DIFLJ, DIFRJ, DJ, DSIGJ, DSIGJP, TEMP
00300 *     ..
00301 *     .. External Subroutines ..
00302       EXTERNAL           DGEMV, XERBLA, ZCOPY, ZDROT, ZDSCAL, ZLACPY,
00303      $                   ZLASCL
00304 *     ..
00305 *     .. External Functions ..
00306       DOUBLE PRECISION   DLAMC3, DNRM2
00307       EXTERNAL           DLAMC3, DNRM2
00308 *     ..
00309 *     .. Intrinsic Functions ..
00310       INTRINSIC          DBLE, DCMPLX, DIMAG, MAX
00311 *     ..
00312 *     .. Executable Statements ..
00313 *
00314 *     Test the input parameters.
00315 *
00316       INFO = 0
00317 *
00318       IF( ( ICOMPQ.LT.0 ) .OR. ( ICOMPQ.GT.1 ) ) THEN
00319          INFO = -1
00320       ELSE IF( NL.LT.1 ) THEN
00321          INFO = -2
00322       ELSE IF( NR.LT.1 ) THEN
00323          INFO = -3
00324       ELSE IF( ( SQRE.LT.0 ) .OR. ( SQRE.GT.1 ) ) THEN
00325          INFO = -4
00326       END IF
00327 *
00328       N = NL + NR + 1
00329 *
00330       IF( NRHS.LT.1 ) THEN
00331          INFO = -5
00332       ELSE IF( LDB.LT.N ) THEN
00333          INFO = -7
00334       ELSE IF( LDBX.LT.N ) THEN
00335          INFO = -9
00336       ELSE IF( GIVPTR.LT.0 ) THEN
00337          INFO = -11
00338       ELSE IF( LDGCOL.LT.N ) THEN
00339          INFO = -13
00340       ELSE IF( LDGNUM.LT.N ) THEN
00341          INFO = -15
00342       ELSE IF( K.LT.1 ) THEN
00343          INFO = -20
00344       END IF
00345       IF( INFO.NE.0 ) THEN
00346          CALL XERBLA( 'ZLALS0', -INFO )
00347          RETURN
00348       END IF
00349 *
00350       M = N + SQRE
00351       NLP1 = NL + 1
00352 *
00353       IF( ICOMPQ.EQ.0 ) THEN
00354 *
00355 *        Apply back orthogonal transformations from the left.
00356 *
00357 *        Step (1L): apply back the Givens rotations performed.
00358 *
00359          DO 10 I = 1, GIVPTR
00360             CALL ZDROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
00361      $                  B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
00362      $                  GIVNUM( I, 1 ) )
00363    10    CONTINUE
00364 *
00365 *        Step (2L): permute rows of B.
00366 *
00367          CALL ZCOPY( NRHS, B( NLP1, 1 ), LDB, BX( 1, 1 ), LDBX )
00368          DO 20 I = 2, N
00369             CALL ZCOPY( NRHS, B( PERM( I ), 1 ), LDB, BX( I, 1 ), LDBX )
00370    20    CONTINUE
00371 *
00372 *        Step (3L): apply the inverse of the left singular vector
00373 *        matrix to BX.
00374 *
00375          IF( K.EQ.1 ) THEN
00376             CALL ZCOPY( NRHS, BX, LDBX, B, LDB )
00377             IF( Z( 1 ).LT.ZERO ) THEN
00378                CALL ZDSCAL( NRHS, NEGONE, B, LDB )
00379             END IF
00380          ELSE
00381             DO 100 J = 1, K
00382                DIFLJ = DIFL( J )
00383                DJ = POLES( J, 1 )
00384                DSIGJ = -POLES( J, 2 )
00385                IF( J.LT.K ) THEN
00386                   DIFRJ = -DIFR( J, 1 )
00387                   DSIGJP = -POLES( J+1, 2 )
00388                END IF
00389                IF( ( Z( J ).EQ.ZERO ) .OR. ( POLES( J, 2 ).EQ.ZERO ) )
00390      $              THEN
00391                   RWORK( J ) = ZERO
00392                ELSE
00393                   RWORK( J ) = -POLES( J, 2 )*Z( J ) / DIFLJ /
00394      $                         ( POLES( J, 2 )+DJ )
00395                END IF
00396                DO 30 I = 1, J - 1
00397                   IF( ( Z( I ).EQ.ZERO ) .OR.
00398      $                ( POLES( I, 2 ).EQ.ZERO ) ) THEN
00399                      RWORK( I ) = ZERO
00400                   ELSE
00401                      RWORK( I ) = POLES( I, 2 )*Z( I ) /
00402      $                            ( DLAMC3( POLES( I, 2 ), DSIGJ )-
00403      $                            DIFLJ ) / ( POLES( I, 2 )+DJ )
00404                   END IF
00405    30          CONTINUE
00406                DO 40 I = J + 1, K
00407                   IF( ( Z( I ).EQ.ZERO ) .OR.
00408      $                ( POLES( I, 2 ).EQ.ZERO ) ) THEN
00409                      RWORK( I ) = ZERO
00410                   ELSE
00411                      RWORK( I ) = POLES( I, 2 )*Z( I ) /
00412      $                            ( DLAMC3( POLES( I, 2 ), DSIGJP )+
00413      $                            DIFRJ ) / ( POLES( I, 2 )+DJ )
00414                   END IF
00415    40          CONTINUE
00416                RWORK( 1 ) = NEGONE
00417                TEMP = DNRM2( K, RWORK, 1 )
00418 *
00419 *              Since B and BX are complex, the following call to DGEMV
00420 *              is performed in two steps (real and imaginary parts).
00421 *
00422 *              CALL DGEMV( 'T', K, NRHS, ONE, BX, LDBX, WORK, 1, ZERO,
00423 *    $                     B( J, 1 ), LDB )
00424 *
00425                I = K + NRHS*2
00426                DO 60 JCOL = 1, NRHS
00427                   DO 50 JROW = 1, K
00428                      I = I + 1
00429                      RWORK( I ) = DBLE( BX( JROW, JCOL ) )
00430    50             CONTINUE
00431    60          CONTINUE
00432                CALL DGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K,
00433      $                     RWORK( 1 ), 1, ZERO, RWORK( 1+K ), 1 )
00434                I = K + NRHS*2
00435                DO 80 JCOL = 1, NRHS
00436                   DO 70 JROW = 1, K
00437                      I = I + 1
00438                      RWORK( I ) = DIMAG( BX( JROW, JCOL ) )
00439    70             CONTINUE
00440    80          CONTINUE
00441                CALL DGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K,
00442      $                     RWORK( 1 ), 1, ZERO, RWORK( 1+K+NRHS ), 1 )
00443                DO 90 JCOL = 1, NRHS
00444                   B( J, JCOL ) = DCMPLX( RWORK( JCOL+K ),
00445      $                           RWORK( JCOL+K+NRHS ) )
00446    90          CONTINUE
00447                CALL ZLASCL( 'G', 0, 0, TEMP, ONE, 1, NRHS, B( J, 1 ),
00448      $                      LDB, INFO )
00449   100       CONTINUE
00450          END IF
00451 *
00452 *        Move the deflated rows of BX to B also.
00453 *
00454          IF( K.LT.MAX( M, N ) )
00455      $      CALL ZLACPY( 'A', N-K, NRHS, BX( K+1, 1 ), LDBX,
00456      $                   B( K+1, 1 ), LDB )
00457       ELSE
00458 *
00459 *        Apply back the right orthogonal transformations.
00460 *
00461 *        Step (1R): apply back the new right singular vector matrix
00462 *        to B.
00463 *
00464          IF( K.EQ.1 ) THEN
00465             CALL ZCOPY( NRHS, B, LDB, BX, LDBX )
00466          ELSE
00467             DO 180 J = 1, K
00468                DSIGJ = POLES( J, 2 )
00469                IF( Z( J ).EQ.ZERO ) THEN
00470                   RWORK( J ) = ZERO
00471                ELSE
00472                   RWORK( J ) = -Z( J ) / DIFL( J ) /
00473      $                         ( DSIGJ+POLES( J, 1 ) ) / DIFR( J, 2 )
00474                END IF
00475                DO 110 I = 1, J - 1
00476                   IF( Z( J ).EQ.ZERO ) THEN
00477                      RWORK( I ) = ZERO
00478                   ELSE
00479                      RWORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I+1,
00480      $                            2 ) )-DIFR( I, 1 ) ) /
00481      $                            ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
00482                   END IF
00483   110          CONTINUE
00484                DO 120 I = J + 1, K
00485                   IF( Z( J ).EQ.ZERO ) THEN
00486                      RWORK( I ) = ZERO
00487                   ELSE
00488                      RWORK( I ) = Z( J ) / ( DLAMC3( DSIGJ, -POLES( I,
00489      $                            2 ) )-DIFL( I ) ) /
00490      $                            ( DSIGJ+POLES( I, 1 ) ) / DIFR( I, 2 )
00491                   END IF
00492   120          CONTINUE
00493 *
00494 *              Since B and BX are complex, the following call to DGEMV
00495 *              is performed in two steps (real and imaginary parts).
00496 *
00497 *              CALL DGEMV( 'T', K, NRHS, ONE, B, LDB, WORK, 1, ZERO,
00498 *    $                     BX( J, 1 ), LDBX )
00499 *
00500                I = K + NRHS*2
00501                DO 140 JCOL = 1, NRHS
00502                   DO 130 JROW = 1, K
00503                      I = I + 1
00504                      RWORK( I ) = DBLE( B( JROW, JCOL ) )
00505   130             CONTINUE
00506   140          CONTINUE
00507                CALL DGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K,
00508      $                     RWORK( 1 ), 1, ZERO, RWORK( 1+K ), 1 )
00509                I = K + NRHS*2
00510                DO 160 JCOL = 1, NRHS
00511                   DO 150 JROW = 1, K
00512                      I = I + 1
00513                      RWORK( I ) = DIMAG( B( JROW, JCOL ) )
00514   150             CONTINUE
00515   160          CONTINUE
00516                CALL DGEMV( 'T', K, NRHS, ONE, RWORK( 1+K+NRHS*2 ), K,
00517      $                     RWORK( 1 ), 1, ZERO, RWORK( 1+K+NRHS ), 1 )
00518                DO 170 JCOL = 1, NRHS
00519                   BX( J, JCOL ) = DCMPLX( RWORK( JCOL+K ),
00520      $                            RWORK( JCOL+K+NRHS ) )
00521   170          CONTINUE
00522   180       CONTINUE
00523          END IF
00524 *
00525 *        Step (2R): if SQRE = 1, apply back the rotation that is
00526 *        related to the right null space of the subproblem.
00527 *
00528          IF( SQRE.EQ.1 ) THEN
00529             CALL ZCOPY( NRHS, B( M, 1 ), LDB, BX( M, 1 ), LDBX )
00530             CALL ZDROT( NRHS, BX( 1, 1 ), LDBX, BX( M, 1 ), LDBX, C, S )
00531          END IF
00532          IF( K.LT.MAX( M, N ) )
00533      $      CALL ZLACPY( 'A', N-K, NRHS, B( K+1, 1 ), LDB, BX( K+1, 1 ),
00534      $                   LDBX )
00535 *
00536 *        Step (3R): permute rows of B.
00537 *
00538          CALL ZCOPY( NRHS, BX( 1, 1 ), LDBX, B( NLP1, 1 ), LDB )
00539          IF( SQRE.EQ.1 ) THEN
00540             CALL ZCOPY( NRHS, BX( M, 1 ), LDBX, B( M, 1 ), LDB )
00541          END IF
00542          DO 190 I = 2, N
00543             CALL ZCOPY( NRHS, BX( I, 1 ), LDBX, B( PERM( I ), 1 ), LDB )
00544   190    CONTINUE
00545 *
00546 *        Step (4R): apply back the Givens rotations performed.
00547 *
00548          DO 200 I = GIVPTR, 1, -1
00549             CALL ZDROT( NRHS, B( GIVCOL( I, 2 ), 1 ), LDB,
00550      $                  B( GIVCOL( I, 1 ), 1 ), LDB, GIVNUM( I, 2 ),
00551      $                  -GIVNUM( I, 1 ) )
00552   200    CONTINUE
00553       END IF
00554 *
00555       RETURN
00556 *
00557 *     End of ZLALS0
00558 *
00559       END
 All Files Functions