LAPACK 3.3.0

cupgtr.f

Go to the documentation of this file.
00001       SUBROUTINE CUPGTR( 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       COMPLEX            AP( * ), Q( LDQ, * ), TAU( * ), WORK( * )
00014 *     ..
00015 *
00016 *  Purpose
00017 *  =======
00018 *
00019 *  CUPGTR generates a complex unitary matrix Q which is defined as the
00020 *  product of n-1 elementary reflectors H(i) of order n, as returned by
00021 *  CHPTRD 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 CHPTRD;
00033 *          = 'L': Lower triangular packed storage used in previous
00034 *                 call to CHPTRD.
00035 *
00036 *  N       (input) INTEGER
00037 *          The order of the matrix Q. N >= 0.
00038 *
00039 *  AP      (input) COMPLEX array, dimension (N*(N+1)/2)
00040 *          The vectors which define the elementary reflectors, as
00041 *          returned by CHPTRD.
00042 *
00043 *  TAU     (input) COMPLEX array, dimension (N-1)
00044 *          TAU(i) must contain the scalar factor of the elementary
00045 *          reflector H(i), as returned by CHPTRD.
00046 *
00047 *  Q       (output) COMPLEX array, dimension (LDQ,N)
00048 *          The N-by-N unitary matrix Q.
00049 *
00050 *  LDQ     (input) INTEGER
00051 *          The leading dimension of the array Q. LDQ >= max(1,N).
00052 *
00053 *  WORK    (workspace) COMPLEX 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       COMPLEX            CZERO, CONE
00063       PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
00064      $                   CONE = ( 1.0E+0, 0.0E+0 ) )
00065 *     ..
00066 *     .. Local Scalars ..
00067       LOGICAL            UPPER
00068       INTEGER            I, IINFO, IJ, J
00069 *     ..
00070 *     .. External Functions ..
00071       LOGICAL            LSAME
00072       EXTERNAL           LSAME
00073 *     ..
00074 *     .. External Subroutines ..
00075       EXTERNAL           CUNG2L, CUNG2R, XERBLA
00076 *     ..
00077 *     .. Intrinsic Functions ..
00078       INTRINSIC          MAX
00079 *     ..
00080 *     .. Executable Statements ..
00081 *
00082 *     Test the input arguments
00083 *
00084       INFO = 0
00085       UPPER = LSAME( UPLO, 'U' )
00086       IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
00087          INFO = -1
00088       ELSE IF( N.LT.0 ) THEN
00089          INFO = -2
00090       ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
00091          INFO = -6
00092       END IF
00093       IF( INFO.NE.0 ) THEN
00094          CALL XERBLA( 'CUPGTR', -INFO )
00095          RETURN
00096       END IF
00097 *
00098 *     Quick return if possible
00099 *
00100       IF( N.EQ.0 )
00101      $   RETURN
00102 *
00103       IF( UPPER ) THEN
00104 *
00105 *        Q was determined by a call to CHPTRD with UPLO = 'U'
00106 *
00107 *        Unpack the vectors which define the elementary reflectors and
00108 *        set the last row and column of Q equal to those of the unit
00109 *        matrix
00110 *
00111          IJ = 2
00112          DO 20 J = 1, N - 1
00113             DO 10 I = 1, J - 1
00114                Q( I, J ) = AP( IJ )
00115                IJ = IJ + 1
00116    10       CONTINUE
00117             IJ = IJ + 2
00118             Q( N, J ) = CZERO
00119    20    CONTINUE
00120          DO 30 I = 1, N - 1
00121             Q( I, N ) = CZERO
00122    30    CONTINUE
00123          Q( N, N ) = CONE
00124 *
00125 *        Generate Q(1:n-1,1:n-1)
00126 *
00127          CALL CUNG2L( N-1, N-1, N-1, Q, LDQ, TAU, WORK, IINFO )
00128 *
00129       ELSE
00130 *
00131 *        Q was determined by a call to CHPTRD with UPLO = 'L'.
00132 *
00133 *        Unpack the vectors which define the elementary reflectors and
00134 *        set the first row and column of Q equal to those of the unit
00135 *        matrix
00136 *
00137          Q( 1, 1 ) = CONE
00138          DO 40 I = 2, N
00139             Q( I, 1 ) = CZERO
00140    40    CONTINUE
00141          IJ = 3
00142          DO 60 J = 2, N
00143             Q( 1, J ) = CZERO
00144             DO 50 I = J + 1, N
00145                Q( I, J ) = AP( IJ )
00146                IJ = IJ + 1
00147    50       CONTINUE
00148             IJ = IJ + 2
00149    60    CONTINUE
00150          IF( N.GT.1 ) THEN
00151 *
00152 *           Generate Q(2:n,2:n)
00153 *
00154             CALL CUNG2R( N-1, N-1, N-1, Q( 2, 2 ), LDQ, TAU, WORK,
00155      $                   IINFO )
00156          END IF
00157       END IF
00158       RETURN
00159 *
00160 *     End of CUPGTR
00161 *
00162       END
 All Files Functions