You can not select more than 25 topics Topics must start with a chinese character,a letter or number, can include dashes ('-') and can be up to 35 characters long.

slaror.c 17 kB

123456789101112131415161718192021222324252627282930313233343536373839404142434445464748495051525354555657585960616263646566676869707172737475767778798081828384858687888990919293949596979899100101102103104105106107108109110111112113114115116117118119120121122123124125126127128129130131132133134135136137138139140141142143144145146147148149150151152153154155156157158159160161162163164165166167168169170171172173174175176177178179180181182183184185186187188189190191192193194195196197198199200201202203204205206207208209210211212213214215216217218219220221222223224225226227228229230231232233234235236237238239240241242243244245246247248249250251252253254255256257258259260261262263264265266267268269270271272273274275276277278279280281282283284285286287288289290291292293294295296297298299300301302303304305306307308309310311312313314315316317318319320321322323324325326327328329330331332333334335336337338339340341342343344345346347348349350351352353354355356357358359360361362363364365366367368369370371372373374375376377378379380381382383384385386387388389390391392393394395396397398399400401402403404405406407408409410411412413414415416417418419420421422423424425426427428429430431432433434435436437438439440441442443444445446447448449450451452453454455456457458459460461462463464465466467468469470471472473474475476477478479480481482483484485486487488489490491492493494495496497498499500501502503504505506507508509510511512513514515516517518519520521522523524525526527528529530531532533534535536537538539540541542543544545546547548549550551552553554555556557558559560561562563564565566567568569570571572573574575576577578579580581582583584585586587588589590591592593594
  1. #include <math.h>
  2. #include <stdlib.h>
  3. #include <string.h>
  4. #include <stdio.h>
  5. #include <complex.h>
  6. #ifdef complex
  7. #undef complex
  8. #endif
  9. #ifdef I
  10. #undef I
  11. #endif
  12. #if defined(_WIN64)
  13. typedef long long BLASLONG;
  14. typedef unsigned long long BLASULONG;
  15. #else
  16. typedef long BLASLONG;
  17. typedef unsigned long BLASULONG;
  18. #endif
  19. #ifdef LAPACK_ILP64
  20. typedef BLASLONG blasint;
  21. #if defined(_WIN64)
  22. #define blasabs(x) llabs(x)
  23. #else
  24. #define blasabs(x) labs(x)
  25. #endif
  26. #else
  27. typedef int blasint;
  28. #define blasabs(x) abs(x)
  29. #endif
  30. typedef blasint integer;
  31. typedef unsigned int uinteger;
  32. typedef char *address;
  33. typedef short int shortint;
  34. typedef float real;
  35. typedef double doublereal;
  36. typedef struct { real r, i; } complex;
  37. typedef struct { doublereal r, i; } doublecomplex;
  38. #ifdef _MSC_VER
  39. static inline _Fcomplex Cf(complex *z) {_Fcomplex zz={z->r , z->i}; return zz;}
  40. static inline _Dcomplex Cd(doublecomplex *z) {_Dcomplex zz={z->r , z->i};return zz;}
  41. static inline _Fcomplex * _pCf(complex *z) {return (_Fcomplex*)z;}
  42. static inline _Dcomplex * _pCd(doublecomplex *z) {return (_Dcomplex*)z;}
  43. #else
  44. static inline _Complex float Cf(complex *z) {return z->r + z->i*_Complex_I;}
  45. static inline _Complex double Cd(doublecomplex *z) {return z->r + z->i*_Complex_I;}
  46. static inline _Complex float * _pCf(complex *z) {return (_Complex float*)z;}
  47. static inline _Complex double * _pCd(doublecomplex *z) {return (_Complex double*)z;}
  48. #endif
  49. #define pCf(z) (*_pCf(z))
  50. #define pCd(z) (*_pCd(z))
  51. typedef int logical;
  52. typedef short int shortlogical;
  53. typedef char logical1;
  54. typedef char integer1;
  55. #define TRUE_ (1)
  56. #define FALSE_ (0)
  57. /* Extern is for use with -E */
  58. #ifndef Extern
  59. #define Extern extern
  60. #endif
  61. /* I/O stuff */
  62. typedef int flag;
  63. typedef int ftnlen;
  64. typedef int ftnint;
  65. /*external read, write*/
  66. typedef struct
  67. { flag cierr;
  68. ftnint ciunit;
  69. flag ciend;
  70. char *cifmt;
  71. ftnint cirec;
  72. } cilist;
  73. /*internal read, write*/
  74. typedef struct
  75. { flag icierr;
  76. char *iciunit;
  77. flag iciend;
  78. char *icifmt;
  79. ftnint icirlen;
  80. ftnint icirnum;
  81. } icilist;
  82. /*open*/
  83. typedef struct
  84. { flag oerr;
  85. ftnint ounit;
  86. char *ofnm;
  87. ftnlen ofnmlen;
  88. char *osta;
  89. char *oacc;
  90. char *ofm;
  91. ftnint orl;
  92. char *oblnk;
  93. } olist;
  94. /*close*/
  95. typedef struct
  96. { flag cerr;
  97. ftnint cunit;
  98. char *csta;
  99. } cllist;
  100. /*rewind, backspace, endfile*/
  101. typedef struct
  102. { flag aerr;
  103. ftnint aunit;
  104. } alist;
  105. /* inquire */
  106. typedef struct
  107. { flag inerr;
  108. ftnint inunit;
  109. char *infile;
  110. ftnlen infilen;
  111. ftnint *inex; /*parameters in standard's order*/
  112. ftnint *inopen;
  113. ftnint *innum;
  114. ftnint *innamed;
  115. char *inname;
  116. ftnlen innamlen;
  117. char *inacc;
  118. ftnlen inacclen;
  119. char *inseq;
  120. ftnlen inseqlen;
  121. char *indir;
  122. ftnlen indirlen;
  123. char *infmt;
  124. ftnlen infmtlen;
  125. char *inform;
  126. ftnint informlen;
  127. char *inunf;
  128. ftnlen inunflen;
  129. ftnint *inrecl;
  130. ftnint *innrec;
  131. char *inblank;
  132. ftnlen inblanklen;
  133. } inlist;
  134. #define VOID void
  135. union Multitype { /* for multiple entry points */
  136. integer1 g;
  137. shortint h;
  138. integer i;
  139. /* longint j; */
  140. real r;
  141. doublereal d;
  142. complex c;
  143. doublecomplex z;
  144. };
  145. typedef union Multitype Multitype;
  146. struct Vardesc { /* for Namelist */
  147. char *name;
  148. char *addr;
  149. ftnlen *dims;
  150. int type;
  151. };
  152. typedef struct Vardesc Vardesc;
  153. struct Namelist {
  154. char *name;
  155. Vardesc **vars;
  156. int nvars;
  157. };
  158. typedef struct Namelist Namelist;
  159. #define abs(x) ((x) >= 0 ? (x) : -(x))
  160. #define dabs(x) (fabs(x))
  161. #define f2cmin(a,b) ((a) <= (b) ? (a) : (b))
  162. #define f2cmax(a,b) ((a) >= (b) ? (a) : (b))
  163. #define dmin(a,b) (f2cmin(a,b))
  164. #define dmax(a,b) (f2cmax(a,b))
  165. #define bit_test(a,b) ((a) >> (b) & 1)
  166. #define bit_clear(a,b) ((a) & ~((uinteger)1 << (b)))
  167. #define bit_set(a,b) ((a) | ((uinteger)1 << (b)))
  168. #define abort_() { sig_die("Fortran abort routine called", 1); }
  169. #define c_abs(z) (cabsf(Cf(z)))
  170. #define c_cos(R,Z) { pCf(R)=ccos(Cf(Z)); }
  171. #ifdef _MSC_VER
  172. #define c_div(c, a, b) {Cf(c)._Val[0] = (Cf(a)._Val[0]/Cf(b)._Val[0]); Cf(c)._Val[1]=(Cf(a)._Val[1]/Cf(b)._Val[1]);}
  173. #define z_div(c, a, b) {Cd(c)._Val[0] = (Cd(a)._Val[0]/Cd(b)._Val[0]); Cd(c)._Val[1]=(Cd(a)._Val[1]/df(b)._Val[1]);}
  174. #else
  175. #define c_div(c, a, b) {pCf(c) = Cf(a)/Cf(b);}
  176. #define z_div(c, a, b) {pCd(c) = Cd(a)/Cd(b);}
  177. #endif
  178. #define c_exp(R, Z) {pCf(R) = cexpf(Cf(Z));}
  179. #define c_log(R, Z) {pCf(R) = clogf(Cf(Z));}
  180. #define c_sin(R, Z) {pCf(R) = csinf(Cf(Z));}
  181. //#define c_sqrt(R, Z) {*(R) = csqrtf(Cf(Z));}
  182. #define c_sqrt(R, Z) {pCf(R) = csqrtf(Cf(Z));}
  183. #define d_abs(x) (fabs(*(x)))
  184. #define d_acos(x) (acos(*(x)))
  185. #define d_asin(x) (asin(*(x)))
  186. #define d_atan(x) (atan(*(x)))
  187. #define d_atn2(x, y) (atan2(*(x),*(y)))
  188. #define d_cnjg(R, Z) { pCd(R) = conj(Cd(Z)); }
  189. #define r_cnjg(R, Z) { pCf(R) = conjf(Cf(Z)); }
  190. #define d_cos(x) (cos(*(x)))
  191. #define d_cosh(x) (cosh(*(x)))
  192. #define d_dim(__a, __b) ( *(__a) > *(__b) ? *(__a) - *(__b) : 0.0 )
  193. #define d_exp(x) (exp(*(x)))
  194. #define d_imag(z) (cimag(Cd(z)))
  195. #define r_imag(z) (cimagf(Cf(z)))
  196. #define d_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
  197. #define r_int(__x) (*(__x)>0 ? floor(*(__x)) : -floor(- *(__x)))
  198. #define d_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
  199. #define r_lg10(x) ( 0.43429448190325182765 * log(*(x)) )
  200. #define d_log(x) (log(*(x)))
  201. #define d_mod(x, y) (fmod(*(x), *(y)))
  202. #define u_nint(__x) ((__x)>=0 ? floor((__x) + .5) : -floor(.5 - (__x)))
  203. #define d_nint(x) u_nint(*(x))
  204. #define u_sign(__a,__b) ((__b) >= 0 ? ((__a) >= 0 ? (__a) : -(__a)) : -((__a) >= 0 ? (__a) : -(__a)))
  205. #define d_sign(a,b) u_sign(*(a),*(b))
  206. #define r_sign(a,b) u_sign(*(a),*(b))
  207. #define d_sin(x) (sin(*(x)))
  208. #define d_sinh(x) (sinh(*(x)))
  209. #define d_sqrt(x) (sqrt(*(x)))
  210. #define d_tan(x) (tan(*(x)))
  211. #define d_tanh(x) (tanh(*(x)))
  212. #define i_abs(x) abs(*(x))
  213. #define i_dnnt(x) ((integer)u_nint(*(x)))
  214. #define i_len(s, n) (n)
  215. #define i_nint(x) ((integer)u_nint(*(x)))
  216. #define i_sign(a,b) ((integer)u_sign((integer)*(a),(integer)*(b)))
  217. #define pow_dd(ap, bp) ( pow(*(ap), *(bp)))
  218. #define pow_si(B,E) spow_ui(*(B),*(E))
  219. #define pow_ri(B,E) spow_ui(*(B),*(E))
  220. #define pow_di(B,E) dpow_ui(*(B),*(E))
  221. #define pow_zi(p, a, b) {pCd(p) = zpow_ui(Cd(a), *(b));}
  222. #define pow_ci(p, a, b) {pCf(p) = cpow_ui(Cf(a), *(b));}
  223. #define pow_zz(R,A,B) {pCd(R) = cpow(Cd(A),*(B));}
  224. #define s_cat(lpp, rpp, rnp, np, llp) { ftnlen i, nc, ll; char *f__rp, *lp; ll = (llp); lp = (lpp); for(i=0; i < (int)*(np); ++i) { nc = ll; if((rnp)[i] < nc) nc = (rnp)[i]; ll -= nc; f__rp = (rpp)[i]; while(--nc >= 0) *lp++ = *(f__rp)++; } while(--ll >= 0) *lp++ = ' '; }
  225. #define s_cmp(a,b,c,d) ((integer)strncmp((a),(b),f2cmin((c),(d))))
  226. #define s_copy(A,B,C,D) { int __i,__m; for (__i=0, __m=f2cmin((C),(D)); __i<__m && (B)[__i] != 0; ++__i) (A)[__i] = (B)[__i]; }
  227. #define sig_die(s, kill) { exit(1); }
  228. #define s_stop(s, n) {exit(0);}
  229. #define z_abs(z) (cabs(Cd(z)))
  230. #define z_exp(R, Z) {pCd(R) = cexp(Cd(Z));}
  231. #define z_sqrt(R, Z) {pCd(R) = csqrt(Cd(Z));}
  232. #define myexit_() break;
  233. #define mycycle() continue;
  234. #define myceiling(w) {ceil(w)}
  235. #define myhuge(w) {HUGE_VAL}
  236. //#define mymaxloc_(w,s,e,n) {if (sizeof(*(w)) == sizeof(double)) dmaxloc_((w),*(s),*(e),n); else dmaxloc_((w),*(s),*(e),n);}
  237. #define mymaxloc(w,s,e,n) {dmaxloc_(w,*(s),*(e),n)}
  238. /* procedure parameter types for -A and -C++ */
  239. #define F2C_proc_par_types 1
  240. /* Table of constant values */
  241. static real c_b9 = 0.f;
  242. static real c_b10 = 1.f;
  243. static integer c__3 = 3;
  244. static integer c__1 = 1;
  245. /* > \brief \b SLAROR */
  246. /* =========== DOCUMENTATION =========== */
  247. /* Online html documentation available at */
  248. /* http://www.netlib.org/lapack/explore-html/ */
  249. /* Definition: */
  250. /* =========== */
  251. /* SUBROUTINE SLAROR( SIDE, INIT, M, N, A, LDA, ISEED, X, INFO ) */
  252. /* CHARACTER INIT, SIDE */
  253. /* INTEGER INFO, LDA, M, N */
  254. /* INTEGER ISEED( 4 ) */
  255. /* REAL A( LDA, * ), X( * ) */
  256. /* > \par Purpose: */
  257. /* ============= */
  258. /* > */
  259. /* > \verbatim */
  260. /* > */
  261. /* > SLAROR pre- or post-multiplies an M by N matrix A by a random */
  262. /* > orthogonal matrix U, overwriting A. A may optionally be initialized */
  263. /* > to the identity matrix before multiplying by U. U is generated using */
  264. /* > the method of G.W. Stewart (SIAM J. Numer. Anal. 17, 1980, 403-409). */
  265. /* > \endverbatim */
  266. /* Arguments: */
  267. /* ========== */
  268. /* > \param[in] SIDE */
  269. /* > \verbatim */
  270. /* > SIDE is CHARACTER*1 */
  271. /* > Specifies whether A is multiplied on the left or right by U. */
  272. /* > = 'L': Multiply A on the left (premultiply) by U */
  273. /* > = 'R': Multiply A on the right (postmultiply) by U' */
  274. /* > = 'C' or 'T': Multiply A on the left by U and the right */
  275. /* > by U' (Here, U' means U-transpose.) */
  276. /* > \endverbatim */
  277. /* > */
  278. /* > \param[in] INIT */
  279. /* > \verbatim */
  280. /* > INIT is CHARACTER*1 */
  281. /* > Specifies whether or not A should be initialized to the */
  282. /* > identity matrix. */
  283. /* > = 'I': Initialize A to (a section of) the identity matrix */
  284. /* > before applying U. */
  285. /* > = 'N': No initialization. Apply U to the input matrix A. */
  286. /* > */
  287. /* > INIT = 'I' may be used to generate square or rectangular */
  288. /* > orthogonal matrices: */
  289. /* > */
  290. /* > For M = N and SIDE = 'L' or 'R', the rows will be orthogonal */
  291. /* > to each other, as will the columns. */
  292. /* > */
  293. /* > If M < N, SIDE = 'R' produces a dense matrix whose rows are */
  294. /* > orthogonal and whose columns are not, while SIDE = 'L' */
  295. /* > produces a matrix whose rows are orthogonal, and whose first */
  296. /* > M columns are orthogonal, and whose remaining columns are */
  297. /* > zero. */
  298. /* > */
  299. /* > If M > N, SIDE = 'L' produces a dense matrix whose columns */
  300. /* > are orthogonal and whose rows are not, while SIDE = 'R' */
  301. /* > produces a matrix whose columns are orthogonal, and whose */
  302. /* > first M rows are orthogonal, and whose remaining rows are */
  303. /* > zero. */
  304. /* > \endverbatim */
  305. /* > */
  306. /* > \param[in] M */
  307. /* > \verbatim */
  308. /* > M is INTEGER */
  309. /* > The number of rows of A. */
  310. /* > \endverbatim */
  311. /* > */
  312. /* > \param[in] N */
  313. /* > \verbatim */
  314. /* > N is INTEGER */
  315. /* > The number of columns of A. */
  316. /* > \endverbatim */
  317. /* > */
  318. /* > \param[in,out] A */
  319. /* > \verbatim */
  320. /* > A is REAL array, dimension (LDA, N) */
  321. /* > On entry, the array A. */
  322. /* > On exit, overwritten by U A ( if SIDE = 'L' ), */
  323. /* > or by A U ( if SIDE = 'R' ), */
  324. /* > or by U A U' ( if SIDE = 'C' or 'T'). */
  325. /* > \endverbatim */
  326. /* > */
  327. /* > \param[in] LDA */
  328. /* > \verbatim */
  329. /* > LDA is INTEGER */
  330. /* > The leading dimension of the array A. LDA >= f2cmax(1,M). */
  331. /* > \endverbatim */
  332. /* > */
  333. /* > \param[in,out] ISEED */
  334. /* > \verbatim */
  335. /* > ISEED is INTEGER array, dimension (4) */
  336. /* > On entry ISEED specifies the seed of the random number */
  337. /* > generator. The array elements should be between 0 and 4095; */
  338. /* > if not they will be reduced mod 4096. Also, ISEED(4) must */
  339. /* > be odd. The random number generator uses a linear */
  340. /* > congruential sequence limited to small integers, and so */
  341. /* > should produce machine independent random numbers. The */
  342. /* > values of ISEED are changed on exit, and can be used in the */
  343. /* > next call to SLAROR to continue the same random number */
  344. /* > sequence. */
  345. /* > \endverbatim */
  346. /* > */
  347. /* > \param[out] X */
  348. /* > \verbatim */
  349. /* > X is REAL array, dimension (3*MAX( M, N )) */
  350. /* > Workspace of length */
  351. /* > 2*M + N if SIDE = 'L', */
  352. /* > 2*N + M if SIDE = 'R', */
  353. /* > 3*N if SIDE = 'C' or 'T'. */
  354. /* > \endverbatim */
  355. /* > */
  356. /* > \param[out] INFO */
  357. /* > \verbatim */
  358. /* > INFO is INTEGER */
  359. /* > An error flag. It is set to: */
  360. /* > = 0: normal return */
  361. /* > < 0: if INFO = -k, the k-th argument had an illegal value */
  362. /* > = 1: if the random numbers generated by SLARND are bad. */
  363. /* > \endverbatim */
  364. /* Authors: */
  365. /* ======== */
  366. /* > \author Univ. of Tennessee */
  367. /* > \author Univ. of California Berkeley */
  368. /* > \author Univ. of Colorado Denver */
  369. /* > \author NAG Ltd. */
  370. /* > \date December 2016 */
  371. /* > \ingroup real_matgen */
  372. /* ===================================================================== */
  373. /* Subroutine */ void slaror_(char *side, char *init, integer *m, integer *n,
  374. real *a, integer *lda, integer *iseed, real *x, integer *info)
  375. {
  376. /* System generated locals */
  377. integer a_dim1, a_offset, i__1, i__2;
  378. real r__1;
  379. /* Local variables */
  380. integer kbeg, jcol;
  381. extern /* Subroutine */ void sger_(integer *, integer *, real *, real *,
  382. integer *, real *, integer *, real *, integer *);
  383. integer irow;
  384. extern real snrm2_(integer *, real *, integer *);
  385. integer j;
  386. extern logical lsame_(char *, char *);
  387. extern /* Subroutine */ void sscal_(integer *, real *, real *, integer *),
  388. sgemv_(char *, integer *, integer *, real *, real *, integer *,
  389. real *, integer *, real *, real *, integer *);
  390. integer ixfrm, itype, nxfrm;
  391. real xnorm;
  392. extern /* Subroutine */ int xerbla_(char *, integer *, ftnlen);
  393. real factor;
  394. extern real slarnd_(integer *, integer *);
  395. extern /* Subroutine */ void slaset_(char *, integer *, integer *, real *,
  396. real *, real *, integer *);
  397. real xnorms;
  398. /* -- LAPACK auxiliary routine (version 3.7.0) -- */
  399. /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
  400. /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
  401. /* December 2016 */
  402. /* ===================================================================== */
  403. /* Parameter adjustments */
  404. a_dim1 = *lda;
  405. a_offset = 1 + a_dim1 * 1;
  406. a -= a_offset;
  407. --iseed;
  408. --x;
  409. /* Function Body */
  410. *info = 0;
  411. if (*n == 0 || *m == 0) {
  412. return;
  413. }
  414. itype = 0;
  415. if (lsame_(side, "L")) {
  416. itype = 1;
  417. } else if (lsame_(side, "R")) {
  418. itype = 2;
  419. } else if (lsame_(side, "C") || lsame_(side, "T")) {
  420. itype = 3;
  421. }
  422. /* Check for argument errors. */
  423. if (itype == 0) {
  424. *info = -1;
  425. } else if (*m < 0) {
  426. *info = -3;
  427. } else if (*n < 0 || itype == 3 && *n != *m) {
  428. *info = -4;
  429. } else if (*lda < *m) {
  430. *info = -6;
  431. }
  432. if (*info != 0) {
  433. i__1 = -(*info);
  434. xerbla_("SLAROR", &i__1, 6);
  435. return;
  436. }
  437. if (itype == 1) {
  438. nxfrm = *m;
  439. } else {
  440. nxfrm = *n;
  441. }
  442. /* Initialize A to the identity matrix if desired */
  443. if (lsame_(init, "I")) {
  444. slaset_("Full", m, n, &c_b9, &c_b10, &a[a_offset], lda);
  445. }
  446. /* If no rotation possible, multiply by random +/-1 */
  447. /* Compute rotation by computing Householder transformations */
  448. /* H(2), H(3), ..., H(nhouse) */
  449. i__1 = nxfrm;
  450. for (j = 1; j <= i__1; ++j) {
  451. x[j] = 0.f;
  452. /* L10: */
  453. }
  454. i__1 = nxfrm;
  455. for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) {
  456. kbeg = nxfrm - ixfrm + 1;
  457. /* Generate independent normal( 0, 1 ) random numbers */
  458. i__2 = nxfrm;
  459. for (j = kbeg; j <= i__2; ++j) {
  460. x[j] = slarnd_(&c__3, &iseed[1]);
  461. /* L20: */
  462. }
  463. /* Generate a Householder transformation from the random vector X */
  464. xnorm = snrm2_(&ixfrm, &x[kbeg], &c__1);
  465. xnorms = r_sign(&xnorm, &x[kbeg]);
  466. r__1 = -x[kbeg];
  467. x[kbeg + nxfrm] = r_sign(&c_b10, &r__1);
  468. factor = xnorms * (xnorms + x[kbeg]);
  469. if (abs(factor) < 1e-20f) {
  470. *info = 1;
  471. xerbla_("SLAROR", info, 6);
  472. return;
  473. } else {
  474. factor = 1.f / factor;
  475. }
  476. x[kbeg] += xnorms;
  477. /* Apply Householder transformation to A */
  478. if (itype == 1 || itype == 3) {
  479. /* Apply H(k) from the left. */
  480. sgemv_("T", &ixfrm, n, &c_b10, &a[kbeg + a_dim1], lda, &x[kbeg], &
  481. c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1);
  482. r__1 = -factor;
  483. sger_(&ixfrm, n, &r__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], &
  484. c__1, &a[kbeg + a_dim1], lda);
  485. }
  486. if (itype == 2 || itype == 3) {
  487. /* Apply H(k) from the right. */
  488. sgemv_("N", m, &ixfrm, &c_b10, &a[kbeg * a_dim1 + 1], lda, &x[
  489. kbeg], &c__1, &c_b9, &x[(nxfrm << 1) + 1], &c__1);
  490. r__1 = -factor;
  491. sger_(m, &ixfrm, &r__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], &
  492. c__1, &a[kbeg * a_dim1 + 1], lda);
  493. }
  494. /* L30: */
  495. }
  496. r__1 = slarnd_(&c__3, &iseed[1]);
  497. x[nxfrm * 2] = r_sign(&c_b10, &r__1);
  498. /* Scale the matrix A by D. */
  499. if (itype == 1 || itype == 3) {
  500. i__1 = *m;
  501. for (irow = 1; irow <= i__1; ++irow) {
  502. sscal_(n, &x[nxfrm + irow], &a[irow + a_dim1], lda);
  503. /* L40: */
  504. }
  505. }
  506. if (itype == 2 || itype == 3) {
  507. i__1 = *n;
  508. for (jcol = 1; jcol <= i__1; ++jcol) {
  509. sscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1);
  510. /* L50: */
  511. }
  512. }
  513. return;
  514. /* End of SLAROR */
  515. } /* slaror_ */