00001 SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, 00002 $ WORK, LWORK, INFO ) 00003 * 00004 * -- LAPACK routine (version 3.2) -- 00005 * -- LAPACK is a software package provided by Univ. of Tennessee, -- 00006 * -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 00007 * November 2006 00008 * 00009 * .. Scalar Arguments .. 00010 CHARACTER SIDE, TRANS, UPLO 00011 INTEGER INFO, LDA, LDC, LWORK, M, N 00012 * .. 00013 * .. Array Arguments .. 00014 DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) 00015 * .. 00016 * 00017 * Purpose 00018 * ======= 00019 * 00020 * DORMTR overwrites the general real M-by-N matrix C with 00021 * 00022 * SIDE = 'L' SIDE = 'R' 00023 * TRANS = 'N': Q * C C * Q 00024 * TRANS = 'T': Q**T * C C * Q**T 00025 * 00026 * where Q is a real orthogonal matrix of order nq, with nq = m if 00027 * SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of 00028 * nq-1 elementary reflectors, as returned by DSYTRD: 00029 * 00030 * if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); 00031 * 00032 * if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). 00033 * 00034 * Arguments 00035 * ========= 00036 * 00037 * SIDE (input) CHARACTER*1 00038 * = 'L': apply Q or Q**T from the Left; 00039 * = 'R': apply Q or Q**T from the Right. 00040 * 00041 * UPLO (input) CHARACTER*1 00042 * = 'U': Upper triangle of A contains elementary reflectors 00043 * from DSYTRD; 00044 * = 'L': Lower triangle of A contains elementary reflectors 00045 * from DSYTRD. 00046 * 00047 * TRANS (input) CHARACTER*1 00048 * = 'N': No transpose, apply Q; 00049 * = 'T': Transpose, apply Q**T. 00050 * 00051 * M (input) INTEGER 00052 * The number of rows of the matrix C. M >= 0. 00053 * 00054 * N (input) INTEGER 00055 * The number of columns of the matrix C. N >= 0. 00056 * 00057 * A (input) DOUBLE PRECISION array, dimension 00058 * (LDA,M) if SIDE = 'L' 00059 * (LDA,N) if SIDE = 'R' 00060 * The vectors which define the elementary reflectors, as 00061 * returned by DSYTRD. 00062 * 00063 * LDA (input) INTEGER 00064 * The leading dimension of the array A. 00065 * LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. 00066 * 00067 * TAU (input) DOUBLE PRECISION array, dimension 00068 * (M-1) if SIDE = 'L' 00069 * (N-1) if SIDE = 'R' 00070 * TAU(i) must contain the scalar factor of the elementary 00071 * reflector H(i), as returned by DSYTRD. 00072 * 00073 * C (input/output) DOUBLE PRECISION array, dimension (LDC,N) 00074 * On entry, the M-by-N matrix C. 00075 * On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. 00076 * 00077 * LDC (input) INTEGER 00078 * The leading dimension of the array C. LDC >= max(1,M). 00079 * 00080 * WORK (workspace/output) DOUBLE PRECISION array, dimension (MAX(1,LWORK)) 00081 * On exit, if INFO = 0, WORK(1) returns the optimal LWORK. 00082 * 00083 * LWORK (input) INTEGER 00084 * The dimension of the array WORK. 00085 * If SIDE = 'L', LWORK >= max(1,N); 00086 * if SIDE = 'R', LWORK >= max(1,M). 00087 * For optimum performance LWORK >= N*NB if SIDE = 'L', and 00088 * LWORK >= M*NB if SIDE = 'R', where NB is the optimal 00089 * blocksize. 00090 * 00091 * If LWORK = -1, then a workspace query is assumed; the routine 00092 * only calculates the optimal size of the WORK array, returns 00093 * this value as the first entry of the WORK array, and no error 00094 * message related to LWORK is issued by XERBLA. 00095 * 00096 * INFO (output) INTEGER 00097 * = 0: successful exit 00098 * < 0: if INFO = -i, the i-th argument had an illegal value 00099 * 00100 * ===================================================================== 00101 * 00102 * .. Local Scalars .. 00103 LOGICAL LEFT, LQUERY, UPPER 00104 INTEGER I1, I2, IINFO, LWKOPT, MI, NB, NI, NQ, NW 00105 * .. 00106 * .. External Functions .. 00107 LOGICAL LSAME 00108 INTEGER ILAENV 00109 EXTERNAL LSAME, ILAENV 00110 * .. 00111 * .. External Subroutines .. 00112 EXTERNAL DORMQL, DORMQR, XERBLA 00113 * .. 00114 * .. Intrinsic Functions .. 00115 INTRINSIC MAX 00116 * .. 00117 * .. Executable Statements .. 00118 * 00119 * Test the input arguments 00120 * 00121 INFO = 0 00122 LEFT = LSAME( SIDE, 'L' ) 00123 UPPER = LSAME( UPLO, 'U' ) 00124 LQUERY = ( LWORK.EQ.-1 ) 00125 * 00126 * NQ is the order of Q and NW is the minimum dimension of WORK 00127 * 00128 IF( LEFT ) THEN 00129 NQ = M 00130 NW = N 00131 ELSE 00132 NQ = N 00133 NW = M 00134 END IF 00135 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 00136 INFO = -1 00137 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 00138 INFO = -2 00139 ELSE IF( .NOT.LSAME( TRANS, 'N' ) .AND. .NOT.LSAME( TRANS, 'T' ) ) 00140 $ THEN 00141 INFO = -3 00142 ELSE IF( M.LT.0 ) THEN 00143 INFO = -4 00144 ELSE IF( N.LT.0 ) THEN 00145 INFO = -5 00146 ELSE IF( LDA.LT.MAX( 1, NQ ) ) THEN 00147 INFO = -7 00148 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN 00149 INFO = -10 00150 ELSE IF( LWORK.LT.MAX( 1, NW ) .AND. .NOT.LQUERY ) THEN 00151 INFO = -12 00152 END IF 00153 * 00154 IF( INFO.EQ.0 ) THEN 00155 IF( UPPER ) THEN 00156 IF( LEFT ) THEN 00157 NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M-1, N, M-1, 00158 $ -1 ) 00159 ELSE 00160 NB = ILAENV( 1, 'DORMQL', SIDE // TRANS, M, N-1, N-1, 00161 $ -1 ) 00162 END IF 00163 ELSE 00164 IF( LEFT ) THEN 00165 NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M-1, N, M-1, 00166 $ -1 ) 00167 ELSE 00168 NB = ILAENV( 1, 'DORMQR', SIDE // TRANS, M, N-1, N-1, 00169 $ -1 ) 00170 END IF 00171 END IF 00172 LWKOPT = MAX( 1, NW )*NB 00173 WORK( 1 ) = LWKOPT 00174 END IF 00175 * 00176 IF( INFO.NE.0 ) THEN 00177 CALL XERBLA( 'DORMTR', -INFO ) 00178 RETURN 00179 ELSE IF( LQUERY ) THEN 00180 RETURN 00181 END IF 00182 * 00183 * Quick return if possible 00184 * 00185 IF( M.EQ.0 .OR. N.EQ.0 .OR. NQ.EQ.1 ) THEN 00186 WORK( 1 ) = 1 00187 RETURN 00188 END IF 00189 * 00190 IF( LEFT ) THEN 00191 MI = M - 1 00192 NI = N 00193 ELSE 00194 MI = M 00195 NI = N - 1 00196 END IF 00197 * 00198 IF( UPPER ) THEN 00199 * 00200 * Q was determined by a call to DSYTRD with UPLO = 'U' 00201 * 00202 CALL DORMQL( SIDE, TRANS, MI, NI, NQ-1, A( 1, 2 ), LDA, TAU, C, 00203 $ LDC, WORK, LWORK, IINFO ) 00204 ELSE 00205 * 00206 * Q was determined by a call to DSYTRD with UPLO = 'L' 00207 * 00208 IF( LEFT ) THEN 00209 I1 = 2 00210 I2 = 1 00211 ELSE 00212 I1 = 1 00213 I2 = 2 00214 END IF 00215 CALL DORMQR( SIDE, TRANS, MI, NI, NQ-1, A( 2, 1 ), LDA, TAU, 00216 $ C( I1, I2 ), LDC, WORK, LWORK, IINFO ) 00217 END IF 00218 WORK( 1 ) = LWKOPT 00219 RETURN 00220 * 00221 * End of DORMTR 00222 * 00223 END
1.7.2