src/LAPACK/dopgtr.f

   1       SUBROUTINE DOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
   2 *
   3 *  -- LAPACK routine (version 3.1) --
   4 *     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
   5 *     November 2006
   6 *
   7 *     .. Scalar Arguments ..
   8       CHARACTER          UPLO
   9       INTEGER            INFO, LDQ, N
  10 *     ..
  11 *     .. Array Arguments ..
  12       DOUBLE PRECISION   AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
  13 *     ..
  14 *
  15 *  Purpose
  16 *  =======
  17 *
  18 *  DOPGTR generates a real orthogonal matrix Q which is defined as the
  19 *  product of n-1 elementary reflectors H(i) of order n, as returned by
  20 *  DSPTRD using packed storage:
  21 *
  22 *  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
  23 *
  24 *  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
  25 *
  26 *  Arguments
  27 *  =========
  28 *
  29 *  UPLO    (input) CHARACTER*1
  30 *          = 'U': Upper triangular packed storage used in previous
  31 *                 call to DSPTRD;
  32 *          = 'L': Lower triangular packed storage used in previous
  33 *                 call to DSPTRD.
  34 *
  35 *  N       (input) INTEGER
  36 *          The order of the matrix Q. N >= 0.
  37 *
  38 *  AP      (input) DOUBLE PRECISION array, dimension (N*(N+1)/2)
  39 *          The vectors which define the elementary reflectors, as
  40 *          returned by DSPTRD.
  41 *
  42 *  TAU     (input) DOUBLE PRECISION array, dimension (N-1)
  43 *          TAU(i) must contain the scalar factor of the elementary
  44 *          reflector H(i), as returned by DSPTRD.
  45 *
  46 *  Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
  47 *          The N-by-N orthogonal matrix Q.
  48 *
  49 *  LDQ     (input) INTEGER
  50 *          The leading dimension of the array Q. LDQ >= max(1,N).
  51 *
  52 *  WORK    (workspace) DOUBLE PRECISION array, dimension (N-1)
  53 *
  54 *  INFO    (output) INTEGER
  55 *          = 0:  successful exit
  56 *          < 0:  if INFO = -i, the i-th argument had an illegal value
  57 *
  58 *  =====================================================================
  59 *
  60 *     .. Parameters ..
  61       DOUBLE PRECISION   ZERO, ONE
  62       PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
  63 *     ..
  64 *     .. Local Scalars ..
  65       LOGICAL            UPPER
  66       INTEGER            I, IINFO, IJ, J
  67 *     ..
  68 *     .. External Functions ..
  69       LOGICAL            LSAME
  70       EXTERNAL           LSAME
  71 *     ..
  72 *     .. External Subroutines ..
  73       EXTERNAL           DORG2L, DORG2R, XERBLA
  74 *     ..
  75 *     .. Intrinsic Functions ..
  76       INTRINSIC          MAX
  77 *     ..
  78 *     .. Executable Statements ..
  79 *
  80 *     Test the input arguments
  81 *
  82       INFO = 0
  83       UPPER = LSAME( UPLO, 'U' )
  84       IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
  85          INFO = -1
  86       ELSE IF( N.LT.0 ) THEN
  87          INFO = -2
  88       ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
  89          INFO = -6
  90       END IF
  91       IF( INFO.NE.0 ) THEN
  92          CALL XERBLA( 'DOPGTR', -INFO )
  93          RETURN
  94       END IF
  95 *
  96 *     Quick return if possible
  97 *
  98       IF( N.EQ.0 )
  99      $   RETURN
 100 *
 101       IF( UPPER ) THEN
 102 *
 103 *        Q was determined by a call to DSPTRD with UPLO = 'U'
 104 *
 105 *        Unpack the vectors which define the elementary reflectors and
 106 *        set the last row and column of Q equal to those of the unit
 107 *        matrix
 108 *
 109          IJ = 2
 110          DO 20 J = 1, N - 1
 111             DO 10 I = 1, J - 1
 112                Q( I, J ) = AP( IJ )
 113                IJ = IJ + 1
 114    10       CONTINUE
 115             IJ = IJ + 2
 116             Q( N, J ) = ZERO
 117    20    CONTINUE
 118          DO 30 I = 1, N - 1
 119             Q( I, N ) = ZERO
 120    30    CONTINUE
 121          Q( N, N ) = ONE
 122 *
 123 *        Generate Q(1:n-1,1:n-1)
 124 *
 125          CALL DORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
 126 *
 127       ELSE
 128 *
 129 *        Q was determined by a call to DSPTRD with UPLO = 'L'.
 130 *
 131 *        Unpack the vectors which define the elementary reflectors and
 132 *        set the first row and column of Q equal to those of the unit
 133 *        matrix
 134 *
 135          Q( 1, 1 ) = ONE
 136          DO 40 I = 2, N
 137             Q( I, 1 ) = ZERO
 138    40    CONTINUE
 139          IJ = 3
 140          DO 60 J = 2, N
 141             Q( 1, J ) = ZERO
 142             DO 50 I = J + 1, N
 143                Q( I, J ) = AP( IJ )
 144                IJ = IJ + 1
 145    50       CONTINUE
 146             IJ = IJ + 2
 147    60    CONTINUE
 148          IF( N.GT.1 ) THEN
 149 *
 150 *           Generate Q(2:n,2:n)
 151 *
 152             CALL DORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
 153      $                   IINFO )
 154          END IF
 155       END IF
 156       RETURN
 157 *
 158 *     End of DOPGTR
 159 *
 160       END