LAPACK: SRC/cunglq.f Source File

Go to the documentation of this file.
00001       SUBROUTINE CUNGLQ( M, N, K, A, LDA, TAU, WORK, LWORK, 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       INTEGER            INFO, K, LDA, LWORK, M, N
00010 *     ..
00011 *     .. Array Arguments ..
00012       COMPLEX            A( LDA, * ), TAU( * ), WORK( * )
00013 *     ..
00014 *
00015 *  Purpose
00016 *  =======
00017 *
00018 *  CUNGLQ generates an M-by-N complex matrix Q with orthonormal rows,
00019 *  which is defined as the first M rows of a product of K elementary
00020 *  reflectors of order N
00021 *
00022 *        Q  =  H(k)' . . . H(2)' H(1)'
00023 *
00024 *  as returned by CGELQF.
00025 *
00026 *  Arguments
00027 *  =========
00028 *
00029 *  M       (input) INTEGER
00030 *          The number of rows of the matrix Q. M >= 0.
00031 *
00032 *  N       (input) INTEGER
00033 *          The number of columns of the matrix Q. N >= M.
00034 *
00035 *  K       (input) INTEGER
00036 *          The number of elementary reflectors whose product defines the
00037 *          matrix Q. M >= K >= 0.
00038 *
00039 *  A       (input/output) COMPLEX array, dimension (LDA,N)
00040 *          On entry, the i-th row must contain the vector which defines
00041 *          the elementary reflector H(i), for i = 1,2,...,k, as returned
00042 *          by CGELQF in the first k rows of its array argument A.
00043 *          On exit, the M-by-N matrix Q.
00044 *
00045 *  LDA     (input) INTEGER
00046 *          The first dimension of the array A. LDA >= max(1,M).
00047 *
00048 *  TAU     (input) COMPLEX array, dimension (K)
00049 *          TAU(i) must contain the scalar factor of the elementary
00050 *          reflector H(i), as returned by CGELQF.
00051 *
00052 *  WORK    (workspace/output) COMPLEX array, dimension (MAX(1,LWORK))
00053 *          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
00054 *
00055 *  LWORK   (input) INTEGER
00056 *          The dimension of the array WORK. LWORK >= max(1,M).
00057 *          For optimum performance LWORK >= M*NB, where NB is
00058 *          the optimal blocksize.
00059 *
00060 *          If LWORK = -1, then a workspace query is assumed; the routine
00061 *          only calculates the optimal size of the WORK array, returns
00062 *          this value as the first entry of the WORK array, and no error
00063 *          message related to LWORK is issued by XERBLA.
00064 *
00065 *  INFO    (output) INTEGER
00066 *          = 0:  successful exit;
00067 *          < 0:  if INFO = -i, the i-th argument has an illegal value
00068 *
00069 *  =====================================================================
00070 *
00071 *     .. Parameters ..
00072       COMPLEX            ZERO
00073       PARAMETER          ( ZERO = ( 0.0E+0, 0.0E+0 ) )
00074 *     ..
00075 *     .. Local Scalars ..
00076       LOGICAL            LQUERY
00077       INTEGER            I, IB, IINFO, IWS, J, KI, KK, L, LDWORK,
00078      $                   LWKOPT, NB, NBMIN, NX
00079 *     ..
00080 *     .. External Subroutines ..
00081       EXTERNAL           CLARFB, CLARFT, CUNGL2, XERBLA
00082 *     ..
00083 *     .. Intrinsic Functions ..
00084       INTRINSIC          MAX, MIN
00085 *     ..
00086 *     .. External Functions ..
00087       INTEGER            ILAENV
00088       EXTERNAL           ILAENV
00089 *     ..
00090 *     .. Executable Statements ..
00091 *
00092 *     Test the input arguments
00093 *
00094       INFO = 0
00095       NB = ILAENV( 1, 'CUNGLQ', ' ', M, N, K, -1 )
00096       LWKOPT = MAX( 1, M )*NB
00097       WORK( 1 ) = LWKOPT
00098       LQUERY = ( LWORK.EQ.-1 )
00099       IF( M.LT.0 ) THEN
00100          INFO = -1
00101       ELSE IF( N.LT.M ) THEN
00102          INFO = -2
00103       ELSE IF( K.LT.0 .OR. K.GT.M ) THEN
00104          INFO = -3
00105       ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
00106          INFO = -5
00107       ELSE IF( LWORK.LT.MAX( 1, M ) .AND. .NOT.LQUERY ) THEN
00108          INFO = -8
00109       END IF
00110       IF( INFO.NE.0 ) THEN
00111          CALL XERBLA( 'CUNGLQ', -INFO )
00112          RETURN
00113       ELSE IF( LQUERY ) THEN
00114          RETURN
00115       END IF
00116 *
00117 *     Quick return if possible
00118 *
00119       IF( M.LE.0 ) THEN
00120          WORK( 1 ) = 1
00121          RETURN
00122       END IF
00123 *
00124       NBMIN = 2
00125       NX = 0
00126       IWS = M
00127       IF( NB.GT.1 .AND. NB.LT.K ) THEN
00128 *
00129 *        Determine when to cross over from blocked to unblocked code.
00130 *
00131          NX = MAX( 0, ILAENV( 3, 'CUNGLQ', ' ', M, N, K, -1 ) )
00132          IF( NX.LT.K ) THEN
00133 *
00134 *           Determine if workspace is large enough for blocked code.
00135 *
00136             LDWORK = M
00137             IWS = LDWORK*NB
00138             IF( LWORK.LT.IWS ) THEN
00139 *
00140 *              Not enough workspace to use optimal NB:  reduce NB and
00141 *              determine the minimum value of NB.
00142 *
00143                NB = LWORK / LDWORK
00144                NBMIN = MAX( 2, ILAENV( 2, 'CUNGLQ', ' ', M, N, K, -1 ) )
00145             END IF
00146          END IF
00147       END IF
00148 *
00149       IF( NB.GE.NBMIN .AND. NB.LT.K .AND. NX.LT.K ) THEN
00150 *
00151 *        Use blocked code after the last block.
00152 *        The first kk rows are handled by the block method.
00153 *
00154          KI = ( ( K-NX-1 ) / NB )*NB
00155          KK = MIN( K, KI+NB )
00156 *
00157 *        Set A(kk+1:m,1:kk) to zero.
00158 *
00159          DO 20 J = 1, KK
00160             DO 10 I = KK + 1, M
00161                A( I, J ) = ZERO
00162    10       CONTINUE
00163    20    CONTINUE
00164       ELSE
00165          KK = 0
00166       END IF
00167 *
00168 *     Use unblocked code for the last or only block.
00169 *
00170       IF( KK.LT.M )
00171      $   CALL CUNGL2( M-KK, N-KK, K-KK, A( KK+1, KK+1 ), LDA,
00172      $                TAU( KK+1 ), WORK, IINFO )
00173 *
00174       IF( KK.GT.0 ) THEN
00175 *
00176 *        Use blocked code
00177 *
00178          DO 50 I = KI + 1, 1, -NB
00179             IB = MIN( NB, K-I+1 )
00180             IF( I+IB.LE.M ) THEN
00181 *
00182 *              Form the triangular factor of the block reflector
00183 *              H = H(i) H(i+1) . . . H(i+ib-1)
00184 *
00185                CALL CLARFT( 'Forward', 'Rowwise', N-I+1, IB, A( I, I ),
00186      $                      LDA, TAU( I ), WORK, LDWORK )
00187 *
00188 *              Apply H' to A(i+ib:m,i:n) from the right
00189 *
00190                CALL CLARFB( 'Right', 'Conjugate transpose', 'Forward',
00191      $                      'Rowwise', M-I-IB+1, N-I+1, IB, A( I, I ),
00192      $                      LDA, WORK, LDWORK, A( I+IB, I ), LDA,
00193      $                      WORK( IB+1 ), LDWORK )
00194             END IF
00195 *
00196 *           Apply H' to columns i:n of current block
00197 *
00198             CALL CUNGL2( IB, N-I+1, IB, A( I, I ), LDA, TAU( I ), WORK,
00199      $                   IINFO )
00200 *
00201 *           Set columns 1:i-1 of current block to zero
00202 *
00203             DO 40 J = 1, I - 1
00204                DO 30 L = I, I + IB - 1
00205                   A( L, J ) = ZERO
00206    30          CONTINUE
00207    40       CONTINUE
00208    50    CONTINUE
00209       END IF
00210 *
00211       WORK( 1 ) = IWS
00212       RETURN
00213 *
00214 *     End of CUNGLQ
00215 *
00216       END