1*> \brief \b DOPMTR 2* 3* =========== DOCUMENTATION =========== 4* 5* Online html documentation available at 6* http://www.netlib.org/lapack/explore-html/ 7* 8*> \htmlonly 9*> Download DOPMTR + dependencies 10*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dopmtr.f"> 11*> [TGZ]</a> 12*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dopmtr.f"> 13*> [ZIP]</a> 14*> <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dopmtr.f"> 15*> [TXT]</a> 16*> \endhtmlonly 17* 18* Definition: 19* =========== 20* 21* SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, 22* INFO ) 23* 24* .. Scalar Arguments .. 25* CHARACTER SIDE, TRANS, UPLO 26* INTEGER INFO, LDC, M, N 27* .. 28* .. Array Arguments .. 29* DOUBLE PRECISION AP( * ), C( LDC, * ), TAU( * ), WORK( * ) 30* .. 31* 32* 33*> \par Purpose: 34* ============= 35*> 36*> \verbatim 37*> 38*> DOPMTR overwrites the general real M-by-N matrix C with 39*> 40*> SIDE = 'L' SIDE = 'R' 41*> TRANS = 'N': Q * C C * Q 42*> TRANS = 'T': Q**T * C C * Q**T 43*> 44*> where Q is a real orthogonal matrix of order nq, with nq = m if 45*> SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of 46*> nq-1 elementary reflectors, as returned by DSPTRD using packed 47*> storage: 48*> 49*> if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); 50*> 51*> if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). 52*> \endverbatim 53* 54* Arguments: 55* ========== 56* 57*> \param[in] SIDE 58*> \verbatim 59*> SIDE is CHARACTER*1 60*> = 'L': apply Q or Q**T from the Left; 61*> = 'R': apply Q or Q**T from the Right. 62*> \endverbatim 63*> 64*> \param[in] UPLO 65*> \verbatim 66*> UPLO is CHARACTER*1 67*> = 'U': Upper triangular packed storage used in previous 68*> call to DSPTRD; 69*> = 'L': Lower triangular packed storage used in previous 70*> call to DSPTRD. 71*> \endverbatim 72*> 73*> \param[in] TRANS 74*> \verbatim 75*> TRANS is CHARACTER*1 76*> = 'N': No transpose, apply Q; 77*> = 'T': Transpose, apply Q**T. 78*> \endverbatim 79*> 80*> \param[in] M 81*> \verbatim 82*> M is INTEGER 83*> The number of rows of the matrix C. M >= 0. 84*> \endverbatim 85*> 86*> \param[in] N 87*> \verbatim 88*> N is INTEGER 89*> The number of columns of the matrix C. N >= 0. 90*> \endverbatim 91*> 92*> \param[in] AP 93*> \verbatim 94*> AP is DOUBLE PRECISION array, dimension 95*> (M*(M+1)/2) if SIDE = 'L' 96*> (N*(N+1)/2) if SIDE = 'R' 97*> The vectors which define the elementary reflectors, as 98*> returned by DSPTRD. AP is modified by the routine but 99*> restored on exit. 100*> \endverbatim 101*> 102*> \param[in] TAU 103*> \verbatim 104*> TAU is DOUBLE PRECISION array, dimension (M-1) if SIDE = 'L' 105*> or (N-1) if SIDE = 'R' 106*> TAU(i) must contain the scalar factor of the elementary 107*> reflector H(i), as returned by DSPTRD. 108*> \endverbatim 109*> 110*> \param[in,out] C 111*> \verbatim 112*> C is DOUBLE PRECISION array, dimension (LDC,N) 113*> On entry, the M-by-N matrix C. 114*> On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. 115*> \endverbatim 116*> 117*> \param[in] LDC 118*> \verbatim 119*> LDC is INTEGER 120*> The leading dimension of the array C. LDC >= max(1,M). 121*> \endverbatim 122*> 123*> \param[out] WORK 124*> \verbatim 125*> WORK is DOUBLE PRECISION array, dimension 126*> (N) if SIDE = 'L' 127*> (M) if SIDE = 'R' 128*> \endverbatim 129*> 130*> \param[out] INFO 131*> \verbatim 132*> INFO is INTEGER 133*> = 0: successful exit 134*> < 0: if INFO = -i, the i-th argument had an illegal value 135*> \endverbatim 136* 137* Authors: 138* ======== 139* 140*> \author Univ. of Tennessee 141*> \author Univ. of California Berkeley 142*> \author Univ. of Colorado Denver 143*> \author NAG Ltd. 144* 145*> \date December 2016 146* 147*> \ingroup doubleOTHERcomputational 148* 149* ===================================================================== 150 SUBROUTINE DOPMTR( SIDE, UPLO, TRANS, M, N, AP, TAU, C, LDC, WORK, 151 $ INFO ) 152* 153* -- LAPACK computational routine (version 3.7.0) -- 154* -- LAPACK is a software package provided by Univ. of Tennessee, -- 155* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 156* December 2016 157* 158* .. Scalar Arguments .. 159 CHARACTER SIDE, TRANS, UPLO 160 INTEGER INFO, LDC, M, N 161* .. 162* .. Array Arguments .. 163 DOUBLE PRECISION AP( * ), C( LDC, * ), TAU( * ), WORK( * ) 164* .. 165* 166* ===================================================================== 167* 168* .. Parameters .. 169 DOUBLE PRECISION ONE 170 PARAMETER ( ONE = 1.0D+0 ) 171* .. 172* .. Local Scalars .. 173 LOGICAL FORWRD, LEFT, NOTRAN, UPPER 174 INTEGER I, I1, I2, I3, IC, II, JC, MI, NI, NQ 175 DOUBLE PRECISION AII 176* .. 177* .. External Functions .. 178 LOGICAL LSAME 179 EXTERNAL LSAME 180* .. 181* .. External Subroutines .. 182 EXTERNAL DLARF, XERBLA 183* .. 184* .. Intrinsic Functions .. 185 INTRINSIC MAX 186* .. 187* .. Executable Statements .. 188* 189* Test the input arguments 190* 191 INFO = 0 192 LEFT = LSAME( SIDE, 'L' ) 193 NOTRAN = LSAME( TRANS, 'N' ) 194 UPPER = LSAME( UPLO, 'U' ) 195* 196* NQ is the order of Q 197* 198 IF( LEFT ) THEN 199 NQ = M 200 ELSE 201 NQ = N 202 END IF 203 IF( .NOT.LEFT .AND. .NOT.LSAME( SIDE, 'R' ) ) THEN 204 INFO = -1 205 ELSE IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN 206 INFO = -2 207 ELSE IF( .NOT.NOTRAN .AND. .NOT.LSAME( TRANS, 'T' ) ) THEN 208 INFO = -3 209 ELSE IF( M.LT.0 ) THEN 210 INFO = -4 211 ELSE IF( N.LT.0 ) THEN 212 INFO = -5 213 ELSE IF( LDC.LT.MAX( 1, M ) ) THEN 214 INFO = -9 215 END IF 216 IF( INFO.NE.0 ) THEN 217 CALL XERBLA( 'DOPMTR', -INFO ) 218 RETURN 219 END IF 220* 221* Quick return if possible 222* 223 IF( M.EQ.0 .OR. N.EQ.0 ) 224 $ RETURN 225* 226 IF( UPPER ) THEN 227* 228* Q was determined by a call to DSPTRD with UPLO = 'U' 229* 230 FORWRD = ( LEFT .AND. NOTRAN ) .OR. 231 $ ( .NOT.LEFT .AND. .NOT.NOTRAN ) 232* 233 IF( FORWRD ) THEN 234 I1 = 1 235 I2 = NQ - 1 236 I3 = 1 237 II = 2 238 ELSE 239 I1 = NQ - 1 240 I2 = 1 241 I3 = -1 242 II = NQ*( NQ+1 ) / 2 - 1 243 END IF 244* 245 IF( LEFT ) THEN 246 NI = N 247 ELSE 248 MI = M 249 END IF 250* 251 DO 10 I = I1, I2, I3 252 IF( LEFT ) THEN 253* 254* H(i) is applied to C(1:i,1:n) 255* 256 MI = I 257 ELSE 258* 259* H(i) is applied to C(1:m,1:i) 260* 261 NI = I 262 END IF 263* 264* Apply H(i) 265* 266 AII = AP( II ) 267 AP( II ) = ONE 268 CALL DLARF( SIDE, MI, NI, AP( II-I+1 ), 1, TAU( I ), C, LDC, 269 $ WORK ) 270 AP( II ) = AII 271* 272 IF( FORWRD ) THEN 273 II = II + I + 2 274 ELSE 275 II = II - I - 1 276 END IF 277 10 CONTINUE 278 ELSE 279* 280* Q was determined by a call to DSPTRD with UPLO = 'L'. 281* 282 FORWRD = ( LEFT .AND. .NOT.NOTRAN ) .OR. 283 $ ( .NOT.LEFT .AND. NOTRAN ) 284* 285 IF( FORWRD ) THEN 286 I1 = 1 287 I2 = NQ - 1 288 I3 = 1 289 II = 2 290 ELSE 291 I1 = NQ - 1 292 I2 = 1 293 I3 = -1 294 II = NQ*( NQ+1 ) / 2 - 1 295 END IF 296* 297 IF( LEFT ) THEN 298 NI = N 299 JC = 1 300 ELSE 301 MI = M 302 IC = 1 303 END IF 304* 305 DO 20 I = I1, I2, I3 306 AII = AP( II ) 307 AP( II ) = ONE 308 IF( LEFT ) THEN 309* 310* H(i) is applied to C(i+1:m,1:n) 311* 312 MI = M - I 313 IC = I + 1 314 ELSE 315* 316* H(i) is applied to C(1:m,i+1:n) 317* 318 NI = N - I 319 JC = I + 1 320 END IF 321* 322* Apply H(i) 323* 324 CALL DLARF( SIDE, MI, NI, AP( II ), 1, TAU( I ), 325 $ C( IC, JC ), LDC, WORK ) 326 AP( II ) = AII 327* 328 IF( FORWRD ) THEN 329 II = II + NQ - I + 1 330 ELSE 331 II = II - NQ + I - 2 332 END IF 333 20 CONTINUE 334 END IF 335 RETURN 336* 337* End of DOPMTR 338* 339 END 340