d1/d67/dopmtr_8f_source.html

*> \brief \b DOPMTR

*

*  =========== DOCUMENTATION ===========

*

* Online html documentation available at

*            http://www.netlib.org/lapack/explore-html/

*

*> Download DOPMTR + dependencies

*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dopmtr.f">

*> [TGZ]</a>

*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dopmtr.f">

*> [ZIP]</a>

*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dopmtr.f">

*> [TXT]</a>

*

*  Definition:

*  ===========

*

*       SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK,

*                          INFO )

*

*       .. Scalar Arguments ..

*       CHARACTER          SIDE, TRANS, UPLO

*       INTEGER            INFO, LDC, M, N

*       ..

*       .. Array Arguments ..

*       DOUBLE PRECISION   AP( * ), C( LDC, * ), TAU( * ), WORK( * )

*       ..

*

*

*> \par Purpose:

*  =============

*>

*> \verbatim

*>

*> DOPMTR overwrites the general real M-by-N matrix C with

*>

*>                 SIDE = 'L'     SIDE = 'R'

*> TRANS = 'N':      Q * C          C * Q

*> TRANS = 'T':      Q**T * C       C * Q**T

*>

*> where Q is a real orthogonal matrix of order nq, with nq = m if

*> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of

*> nq-1 elementary reflectors, as returned by DSPTRD using packed

*> storage:

*>

*> if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1);

*>

*> if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1).

*> \endverbatim

*

*  Arguments:

*  ==========

*

*> \param[in] SIDE

*> \verbatim

*>          SIDE is CHARACTER*1

*>          = 'L': apply Q or Q**T from the Left;

*>          = 'R': apply Q or Q**T from the Right.

*> \endverbatim

*>

*> \param[in] UPLO

*> \verbatim

*>          UPLO is CHARACTER*1

*>          = 'U': Upper triangular packed storage used in previous

*>                 call to DSPTRD;

*>          = 'L': Lower triangular packed storage used in previous

*>                 call to DSPTRD.

*> \endverbatim

*>

*> \param[in] TRANS

*> \verbatim

*>          TRANS is CHARACTER*1

*>          = 'N':  No transpose, apply Q;

*>          = 'T':  Transpose, apply Q**T.

*> \endverbatim

*>

*> \param[in] M

*> \verbatim

*>          M is INTEGER

*>          The number of rows of the matrix C. M >= 0.

*> \endverbatim

*>

*> \param[in] N

*> \verbatim

*>          N is INTEGER

*>          The number of columns of the matrix C. N >= 0.

*> \endverbatim

*>

*> \param[in] AP

*> \verbatim

*>          AP is DOUBLE PRECISION array, dimension

*>                               (M*(M+1)/2) if SIDE = 'L'

*>                               (N*(N+1)/2) if SIDE = 'R'

*>          The vectors which define the elementary reflectors, as

*>          returned by DSPTRD.  AP is modified by the routine but

*>          restored on exit.

*> \endverbatim

*>

*> \param[in] TAU

*> \verbatim

*>          TAU is DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L'

*>                                     or (N-1) if SIDE = 'R'

*>          TAU(i) must contain the scalar factor of the elementary

*>          reflector H(i), as returned by DSPTRD.

*> \endverbatim

*>

*> \param[in,out] C

*> \verbatim

*>          C is DOUBLE PRECISION array, dimension (LDC,N)

*>          On entry, the M-by-N matrix C.

*>          On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q.

*> \endverbatim

*>

*> \param[in] LDC

*> \verbatim

*>          LDC is INTEGER

*>          The leading dimension of the array C. LDC >= max(1,M).

*> \endverbatim

*>

*> \param[out] WORK

*> \verbatim

*>          WORK is DOUBLE PRECISION array, dimension

*>                                   (N) if SIDE = 'L'

*>                                   (M) if SIDE = 'R'

*> \endverbatim

*>

*> \param[out] INFO

*> \verbatim

*>          INFO is INTEGER

*>          = 0:  successful exit

*>          < 0:  if INFO = -i, the i-th argument had an illegal value

*> \endverbatim

*

*  Authors:

*  ========

*

*> \author Univ. of Tennessee

*> \author Univ. of California Berkeley

*> \author Univ. of Colorado Denver

*> \author NAG Ltd.

*

*> \ingroup upmtr

*

*  =====================================================================


      SUBROUTINE dopmtr( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC,

     $                   WORK,

     $                   INFO )

*

*  -- LAPACK computational routine --

*  -- LAPACK is a software package provided by Univ. of Tennessee,    --

*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--

*

*     .. Scalar Arguments ..

      CHARACTER          SIDE, TRANS, UPLO

      INTEGER            INFO, LDC, M, N

*     ..

*     .. Array Arguments ..

      DOUBLE PRECISION   AP( * ), C( LDC, * ), TAU( * ), WORK( * )

*     ..

*

*  =====================================================================

*

*     .. Parameters ..

      DOUBLE PRECISION   ONE

      PARAMETER          ( ONE = 1.0d+0 )

*     ..

*     .. Local Scalars ..

      LOGICAL            FORWRD, LEFT, NOTRAN, UPPER

      INTEGER            I, I1, I2, I3, IC, II, JC, MI, NI, NQ

      DOUBLE PRECISION   AII

*     ..

*     .. External Functions ..

      LOGICAL            LSAME

      EXTERNAL           LSAME

*     ..

*     .. External Subroutines ..

      EXTERNAL           dlarf, xerbla

*     ..

*     .. Intrinsic Functions ..

      INTRINSIC          max

*     ..

*     .. Executable Statements ..

*

*     Test the input arguments

*

      info = 0

      left = lsame( side, 'L' )

      notran = lsame( trans, 'N' )

      upper = lsame( uplo, 'U' )

*

*     NQ is the order of Q

*

      IF( left ) THEN

         nq = m

      ELSE

         nq = n

      END IF

      IF( .NOT.left .AND. .NOT.lsame( side, 'R' ) ) THEN

         info = -1

      ELSE IF( .NOT.upper .AND. .NOT.lsame( uplo, 'L' ) ) THEN

         info = -2

      ELSE IF( .NOT.notran .AND. .NOT.lsame( trans, 'T' ) ) THEN

         info = -3

      ELSE IF( m.LT.0 ) THEN

         info = -4

      ELSE IF( n.LT.0 ) THEN

         info = -5

      ELSE IF( ldc.LT.max( 1, m ) ) THEN

         info = -9

      END IF

      IF( info.NE.0 ) THEN

         CALL xerbla( 'DOPMTR', -info )

         RETURN

      END IF

*

*     Quick return if possible

*

      IF( m.EQ.0 .OR. n.EQ.0 )

     $   RETURN

*

      IF( upper ) THEN

*

*        Q was determined by a call to DSPTRD with UPLO = 'U'

*

         forwrd = ( left .AND. notran ) .OR.

     $            ( .NOT.left .AND. .NOT.notran )

*

         IF( forwrd ) THEN

            i1 = 1

            i2 = nq - 1

            i3 = 1

            ii = 2

         ELSE

            i1 = nq - 1

            i2 = 1

            i3 = -1

            ii = nq*( nq+1 ) / 2 - 1

         END IF

*

         IF( left ) THEN

            ni = n

         ELSE

            mi = m

         END IF

*

         DO 10 i = i1, i2, i3

            IF( left ) THEN

*

*              H(i) is applied to C(1:i,1:n)

*

               mi = i

            ELSE

*

*              H(i) is applied to C(1:m,1:i)

*

               ni = i

            END IF

*

*           Apply H(i)

*

            CALL dlarf1l( side, mi, ni, ap( ii-i+1 ), 1, tau( i ), c,

     $                  ldc,

     $                  work )

*

            IF( forwrd ) THEN

               ii = ii + i + 2

            ELSE

               ii = ii - i - 1

            END IF

   10    CONTINUE

      ELSE

*

*        Q was determined by a call to DSPTRD with UPLO = 'L'.

*

         forwrd = ( left .AND. .NOT.notran ) .OR.

     $            ( .NOT.left .AND. notran )

*

         IF( forwrd ) THEN

            i1 = 1

            i2 = nq - 1

            i3 = 1

            ii = 2

         ELSE

            i1 = nq - 1

            i2 = 1

            i3 = -1

            ii = nq*( nq+1 ) / 2 - 1

         END IF

*

         IF( left ) THEN

            ni = n

            jc = 1

         ELSE

            mi = m

            ic = 1

         END IF

*

         DO 20 i = i1, i2, i3

            aii = ap( ii )

            ap( ii ) = one

            IF( left ) THEN

*

*              H(i) is applied to C(i+1:m,1:n)

*

               mi = m - i

               ic = i + 1

            ELSE

*

*              H(i) is applied to C(1:m,i+1:n)

*

               ni = n - i

               jc = i + 1

            END IF

*

*           Apply H(i)

*

            CALL dlarf( side, mi, ni, ap( ii ), 1, tau( i ),

     $                  c( ic, jc ), ldc, work )

            ap( ii ) = aii

*

            IF( forwrd ) THEN

               ii = ii + nq - i + 1

            ELSE

               ii = ii - nq + i - 2

            END IF

   20    CONTINUE

      END IF

      RETURN

*

*     End of DOPMTR

*


      END

xerbla
subroutine xerbla(srname, info)
Definition cblat2.f:3285

dlarf1l
subroutine dlarf1l(side, m, n, v, incv, tau, c, ldc, work)
DLARF1L applies an elementary reflector to a general rectangular
Definition dlarf1l.f:124

dlarf
subroutine dlarf(side, m, n, v, incv, tau, c, ldc, work)
DLARF applies an elementary reflector to a general rectangular matrix.
Definition dlarf.f:122

dopmtr
subroutine dopmtr(side, uplo, trans, m, n, ap, tau, c, ldc, work, info)
DOPMTR
Definition dopmtr.f:149