dlasr.f

Go to the documentation of this file.

      SUBROUTINE dlasr( SIDE, PIVOT, DIRECT, M, N, C, S, A, LDA )
*
*  -- LAPACK auxiliary routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     October 31, 1992
*
*     .. Scalar Arguments ..
      CHARACTER          DIRECT, PIVOT, SIDE
      INTEGER            LDA, M, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), C( * ), S( * )
*     ..
*
*  Purpose
*  =======
*
*  DLASR   performs the transformation
*
*     A := P*A,   when SIDE = 'L' or 'l'  (  Left-hand side )
*
*     A := A*P',  when SIDE = 'R' or 'r'  ( Right-hand side )
*
*  where A is an m by n real matrix and P is an orthogonal matrix,
*  consisting of a sequence of plane rotations determined by the
*  parameters PIVOT and DIRECT as follows ( z = m when SIDE = 'L' or 'l'
*  and z = n when SIDE = 'R' or 'r' ):
*
*  When  DIRECT = 'F' or 'f'  ( Forward sequence ) then
*
*     P = P( z - 1 )*...*P( 2 )*P( 1 ),
*
*  and when DIRECT = 'B' or 'b'  ( Backward sequence ) then
*
*     P = P( 1 )*P( 2 )*...*P( z - 1 ),
*
*  where  P( k ) is a plane rotation matrix for the following planes:
*
*     when  PIVOT = 'V' or 'v'  ( Variable pivot ),
*        the plane ( k, k + 1 )
*
*     when  PIVOT = 'T' or 't'  ( Top pivot ),
*        the plane ( 1, k + 1 )
*
*     when  PIVOT = 'B' or 'b'  ( Bottom pivot ),
*        the plane ( k, z )
*
*  c( k ) and s( k )  must contain the  cosine and sine that define the
*  matrix  P( k ).  The two by two plane rotation part of the matrix
*  P( k ), R( k ), is assumed to be of the form
*
*     R( k ) = (  c( k )  s( k ) ).
*              ( -s( k )  c( k ) )
*
*  This version vectorises across rows of the array A when SIDE = 'L'.
*
*  Arguments
*  =========
*
*  SIDE    (input) CHARACTER*1
*          Specifies whether the plane rotation matrix P is applied to
*          A on the left or the right.
*          = 'L':  Left, compute A := P*A
*          = 'R':  Right, compute A:= A*P'
*
*  DIRECT  (input) CHARACTER*1
*          Specifies whether P is a forward or backward sequence of
*          plane rotations.
*          = 'F':  Forward, P = P( z - 1 )*...*P( 2 )*P( 1 )
*          = 'B':  Backward, P = P( 1 )*P( 2 )*...*P( z - 1 )
*
*  PIVOT   (input) CHARACTER*1
*          Specifies the plane for which P(k) is a plane rotation
*          matrix.
*          = 'V':  Variable pivot, the plane (k,k+1)
*          = 'T':  Top pivot, the plane (1,k+1)
*          = 'B':  Bottom pivot, the plane (k,z)
*
*  M       (input) INTEGER
*          The number of rows of the matrix A.  If m <= 1, an immediate
*          return is effected.
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  If n <= 1, an
*          immediate return is effected.
*
*  C, S    (input) DOUBLE PRECISION arrays, dimension
*                  (M-1) if SIDE = 'L'
*                  (N-1) if SIDE = 'R'
*          c(k) and s(k) contain the cosine and sine that define the
*          matrix P(k).  The two by two plane rotation part of the
*          matrix P(k), R(k), is assumed to be of the form
*          R( k ) = (  c( k )  s( k ) ).
*                   ( -s( k )  c( k ) )
*
*  A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
*          The m by n matrix A.  On exit, A is overwritten by P*A if
*          SIDE = 'R' or by A*P' if SIDE = 'L'.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,M).
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      parameter( one = 1.0d+0, zero = 0.0d+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, INFO, J
      DOUBLE PRECISION   CTEMP, STEMP, TEMP
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           lsame
*     ..
*     .. External Subroutines ..
      EXTERNAL           xerbla
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          max
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters
*
      info = 0
      IF( .NOT.( lsame( side, 'L' ) .OR. lsame( side, 'R' ) ) ) THEN
         info = 1
      ELSE IF( .NOT.( lsame( pivot, 'V' ) .OR. lsame( pivot,
     $         'T' ) .OR. lsame( pivot, 'B' ) ) ) THEN
         info = 2
      ELSE IF( .NOT.( lsame( direct, 'F' ) .OR. lsame( direct, 'B' ) ) )
     $          THEN
         info = 3
      ELSE IF( m.LT.0 ) THEN
         info = 4
      ELSE IF( n.LT.0 ) THEN
         info = 5
      ELSE IF( lda.LT.max( 1, m ) ) THEN
         info = 9
      END IF
      IF( info.NE.0 ) THEN
         CALL xerbla( 'DLASR ', info )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( ( m.EQ.0 ) .OR. ( n.EQ.0 ) )
     $   RETURN
      IF( lsame( side, 'L' ) ) THEN
*
*        Form  P * A
*
         IF( lsame( pivot, 'V' ) ) THEN
            IF( lsame( direct, 'F' ) ) THEN
               DO 20 j = 1, m - 1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 10 i = 1, n
                        temp = a( j+1, i )
                        a( j+1, i ) = ctemp*temp - stemp*a( j, i )
                        a( j, i ) = stemp*temp + ctemp*a( j, i )
   10                CONTINUE
                  END IF
   20          CONTINUE
            ELSE IF( lsame( direct, 'B' ) ) THEN
               DO 40 j = m - 1, 1, -1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 30 i = 1, n
                        temp = a( j+1, i )
                        a( j+1, i ) = ctemp*temp - stemp*a( j, i )
                        a( j, i ) = stemp*temp + ctemp*a( j, i )
   30                CONTINUE
                  END IF
   40          CONTINUE
            END IF
         ELSE IF( lsame( pivot, 'T' ) ) THEN
            IF( lsame( direct, 'F' ) ) THEN
               DO 60 j = 2, m
                  ctemp = c( j-1 )
                  stemp = s( j-1 )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 50 i = 1, n
                        temp = a( j, i )
                        a( j, i ) = ctemp*temp - stemp*a( 1, i )
                        a( 1, i ) = stemp*temp + ctemp*a( 1, i )
   50                CONTINUE
                  END IF
   60          CONTINUE
            ELSE IF( lsame( direct, 'B' ) ) THEN
               DO 80 j = m, 2, -1
                  ctemp = c( j-1 )
                  stemp = s( j-1 )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 70 i = 1, n
                        temp = a( j, i )
                        a( j, i ) = ctemp*temp - stemp*a( 1, i )
                        a( 1, i ) = stemp*temp + ctemp*a( 1, i )
   70                CONTINUE
                  END IF
   80          CONTINUE
            END IF
         ELSE IF( lsame( pivot, 'B' ) ) THEN
            IF( lsame( direct, 'F' ) ) THEN
               DO 100 j = 1, m - 1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 90 i = 1, n
                        temp = a( j, i )
                        a( j, i ) = stemp*a( m, i ) + ctemp*temp
                        a( m, i ) = ctemp*a( m, i ) - stemp*temp
   90                CONTINUE
                  END IF
  100          CONTINUE
            ELSE IF( lsame( direct, 'B' ) ) THEN
               DO 120 j = m - 1, 1, -1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 110 i = 1, n
                        temp = a( j, i )
                        a( j, i ) = stemp*a( m, i ) + ctemp*temp
                        a( m, i ) = ctemp*a( m, i ) - stemp*temp
  110                CONTINUE
                  END IF
  120          CONTINUE
            END IF
         END IF
      ELSE IF( lsame( side, 'R' ) ) THEN
*
*        Form A * P'
*
         IF( lsame( pivot, 'V' ) ) THEN
            IF( lsame( direct, 'F' ) ) THEN
               DO 140 j = 1, n - 1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 130 i = 1, m
                        temp = a( i, j+1 )
                        a( i, j+1 ) = ctemp*temp - stemp*a( i, j )
                        a( i, j ) = stemp*temp + ctemp*a( i, j )
  130                CONTINUE
                  END IF
  140          CONTINUE
            ELSE IF( lsame( direct, 'B' ) ) THEN
               DO 160 j = n - 1, 1, -1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 150 i = 1, m
                        temp = a( i, j+1 )
                        a( i, j+1 ) = ctemp*temp - stemp*a( i, j )
                        a( i, j ) = stemp*temp + ctemp*a( i, j )
  150                CONTINUE
                  END IF
  160          CONTINUE
            END IF
         ELSE IF( lsame( pivot, 'T' ) ) THEN
            IF( lsame( direct, 'F' ) ) THEN
               DO 180 j = 2, n
                  ctemp = c( j-1 )
                  stemp = s( j-1 )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 170 i = 1, m
                        temp = a( i, j )
                        a( i, j ) = ctemp*temp - stemp*a( i, 1 )
                        a( i, 1 ) = stemp*temp + ctemp*a( i, 1 )
  170                CONTINUE
                  END IF
  180          CONTINUE
            ELSE IF( lsame( direct, 'B' ) ) THEN
               DO 200 j = n, 2, -1
                  ctemp = c( j-1 )
                  stemp = s( j-1 )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 190 i = 1, m
                        temp = a( i, j )
                        a( i, j ) = ctemp*temp - stemp*a( i, 1 )
                        a( i, 1 ) = stemp*temp + ctemp*a( i, 1 )
  190                CONTINUE
                  END IF
  200          CONTINUE
            END IF
         ELSE IF( lsame( pivot, 'B' ) ) THEN
            IF( lsame( direct, 'F' ) ) THEN
               DO 220 j = 1, n - 1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 210 i = 1, m
                        temp = a( i, j )
                        a( i, j ) = stemp*a( i, n ) + ctemp*temp
                        a( i, n ) = ctemp*a( i, n ) - stemp*temp
  210                CONTINUE
                  END IF
  220          CONTINUE
            ELSE IF( lsame( direct, 'B' ) ) THEN
               DO 240 j = n - 1, 1, -1
                  ctemp = c( j )
                  stemp = s( j )
                  IF( ( ctemp.NE.one ) .OR. ( stemp.NE.zero ) ) THEN
                     DO 230 i = 1, m
                        temp = a( i, j )
                        a( i, j ) = stemp*a( i, n ) + ctemp*temp
                        a( i, n ) = ctemp*a( i, n ) - stemp*temp
  230                CONTINUE
                  END IF
  240          CONTINUE
            END IF
         END IF
      END IF
*
      RETURN
*
*     End of DLASR
*
      END