1 /* -- translated by f2c (version 20191129). 2 You must link the resulting object file with libf2c: 3 on Microsoft Windows system, link with libf2c.lib; 4 on Linux or Unix systems, link with .../path/to/libf2c.a -lm 5 or, if you install libf2c.a in a standard place, with -lf2c -lm 6 -- in that order, at the end of the command line, as in 7 cc *.o -lf2c -lm 8 Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., 9 10 http://www.netlib.org/f2c/libf2c.zip 11 */ 12 13 #include "f2c.h" 14 15 /* Table of constant values */ 16 17 static integer c__1 = 1; 18 static integer c_n1 = -1; 19 static integer c__2 = 2; 20 21 /* > \brief \b DORMTR 22 23 =========== DOCUMENTATION =========== 24 25 Online html documentation available at 26 http://www.netlib.org/lapack/explore-html/ 27 28 > \htmlonly 29 > Download DORMTR + dependencies 30 > <a href="http://www.netlib.org/cgi-bin/netlibfiles.tgz?format=tgz&filename=/lapack/lapack_routine/dormtr. 31 f"> 32 > [TGZ]</a> 33 > <a href="http://www.netlib.org/cgi-bin/netlibfiles.zip?format=zip&filename=/lapack/lapack_routine/dormtr. 34 f"> 35 > [ZIP]</a> 36 > <a href="http://www.netlib.org/cgi-bin/netlibfiles.txt?format=txt&filename=/lapack/lapack_routine/dormtr. 37 f"> 38 > [TXT]</a> 39 > \endhtmlonly 40 41 Definition: 42 =========== 43 44 SUBROUTINE DORMTR( SIDE, UPLO, TRANS, M, N, A, LDA, TAU, C, LDC, 45 WORK, LWORK, INFO ) 46 47 CHARACTER SIDE, TRANS, UPLO 48 INTEGER INFO, LDA, LDC, LWORK, M, N 49 DOUBLE PRECISION A( LDA, * ), C( LDC, * ), TAU( * ), WORK( * ) 50 51 52 > \par Purpose: 53 ============= 54 > 55 > \verbatim 56 > 57 > DORMTR overwrites the general real M-by-N matrix C with 58 > 59 > SIDE = 'L' SIDE = 'R' 60 > TRANS = 'N': Q * C C * Q 61 > TRANS = 'T': Q**T * C C * Q**T 62 > 63 > where Q is a real orthogonal matrix of order nq, with nq = m if 64 > SIDE = 'L' and nq = n if SIDE = 'R'. Q is defined as the product of 65 > nq-1 elementary reflectors, as returned by DSYTRD: 66 > 67 > if UPLO = 'U', Q = H(nq-1) . . . H(2) H(1); 68 > 69 > if UPLO = 'L', Q = H(1) H(2) . . . H(nq-1). 70 > \endverbatim 71 72 Arguments: 73 ========== 74 75 > \param[in] SIDE 76 > \verbatim 77 > SIDE is CHARACTER*1 78 > = 'L': apply Q or Q**T from the Left; 79 > = 'R': apply Q or Q**T from the Right. 80 > \endverbatim 81 > 82 > \param[in] UPLO 83 > \verbatim 84 > UPLO is CHARACTER*1 85 > = 'U': Upper triangle of A contains elementary reflectors 86 > from DSYTRD; 87 > = 'L': Lower triangle of A contains elementary reflectors 88 > from DSYTRD. 89 > \endverbatim 90 > 91 > \param[in] TRANS 92 > \verbatim 93 > TRANS is CHARACTER*1 94 > = 'N': No transpose, apply Q; 95 > = 'T': Transpose, apply Q**T. 96 > \endverbatim 97 > 98 > \param[in] M 99 > \verbatim 100 > M is INTEGER 101 > The number of rows of the matrix C. M >= 0. 102 > \endverbatim 103 > 104 > \param[in] N 105 > \verbatim 106 > N is INTEGER 107 > The number of columns of the matrix C. N >= 0. 108 > \endverbatim 109 > 110 > \param[in] A 111 > \verbatim 112 > A is DOUBLE PRECISION array, dimension 113 > (LDA,M) if SIDE = 'L' 114 > (LDA,N) if SIDE = 'R' 115 > The vectors which define the elementary reflectors, as 116 > returned by DSYTRD. 117 > \endverbatim 118 > 119 > \param[in] LDA 120 > \verbatim 121 > LDA is INTEGER 122 > The leading dimension of the array A. 123 > LDA >= max(1,M) if SIDE = 'L'; LDA >= max(1,N) if SIDE = 'R'. 124 > \endverbatim 125 > 126 > \param[in] TAU 127 > \verbatim 128 > TAU is DOUBLE PRECISION array, dimension 129 > (M-1) if SIDE = 'L' 130 > (N-1) if SIDE = 'R' 131 > TAU(i) must contain the scalar factor of the elementary 132 > reflector H(i), as returned by DSYTRD. 133 > \endverbatim 134 > 135 > \param[in,out] C 136 > \verbatim 137 > C is DOUBLE PRECISION array, dimension (LDC,N) 138 > On entry, the M-by-N matrix C. 139 > On exit, C is overwritten by Q*C or Q**T*C or C*Q**T or C*Q. 140 > \endverbatim 141 > 142 > \param[in] LDC 143 > \verbatim 144 > LDC is INTEGER 145 > The leading dimension of the array C. LDC >= max(1,M). 146 > \endverbatim 147 > 148 > \param[out] WORK 149 > \verbatim 150 > WORK is DOUBLE PRECISION array, dimension (MAX(1,LWORK)) 151 > On exit, if INFO = 0, WORK(1) returns the optimal LWORK. 152 > \endverbatim 153 > 154 > \param[in] LWORK 155 > \verbatim 156 > LWORK is INTEGER 157 > The dimension of the array WORK. 158 > If SIDE = 'L', LWORK >= max(1,N); 159 > if SIDE = 'R', LWORK >= max(1,M). 160 > For optimum performance LWORK >= N*NB if SIDE = 'L', and 161 > LWORK >= M*NB if SIDE = 'R', where NB is the optimal 162 > blocksize. 163 > 164 > If LWORK = -1, then a workspace query is assumed; the routine 165 > only calculates the optimal size of the WORK array, returns 166 > this value as the first entry of the WORK array, and no error 167 > message related to LWORK is issued by XERBLA. 168 > \endverbatim 169 > 170 > \param[out] INFO 171 > \verbatim 172 > INFO is INTEGER 173 > = 0: successful exit 174 > < 0: if INFO = -i, the i-th argument had an illegal value 175 > \endverbatim 176 177 Authors: 178 ======== 179 180 > \author Univ. of Tennessee 181 > \author Univ. of California Berkeley 182 > \author Univ. of Colorado Denver 183 > \author NAG Ltd. 184 185 > \date November 2011 186 187 > \ingroup doubleOTHERcomputational 188 189 ===================================================================== igraphdormtr_(char * side,char * uplo,char * trans,integer * m,integer * n,doublereal * a,integer * lda,doublereal * tau,doublereal * c__,integer * ldc,doublereal * work,integer * lwork,integer * info)190 Subroutine */ int igraphdormtr_(char *side, char *uplo, char *trans, integer *m, 191 integer *n, doublereal *a, integer *lda, doublereal *tau, doublereal * 192 c__, integer *ldc, doublereal *work, integer *lwork, integer *info) 193 { 194 /* System generated locals */ 195 address a__1[2]; 196 integer a_dim1, a_offset, c_dim1, c_offset, i__1[2], i__2, i__3; 197 char ch__1[2]; 198 199 /* Builtin functions 200 Subroutine */ int s_cat(char *, char **, integer *, integer *, ftnlen); 201 202 /* Local variables */ 203 integer i1, i2, nb, mi, ni, nq, nw; 204 logical left; 205 extern logical igraphlsame_(char *, char *); 206 integer iinfo; 207 logical upper; 208 extern /* Subroutine */ int igraphxerbla_(char *, integer *, ftnlen); 209 extern integer igraphilaenv_(integer *, char *, char *, integer *, integer *, 210 integer *, integer *, ftnlen, ftnlen); 211 extern /* Subroutine */ int igraphdormql_(char *, char *, integer *, integer *, 212 integer *, doublereal *, integer *, doublereal *, doublereal *, 213 integer *, doublereal *, integer *, integer *), 214 igraphdormqr_(char *, char *, integer *, integer *, integer *, 215 doublereal *, integer *, doublereal *, doublereal *, integer *, 216 doublereal *, integer *, integer *); 217 integer lwkopt; 218 logical lquery; 219 220 221 /* -- LAPACK computational routine (version 3.4.0) -- 222 -- LAPACK is a software package provided by Univ. of Tennessee, -- 223 -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- 224 November 2011 225 226 227 ===================================================================== 228 229 230 Test the input arguments 231 232 Parameter adjustments */ 233 a_dim1 = *lda; 234 a_offset = 1 + a_dim1; 235 a -= a_offset; 236 --tau; 237 c_dim1 = *ldc; 238 c_offset = 1 + c_dim1; 239 c__ -= c_offset; 240 --work; 241 242 /* Function Body */ 243 *info = 0; 244 left = igraphlsame_(side, "L"); 245 upper = igraphlsame_(uplo, "U"); 246 lquery = *lwork == -1; 247 248 /* NQ is the order of Q and NW is the minimum dimension of WORK */ 249 250 if (left) { 251 nq = *m; 252 nw = *n; 253 } else { 254 nq = *n; 255 nw = *m; 256 } 257 if (! left && ! igraphlsame_(side, "R")) { 258 *info = -1; 259 } else if (! upper && ! igraphlsame_(uplo, "L")) { 260 *info = -2; 261 } else if (! igraphlsame_(trans, "N") && ! igraphlsame_(trans, 262 "T")) { 263 *info = -3; 264 } else if (*m < 0) { 265 *info = -4; 266 } else if (*n < 0) { 267 *info = -5; 268 } else if (*lda < max(1,nq)) { 269 *info = -7; 270 } else if (*ldc < max(1,*m)) { 271 *info = -10; 272 } else if (*lwork < max(1,nw) && ! lquery) { 273 *info = -12; 274 } 275 276 if (*info == 0) { 277 if (upper) { 278 if (left) { 279 /* Writing concatenation */ 280 i__1[0] = 1, a__1[0] = side; 281 i__1[1] = 1, a__1[1] = trans; 282 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); 283 i__2 = *m - 1; 284 i__3 = *m - 1; 285 nb = igraphilaenv_(&c__1, "DORMQL", ch__1, &i__2, n, &i__3, &c_n1, ( 286 ftnlen)6, (ftnlen)2); 287 } else { 288 /* Writing concatenation */ 289 i__1[0] = 1, a__1[0] = side; 290 i__1[1] = 1, a__1[1] = trans; 291 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); 292 i__2 = *n - 1; 293 i__3 = *n - 1; 294 nb = igraphilaenv_(&c__1, "DORMQL", ch__1, m, &i__2, &i__3, &c_n1, ( 295 ftnlen)6, (ftnlen)2); 296 } 297 } else { 298 if (left) { 299 /* Writing concatenation */ 300 i__1[0] = 1, a__1[0] = side; 301 i__1[1] = 1, a__1[1] = trans; 302 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); 303 i__2 = *m - 1; 304 i__3 = *m - 1; 305 nb = igraphilaenv_(&c__1, "DORMQR", ch__1, &i__2, n, &i__3, &c_n1, ( 306 ftnlen)6, (ftnlen)2); 307 } else { 308 /* Writing concatenation */ 309 i__1[0] = 1, a__1[0] = side; 310 i__1[1] = 1, a__1[1] = trans; 311 s_cat(ch__1, a__1, i__1, &c__2, (ftnlen)2); 312 i__2 = *n - 1; 313 i__3 = *n - 1; 314 nb = igraphilaenv_(&c__1, "DORMQR", ch__1, m, &i__2, &i__3, &c_n1, ( 315 ftnlen)6, (ftnlen)2); 316 } 317 } 318 lwkopt = max(1,nw) * nb; 319 work[1] = (doublereal) lwkopt; 320 } 321 322 if (*info != 0) { 323 i__2 = -(*info); 324 igraphxerbla_("DORMTR", &i__2, (ftnlen)6); 325 return 0; 326 } else if (lquery) { 327 return 0; 328 } 329 330 /* Quick return if possible */ 331 332 if (*m == 0 || *n == 0 || nq == 1) { 333 work[1] = 1.; 334 return 0; 335 } 336 337 if (left) { 338 mi = *m - 1; 339 ni = *n; 340 } else { 341 mi = *m; 342 ni = *n - 1; 343 } 344 345 if (upper) { 346 347 /* Q was determined by a call to DSYTRD with UPLO = 'U' */ 348 349 i__2 = nq - 1; 350 igraphdormql_(side, trans, &mi, &ni, &i__2, &a[(a_dim1 << 1) + 1], lda, & 351 tau[1], &c__[c_offset], ldc, &work[1], lwork, &iinfo); 352 } else { 353 354 /* Q was determined by a call to DSYTRD with UPLO = 'L' */ 355 356 if (left) { 357 i1 = 2; 358 i2 = 1; 359 } else { 360 i1 = 1; 361 i2 = 2; 362 } 363 i__2 = nq - 1; 364 igraphdormqr_(side, trans, &mi, &ni, &i__2, &a[a_dim1 + 2], lda, &tau[1], & 365 c__[i1 + i2 * c_dim1], ldc, &work[1], lwork, &iinfo); 366 } 367 work[1] = (doublereal) lwkopt; 368 return 0; 369 370 /* End of DORMTR */ 371 372 } /* igraphdormtr_ */ 373 374