/* -- translated by f2c (version 19940927). You must link the resulting object file with the libraries: -lf2c -lm (in that order) */ #include #include "f2c.h" /* Table of constant values */ static doublecomplex c_b1 = {0.,0.}; static doublecomplex c_b2 = {1.,0.}; static integer c__3 = 3; static integer c__1 = 1; /* Subroutine */ int zlaror_slu(char *side, char *init, integer *m, integer *n, doublecomplex *a, integer *lda, integer *iseed, doublecomplex *x, integer *info) { /* System generated locals */ integer a_dim1, a_offset, i__1, i__2, i__3; doublecomplex z__1, z__2; /* Builtin functions */ double z_abs(doublecomplex *); void d_cnjg(doublecomplex *, doublecomplex *); /* Local variables */ static integer kbeg, jcol; static doublereal xabs; static integer irow, j; static doublecomplex csign; extern /* Subroutine */ int zgerc_(integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, integer *), zscal_(integer *, doublecomplex *, doublecomplex *, integer *); static integer ixfrm; extern /* Subroutine */ int zgemv_(char *, integer *, integer *, doublecomplex *, doublecomplex *, integer *, doublecomplex *, integer *, doublecomplex *, doublecomplex *, integer *); static integer itype, nxfrm; static doublereal xnorm; extern doublereal dznrm2_(integer *, doublecomplex *, integer *); extern int input_error(char *, int *); static doublereal factor; extern /* Subroutine */ int zlacgv_slu(integer *, doublecomplex *, integer *) ; extern /* Double Complex */ VOID zlarnd_slu(doublecomplex *, integer *, integer *); extern /* Subroutine */ int zlaset_slu(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *); static doublecomplex xnorms; /* -- LAPACK auxiliary test routine (version 2.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= ZLAROR pre- or post-multiplies an M by N matrix A by a random unitary matrix U, overwriting A. A may optionally be initialized to the identity matrix before multiplying by U. U is generated using the method of G.W. Stewart ( SIAM J. Numer. Anal. 17, 1980, pp. 403-409 ). (BLAS-2 version) Arguments ========= SIDE - CHARACTER*1 SIDE specifies whether A is multiplied on the left or right by U. SIDE = 'L' Multiply A on the left (premultiply) by U SIDE = 'R' Multiply A on the right (postmultiply) by U* SIDE = 'C' Multiply A on the left by U and the right by U* SIDE = 'T' Multiply A on the left by U and the right by U' Not modified. INIT - CHARACTER*1 INIT specifies whether or not A should be initialized to the identity matrix. INIT = 'I' Initialize A to (a section of) the identity matrix before applying U. INIT = 'N' No initialization. Apply U to the input matrix A. INIT = 'I' may be used to generate square (i.e., unitary) or rectangular orthogonal matrices (orthogonality being in the sense of ZDOTC): For square matrices, M=N, and SIDE many be either 'L' or 'R'; the rows will be orthogonal to each other, as will the columns. For rectangular matrices where M < N, SIDE = 'R' will produce a dense matrix whose rows will be orthogonal and whose columns will not, while SIDE = 'L' will produce a matrix whose rows will be orthogonal, and whose first M columns will be orthogonal, the remaining columns being zero. For matrices where M > N, just use the previous explaination, interchanging 'L' and 'R' and "rows" and "columns". Not modified. M - INTEGER Number of rows of A. Not modified. N - INTEGER Number of columns of A. Not modified. A - COMPLEX*16 array, dimension ( LDA, N ) Input and output array. Overwritten by U A ( if SIDE = 'L' ) or by A U ( if SIDE = 'R' ) or by U A U* ( if SIDE = 'C') or by U A U' ( if SIDE = 'T') on exit. LDA - INTEGER Leading dimension of A. Must be at least MAX ( 1, M ). Not modified. ISEED - INTEGER array, dimension ( 4 ) On entry ISEED specifies the seed of the random number generator. The array elements should be between 0 and 4095; if not they will be reduced mod 4096. Also, ISEED(4) must be odd. The random number generator uses a linear congruential sequence limited to small integers, and so should produce machine independent random numbers. The values of ISEED are changed on exit, and can be used in the next call to ZLAROR to continue the same random number sequence. Modified. X - COMPLEX*16 array, dimension ( 3*MAX( M, N ) ) Workspace. Of length: 2*M + N if SIDE = 'L', 2*N + M if SIDE = 'R', 3*N if SIDE = 'C' or 'T'. Modified. INFO - INTEGER An error flag. It is set to: 0 if no error. 1 if ZLARND returned a bad random number (installation problem) -1 if SIDE is not L, R, C, or T. -3 if M is negative. -4 if N is negative or if SIDE is C or T and N is not equal to M. -6 if LDA is less than M. ===================================================================== Parameter adjustments */ a_dim1 = *lda; a_offset = a_dim1 + 1; a -= a_offset; --iseed; --x; /* Function Body */ if (*n == 0 || *m == 0) { return 0; } itype = 0; if (strncmp(side, "L", 1)==0) { itype = 1; } else if (strncmp(side, "R", 1)==0) { itype = 2; } else if (strncmp(side, "C", 1)==0) { itype = 3; } else if (strncmp(side, "T", 1)==0) { itype = 4; } /* Check for argument errors. */ *info = 0; if (itype == 0) { *info = -1; } else if (*m < 0) { *info = -3; } else if (*n < 0 || itype == 3 && *n != *m) { *info = -4; } else if (*lda < *m) { *info = -6; } if (*info != 0) { i__1 = -(*info); input_error("ZLAROR", &i__1); return 0; } if (itype == 1) { nxfrm = *m; } else { nxfrm = *n; } /* Initialize A to the identity matrix if desired */ if (strncmp(init, "I", 1)==0) { zlaset_slu("Full", m, n, &c_b1, &c_b2, &a[a_offset], lda); } /* If no rotation possible, still multiply by a random complex number from the circle |x| = 1 2) Compute Rotation by computing Householder Transformations H(2), H(3), ..., H(n). Note that the order in which they are computed is irrelevant. */ i__1 = nxfrm; for (j = 1; j <= i__1; ++j) { i__2 = j; x[i__2].r = 0., x[i__2].i = 0.; /* L10: */ } i__1 = nxfrm; for (ixfrm = 2; ixfrm <= i__1; ++ixfrm) { kbeg = nxfrm - ixfrm + 1; /* Generate independent normal( 0, 1 ) random numbers */ i__2 = nxfrm; for (j = kbeg; j <= i__2; ++j) { i__3 = j; zlarnd_slu(&z__1, &c__3, &iseed[1]); x[i__3].r = z__1.r, x[i__3].i = z__1.i; /* L20: */ } /* Generate a Householder transformation from the random vector X */ xnorm = dznrm2_(&ixfrm, &x[kbeg], &c__1); xabs = z_abs(&x[kbeg]); if (xabs != 0.) { i__2 = kbeg; z__1.r = x[i__2].r / xabs, z__1.i = x[i__2].i / xabs; csign.r = z__1.r, csign.i = z__1.i; } else { csign.r = 1., csign.i = 0.; } z__1.r = xnorm * csign.r, z__1.i = xnorm * csign.i; xnorms.r = z__1.r, xnorms.i = z__1.i; i__2 = nxfrm + kbeg; z__1.r = -csign.r, z__1.i = -csign.i; x[i__2].r = z__1.r, x[i__2].i = z__1.i; factor = xnorm * (xnorm + xabs); if (abs(factor) < 1e-20) { *info = 1; i__2 = -(*info); input_error("ZLAROR", &i__2); return 0; } else { factor = 1. / factor; } i__2 = kbeg; i__3 = kbeg; z__1.r = x[i__3].r + xnorms.r, z__1.i = x[i__3].i + xnorms.i; x[i__2].r = z__1.r, x[i__2].i = z__1.i; /* Apply Householder transformation to A */ if (itype == 1 || itype == 3 || itype == 4) { /* Apply H(k) on the left of A */ zgemv_("C", &ixfrm, n, &c_b2, &a[kbeg + a_dim1], lda, &x[kbeg], & c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1); z__2.r = factor, z__2.i = 0.; z__1.r = -z__2.r, z__1.i = -z__2.i; zgerc_(&ixfrm, n, &z__1, &x[kbeg], &c__1, &x[(nxfrm << 1) + 1], & c__1, &a[kbeg + a_dim1], lda); } if (itype >= 2 && itype <= 4) { /* Apply H(k)* (or H(k)') on the right of A */ if (itype == 4) { zlacgv_slu(&ixfrm, &x[kbeg], &c__1); } zgemv_("N", m, &ixfrm, &c_b2, &a[kbeg * a_dim1 + 1], lda, &x[kbeg] , &c__1, &c_b1, &x[(nxfrm << 1) + 1], &c__1); z__2.r = factor, z__2.i = 0.; z__1.r = -z__2.r, z__1.i = -z__2.i; zgerc_(m, &ixfrm, &z__1, &x[(nxfrm << 1) + 1], &c__1, &x[kbeg], & c__1, &a[kbeg * a_dim1 + 1], lda); } /* L30: */ } zlarnd_slu(&z__1, &c__3, &iseed[1]); x[1].r = z__1.r, x[1].i = z__1.i; xabs = z_abs(&x[1]); if (xabs != 0.) { z__1.r = x[1].r / xabs, z__1.i = x[1].i / xabs; csign.r = z__1.r, csign.i = z__1.i; } else { csign.r = 1., csign.i = 0.; } i__1 = nxfrm << 1; x[i__1].r = csign.r, x[i__1].i = csign.i; /* Scale the matrix A by D. */ if (itype == 1 || itype == 3 || itype == 4) { i__1 = *m; for (irow = 1; irow <= i__1; ++irow) { d_cnjg(&z__1, &x[nxfrm + irow]); zscal_(n, &z__1, &a[irow + a_dim1], lda); /* L40: */ } } if (itype == 2 || itype == 3) { i__1 = *n; for (jcol = 1; jcol <= i__1; ++jcol) { zscal_(m, &x[nxfrm + jcol], &a[jcol * a_dim1 + 1], &c__1); /* L50: */ } } if (itype == 4) { i__1 = *n; for (jcol = 1; jcol <= i__1; ++jcol) { d_cnjg(&z__1, &x[nxfrm + jcol]); zscal_(m, &z__1, &a[jcol * a_dim1 + 1], &c__1); /* L60: */ } } return 0; /* End of ZLAROR */ } /* zlaror_slu */