LAPACK 3.3.1 Linear Algebra PACKage

# sopgtr.f

Go to the documentation of this file.
```00001       SUBROUTINE SOPGTR( UPLO, N, AP, TAU, Q, LDQ, WORK, INFO )
00002 *
00003 *  -- LAPACK routine (version 3.2) --
00004 *  -- LAPACK is a software package provided by Univ. of Tennessee,    --
00005 *  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
00006 *     November 2006
00007 *
00008 *     .. Scalar Arguments ..
00009       CHARACTER          UPLO
00010       INTEGER            INFO, LDQ, N
00011 *     ..
00012 *     .. Array Arguments ..
00013       REAL               AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
00014 *     ..
00015 *
00016 *  Purpose
00017 *  =======
00018 *
00019 *  SOPGTR generates a real orthogonal matrix Q which is defined as the
00020 *  product of n-1 elementary reflectors H(i) of order n, as returned by
00021 *  SSPTRD using packed storage:
00022 *
00023 *  if UPLO = 'U', Q = H(n-1) . . . H(2) H(1),
00024 *
00025 *  if UPLO = 'L', Q = H(1) H(2) . . . H(n-1).
00026 *
00027 *  Arguments
00028 *  =========
00029 *
00030 *  UPLO    (input) CHARACTER*1
00031 *          = 'U': Upper triangular packed storage used in previous
00032 *                 call to SSPTRD;
00033 *          = 'L': Lower triangular packed storage used in previous
00034 *                 call to SSPTRD.
00035 *
00036 *  N       (input) INTEGER
00037 *          The order of the matrix Q. N >= 0.
00038 *
00039 *  AP      (input) REAL array, dimension (N*(N+1)/2)
00040 *          The vectors which define the elementary reflectors, as
00041 *          returned by SSPTRD.
00042 *
00043 *  TAU     (input) REAL array, dimension (N-1)
00044 *          TAU(i) must contain the scalar factor of the elementary
00045 *          reflector H(i), as returned by SSPTRD.
00046 *
00047 *  Q       (output) REAL array, dimension (LDQ,N)
00048 *          The N-by-N orthogonal matrix Q.
00049 *
00050 *  LDQ     (input) INTEGER
00051 *          The leading dimension of the array Q. LDQ >= max(1,N).
00052 *
00053 *  WORK    (workspace) REAL array, dimension (N-1)
00054 *
00055 *  INFO    (output) INTEGER
00056 *          = 0:  successful exit
00057 *          < 0:  if INFO = -i, the i-th argument had an illegal value
00058 *
00059 *  =====================================================================
00060 *
00061 *     .. Parameters ..
00062       REAL               ZERO, ONE
00063       PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
00064 *     ..
00065 *     .. Local Scalars ..
00066       LOGICAL            UPPER
00067       INTEGER            I, IINFO, IJ, J
00068 *     ..
00069 *     .. External Functions ..
00070       LOGICAL            LSAME
00071       EXTERNAL           LSAME
00072 *     ..
00073 *     .. External Subroutines ..
00074       EXTERNAL           SORG2L, SORG2R, XERBLA
00075 *     ..
00076 *     .. Intrinsic Functions ..
00077       INTRINSIC          MAX
00078 *     ..
00079 *     .. Executable Statements ..
00080 *
00081 *     Test the input arguments
00082 *
00083       INFO = 0
00084       UPPER = LSAME( UPLO, 'U' )
00085       IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
00086          INFO = -1
00087       ELSE IF( N.LT.0 ) THEN
00088          INFO = -2
00089       ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
00090          INFO = -6
00091       END IF
00092       IF( INFO.NE.0 ) THEN
00093          CALL XERBLA( 'SOPGTR', -INFO )
00094          RETURN
00095       END IF
00096 *
00097 *     Quick return if possible
00098 *
00099       IF( N.EQ.0 )
00100      \$   RETURN
00101 *
00102       IF( UPPER ) THEN
00103 *
00104 *        Q was determined by a call to SSPTRD with UPLO = 'U'
00105 *
00106 *        Unpack the vectors which define the elementary reflectors and
00107 *        set the last row and column of Q equal to those of the unit
00108 *        matrix
00109 *
00110          IJ = 2
00111          DO 20 J = 1, N - 1
00112             DO 10 I = 1, J - 1
00113                Q( I, J ) = AP( IJ )
00114                IJ = IJ + 1
00115    10       CONTINUE
00116             IJ = IJ + 2
00117             Q( N, J ) = ZERO
00118    20    CONTINUE
00119          DO 30 I = 1, N - 1
00120             Q( I, N ) = ZERO
00121    30    CONTINUE
00122          Q( N, N ) = ONE
00123 *
00124 *        Generate Q(1:n-1,1:n-1)
00125 *
00126          CALL SORG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
00127 *
00128       ELSE
00129 *
00130 *        Q was determined by a call to SSPTRD with UPLO = 'L'.
00131 *
00132 *        Unpack the vectors which define the elementary reflectors and
00133 *        set the first row and column of Q equal to those of the unit
00134 *        matrix
00135 *
00136          Q( 1, 1 ) = ONE
00137          DO 40 I = 2, N
00138             Q( I, 1 ) = ZERO
00139    40    CONTINUE
00140          IJ = 3
00141          DO 60 J = 2, N
00142             Q( 1, J ) = ZERO
00143             DO 50 I = J + 1, N
00144                Q( I, J ) = AP( IJ )
00145                IJ = IJ + 1
00146    50       CONTINUE
00147             IJ = IJ + 2
00148    60    CONTINUE
00149          IF( N.GT.1 ) THEN
00150 *
00151 *           Generate Q(2:n,2:n)
00152 *
00153             CALL SORG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
00154      \$                   IINFO )
00155          END IF
00156       END IF
00157       RETURN
00158 *
00159 *     End of SOPGTR
00160 *
00161       END
```