/* Subroutine */ int zspt01_(char *uplo, integer *n, doublecomplex *a, doublecomplex *afac, integer *ipiv, doublecomplex *c__, integer *ldc, doublereal *rwork, doublereal *resid) { /* System generated locals */ integer c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5; doublecomplex z__1; /* Local variables */ static integer info, i__, j; extern logical lsame_(char *, char *); static doublereal anorm; static integer jc; extern doublereal dlamch_(char *); extern /* Subroutine */ int zlaset_(char *, integer *, integer *, doublecomplex *, doublecomplex *, doublecomplex *, integer *); extern doublereal zlansp_(char *, char *, integer *, doublecomplex *, doublereal *); extern /* Subroutine */ int zlavsp_(char *, char *, char *, integer *, integer *, doublecomplex *, integer *, doublecomplex *, integer *, integer *); extern doublereal zlansy_(char *, char *, integer *, doublecomplex *, integer *, doublereal *); static doublereal eps; #define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1 #define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)] /* -- LAPACK test routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= ZSPT01 reconstructs a symmetric indefinite packed matrix A from its diagonal pivoting factorization A = U*D*U' or A = L*D*L' and computes the residual norm( C - A ) / ( N * norm(A) * EPS ), where C is the reconstructed matrix and EPS is the machine epsilon. Arguments ========== UPLO (input) CHARACTER*1 Specifies whether the upper or lower triangular part of the Hermitian matrix A is stored: = 'U': Upper triangular = 'L': Lower triangular N (input) INTEGER The order of the matrix A. N >= 0. A (input) COMPLEX*16 array, dimension (N*(N+1)/2) The original symmetric matrix A, stored as a packed triangular matrix. AFAC (input) COMPLEX*16 array, dimension (N*(N+1)/2) The factored form of the matrix A, stored as a packed triangular matrix. AFAC contains the block diagonal matrix D and the multipliers used to obtain the factor L or U from the L*D*L' or U*D*U' factorization as computed by ZSPTRF. IPIV (input) INTEGER array, dimension (N) The pivot indices from ZSPTRF. C (workspace) COMPLEX*16 array, dimension (LDC,N) LDC (integer) INTEGER The leading dimension of the array C. LDC >= max(1,N). RWORK (workspace) DOUBLE PRECISION array, dimension (N) RESID (output) DOUBLE PRECISION If UPLO = 'L', norm(L*D*L' - A) / ( N * norm(A) * EPS ) If UPLO = 'U', norm(U*D*U' - A) / ( N * norm(A) * EPS ) ===================================================================== Quick exit if N = 0. Parameter adjustments */ --a; --afac; --ipiv; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; --rwork; /* Function Body */ if (*n <= 0) { *resid = 0.; return 0; } /* Determine EPS and the norm of A. */ eps = dlamch_("Epsilon"); anorm = zlansp_("1", uplo, n, &a[1], &rwork[1]); /* Initialize C to the identity matrix. */ zlaset_("Full", n, n, &c_b1, &c_b2, &c__[c_offset], ldc); /* Call ZLAVSP to form the product D * U' (or D * L' ). */ zlavsp_(uplo, "Transpose", "Non-unit", n, n, &afac[1], &ipiv[1], &c__[ c_offset], ldc, &info); /* Call ZLAVSP again to multiply by U ( or L ). */ zlavsp_(uplo, "No transpose", "Unit", n, n, &afac[1], &ipiv[1], &c__[ c_offset], ldc, &info); /* Compute the difference C - A . */ if (lsame_(uplo, "U")) { jc = 0; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); i__4 = c___subscr(i__, j); i__5 = jc + i__; z__1.r = c__[i__4].r - a[i__5].r, z__1.i = c__[i__4].i - a[ i__5].i; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L10: */ } jc += j; /* L20: */ } } else { jc = 1; i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); i__4 = c___subscr(i__, j); i__5 = jc + i__ - j; z__1.r = c__[i__4].r - a[i__5].r, z__1.i = c__[i__4].i - a[ i__5].i; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L30: */ } jc = jc + *n - j + 1; /* L40: */ } } /* Compute norm( C - A ) / ( N * norm(A) * EPS ) */ *resid = zlansy_("1", uplo, n, &c__[c_offset], ldc, &rwork[1]); if (anorm <= 0.) { if (*resid != 0.) { *resid = 1. / eps; } } else { *resid = *resid / (doublereal) (*n) / anorm / eps; } return 0; /* End of ZSPT01 */ } /* zspt01_ */
/* Subroutine */ int ctrsyl_(char *trana, char *tranb, integer *isgn, integer *m, integer *n, complex *a, integer *lda, complex *b, integer *ldb, complex *c__, integer *ldc, real *scale, integer *info) { /* -- LAPACK routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University June 30, 1999 Purpose ======= CTRSYL solves the complex Sylvester matrix equation: op(A)*X + X*op(B) = scale*C or op(A)*X - X*op(B) = scale*C, where op(A) = A or A**H, and A and B are both upper triangular. A is M-by-M and B is N-by-N; the right hand side C and the solution X are M-by-N; and scale is an output scale factor, set <= 1 to avoid overflow in X. Arguments ========= TRANA (input) CHARACTER*1 Specifies the option op(A): = 'N': op(A) = A (No transpose) = 'C': op(A) = A**H (Conjugate transpose) TRANB (input) CHARACTER*1 Specifies the option op(B): = 'N': op(B) = B (No transpose) = 'C': op(B) = B**H (Conjugate transpose) ISGN (input) INTEGER Specifies the sign in the equation: = +1: solve op(A)*X + X*op(B) = scale*C = -1: solve op(A)*X - X*op(B) = scale*C M (input) INTEGER The order of the matrix A, and the number of rows in the matrices X and C. M >= 0. N (input) INTEGER The order of the matrix B, and the number of columns in the matrices X and C. N >= 0. A (input) COMPLEX array, dimension (LDA,M) The upper triangular matrix A. LDA (input) INTEGER The leading dimension of the array A. LDA >= max(1,M). B (input) COMPLEX array, dimension (LDB,N) The upper triangular matrix B. LDB (input) INTEGER The leading dimension of the array B. LDB >= max(1,N). C (input/output) COMPLEX array, dimension (LDC,N) On entry, the M-by-N right hand side matrix C. On exit, C is overwritten by the solution matrix X. LDC (input) INTEGER The leading dimension of the array C. LDC >= max(1,M) SCALE (output) REAL The scale factor, scale, set <= 1 to avoid overflow in X. INFO (output) INTEGER = 0: successful exit < 0: if INFO = -i, the i-th argument had an illegal value = 1: A and B have common or very close eigenvalues; perturbed values were used to solve the equation (but the matrices A and B are unchanged). ===================================================================== Decode and Test input parameters Parameter adjustments */ /* Table of constant values */ static integer c__1 = 1; /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4; real r__1, r__2; complex q__1, q__2, q__3, q__4; /* Builtin functions */ double r_imag(complex *); void r_cnjg(complex *, complex *); /* Local variables */ static real smin; static complex suml, sumr; static integer j, k, l; extern /* Complex */ VOID cdotc_(complex *, integer *, complex *, integer *, complex *, integer *); extern logical lsame_(char *, char *); extern /* Complex */ VOID cdotu_(complex *, integer *, complex *, integer *, complex *, integer *); static complex a11; static real db; extern /* Subroutine */ int slabad_(real *, real *); extern doublereal clange_(char *, integer *, integer *, complex *, integer *, real *); static complex x11; extern /* Complex */ VOID cladiv_(complex *, complex *, complex *); static real scaloc; extern doublereal slamch_(char *); extern /* Subroutine */ int csscal_(integer *, real *, complex *, integer *), xerbla_(char *, integer *); static real bignum; static logical notrna, notrnb; static real smlnum, da11; static complex vec; static real dum[1], eps, sgn; #define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] #define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1 #define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)] #define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1 #define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; /* Function Body */ notrna = lsame_(trana, "N"); notrnb = lsame_(tranb, "N"); *info = 0; if (! notrna && ! lsame_(trana, "T") && ! lsame_( trana, "C")) { *info = -1; } else if (! notrnb && ! lsame_(tranb, "T") && ! lsame_(tranb, "C")) { *info = -2; } else if (*isgn != 1 && *isgn != -1) { *info = -3; } else if (*m < 0) { *info = -4; } else if (*n < 0) { *info = -5; } else if (*lda < max(1,*m)) { *info = -7; } else if (*ldb < max(1,*n)) { *info = -9; } else if (*ldc < max(1,*m)) { *info = -11; } if (*info != 0) { i__1 = -(*info); xerbla_("CTRSYL", &i__1); return 0; } /* Quick return if possible */ if (*m == 0 || *n == 0) { return 0; } /* Set constants to control overflow */ eps = slamch_("P"); smlnum = slamch_("S"); bignum = 1.f / smlnum; slabad_(&smlnum, &bignum); smlnum = smlnum * (real) (*m * *n) / eps; bignum = 1.f / smlnum; /* Computing MAX */ r__1 = smlnum, r__2 = eps * clange_("M", m, m, &a[a_offset], lda, dum), r__1 = max(r__1,r__2), r__2 = eps * clange_("M", n, n, &b[b_offset], ldb, dum); smin = dmax(r__1,r__2); *scale = 1.f; sgn = (real) (*isgn); if (notrna && notrnb) { /* Solve A*X + ISGN*X*B = scale*C. The (K,L)th block of X is determined starting from bottom-left corner column by column by A(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) Where M L-1 R(K,L) = SUM [A(K,I)*X(I,L)] +ISGN*SUM [X(K,J)*B(J,L)]. I=K+1 J=1 */ i__1 = *n; for (l = 1; l <= i__1; ++l) { for (k = *m; k >= 1; --k) { /* Computing MIN */ i__2 = k + 1; /* Computing MIN */ i__3 = k + 1; i__4 = *m - k; cdotu_(&q__1, &i__4, &a_ref(k, min(i__2,*m)), lda, &c___ref( min(i__3,*m), l), &c__1); suml.r = q__1.r, suml.i = q__1.i; i__2 = l - 1; cdotu_(&q__1, &i__2, &c___ref(k, 1), ldc, &b_ref(1, l), &c__1) ; sumr.r = q__1.r, sumr.i = q__1.i; i__2 = c___subscr(k, l); q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i; q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i; q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i; vec.r = q__1.r, vec.i = q__1.i; scaloc = 1.f; i__2 = a_subscr(k, k); i__3 = b_subscr(l, l); q__2.r = sgn * b[i__3].r, q__2.i = sgn * b[i__3].i; q__1.r = a[i__2].r + q__2.r, q__1.i = a[i__2].i + q__2.i; a11.r = q__1.r, a11.i = q__1.i; da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11), dabs(r__2)); if (da11 <= smin) { a11.r = smin, a11.i = 0.f; da11 = smin; *info = 1; } db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs( r__2)); if (da11 < 1.f && db > 1.f) { if (db > bignum * da11) { scaloc = 1.f / db; } } q__3.r = scaloc, q__3.i = 0.f; q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r * q__3.i + vec.i * q__3.r; cladiv_(&q__1, &q__2, &a11); x11.r = q__1.r, x11.i = q__1.i; if (scaloc != 1.f) { i__2 = *n; for (j = 1; j <= i__2; ++j) { csscal_(m, &scaloc, &c___ref(1, j), &c__1); /* L10: */ } *scale *= scaloc; } i__2 = c___subscr(k, l); c__[i__2].r = x11.r, c__[i__2].i = x11.i; /* L20: */ } /* L30: */ } } else if (! notrna && notrnb) { /* Solve A' *X + ISGN*X*B = scale*C. The (K,L)th block of X is determined starting from upper-left corner column by column by A'(K,K)*X(K,L) + ISGN*X(K,L)*B(L,L) = C(K,L) - R(K,L) Where K-1 L-1 R(K,L) = SUM [A'(I,K)*X(I,L)] + ISGN*SUM [X(K,J)*B(J,L)] I=1 J=1 */ i__1 = *n; for (l = 1; l <= i__1; ++l) { i__2 = *m; for (k = 1; k <= i__2; ++k) { i__3 = k - 1; cdotc_(&q__1, &i__3, &a_ref(1, k), &c__1, &c___ref(1, l), & c__1); suml.r = q__1.r, suml.i = q__1.i; i__3 = l - 1; cdotu_(&q__1, &i__3, &c___ref(k, 1), ldc, &b_ref(1, l), &c__1) ; sumr.r = q__1.r, sumr.i = q__1.i; i__3 = c___subscr(k, l); q__3.r = sgn * sumr.r, q__3.i = sgn * sumr.i; q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i; q__1.r = c__[i__3].r - q__2.r, q__1.i = c__[i__3].i - q__2.i; vec.r = q__1.r, vec.i = q__1.i; scaloc = 1.f; r_cnjg(&q__2, &a_ref(k, k)); i__3 = b_subscr(l, l); q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i; q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; a11.r = q__1.r, a11.i = q__1.i; da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11), dabs(r__2)); if (da11 <= smin) { a11.r = smin, a11.i = 0.f; da11 = smin; *info = 1; } db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs( r__2)); if (da11 < 1.f && db > 1.f) { if (db > bignum * da11) { scaloc = 1.f / db; } } q__3.r = scaloc, q__3.i = 0.f; q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r * q__3.i + vec.i * q__3.r; cladiv_(&q__1, &q__2, &a11); x11.r = q__1.r, x11.i = q__1.i; if (scaloc != 1.f) { i__3 = *n; for (j = 1; j <= i__3; ++j) { csscal_(m, &scaloc, &c___ref(1, j), &c__1); /* L40: */ } *scale *= scaloc; } i__3 = c___subscr(k, l); c__[i__3].r = x11.r, c__[i__3].i = x11.i; /* L50: */ } /* L60: */ } } else if (! notrna && ! notrnb) { /* Solve A'*X + ISGN*X*B' = C. The (K,L)th block of X is determined starting from upper-right corner column by column by A'(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) Where K-1 R(K,L) = SUM [A'(I,K)*X(I,L)] + I=1 N ISGN*SUM [X(K,J)*B'(L,J)]. J=L+1 */ for (l = *n; l >= 1; --l) { i__1 = *m; for (k = 1; k <= i__1; ++k) { i__2 = k - 1; cdotc_(&q__1, &i__2, &a_ref(1, k), &c__1, &c___ref(1, l), & c__1); suml.r = q__1.r, suml.i = q__1.i; /* Computing MIN */ i__2 = l + 1; /* Computing MIN */ i__3 = l + 1; i__4 = *n - l; cdotc_(&q__1, &i__4, &c___ref(k, min(i__2,*n)), ldc, &b_ref(l, min(i__3,*n)), ldb); sumr.r = q__1.r, sumr.i = q__1.i; i__2 = c___subscr(k, l); r_cnjg(&q__4, &sumr); q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i; q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i; q__1.r = c__[i__2].r - q__2.r, q__1.i = c__[i__2].i - q__2.i; vec.r = q__1.r, vec.i = q__1.i; scaloc = 1.f; i__2 = a_subscr(k, k); i__3 = b_subscr(l, l); q__3.r = sgn * b[i__3].r, q__3.i = sgn * b[i__3].i; q__2.r = a[i__2].r + q__3.r, q__2.i = a[i__2].i + q__3.i; r_cnjg(&q__1, &q__2); a11.r = q__1.r, a11.i = q__1.i; da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11), dabs(r__2)); if (da11 <= smin) { a11.r = smin, a11.i = 0.f; da11 = smin; *info = 1; } db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs( r__2)); if (da11 < 1.f && db > 1.f) { if (db > bignum * da11) { scaloc = 1.f / db; } } q__3.r = scaloc, q__3.i = 0.f; q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r * q__3.i + vec.i * q__3.r; cladiv_(&q__1, &q__2, &a11); x11.r = q__1.r, x11.i = q__1.i; if (scaloc != 1.f) { i__2 = *n; for (j = 1; j <= i__2; ++j) { csscal_(m, &scaloc, &c___ref(1, j), &c__1); /* L70: */ } *scale *= scaloc; } i__2 = c___subscr(k, l); c__[i__2].r = x11.r, c__[i__2].i = x11.i; /* L80: */ } /* L90: */ } } else if (notrna && ! notrnb) { /* Solve A*X + ISGN*X*B' = C. The (K,L)th block of X is determined starting from bottom-left corner column by column by A(K,K)*X(K,L) + ISGN*X(K,L)*B'(L,L) = C(K,L) - R(K,L) Where M N R(K,L) = SUM [A(K,I)*X(I,L)] + ISGN*SUM [X(K,J)*B'(L,J)] I=K+1 J=L+1 */ for (l = *n; l >= 1; --l) { for (k = *m; k >= 1; --k) { /* Computing MIN */ i__1 = k + 1; /* Computing MIN */ i__2 = k + 1; i__3 = *m - k; cdotu_(&q__1, &i__3, &a_ref(k, min(i__1,*m)), lda, &c___ref( min(i__2,*m), l), &c__1); suml.r = q__1.r, suml.i = q__1.i; /* Computing MIN */ i__1 = l + 1; /* Computing MIN */ i__2 = l + 1; i__3 = *n - l; cdotc_(&q__1, &i__3, &c___ref(k, min(i__1,*n)), ldc, &b_ref(l, min(i__2,*n)), ldb); sumr.r = q__1.r, sumr.i = q__1.i; i__1 = c___subscr(k, l); r_cnjg(&q__4, &sumr); q__3.r = sgn * q__4.r, q__3.i = sgn * q__4.i; q__2.r = suml.r + q__3.r, q__2.i = suml.i + q__3.i; q__1.r = c__[i__1].r - q__2.r, q__1.i = c__[i__1].i - q__2.i; vec.r = q__1.r, vec.i = q__1.i; scaloc = 1.f; i__1 = a_subscr(k, k); r_cnjg(&q__3, &b_ref(l, l)); q__2.r = sgn * q__3.r, q__2.i = sgn * q__3.i; q__1.r = a[i__1].r + q__2.r, q__1.i = a[i__1].i + q__2.i; a11.r = q__1.r, a11.i = q__1.i; da11 = (r__1 = a11.r, dabs(r__1)) + (r__2 = r_imag(&a11), dabs(r__2)); if (da11 <= smin) { a11.r = smin, a11.i = 0.f; da11 = smin; *info = 1; } db = (r__1 = vec.r, dabs(r__1)) + (r__2 = r_imag(&vec), dabs( r__2)); if (da11 < 1.f && db > 1.f) { if (db > bignum * da11) { scaloc = 1.f / db; } } q__3.r = scaloc, q__3.i = 0.f; q__2.r = vec.r * q__3.r - vec.i * q__3.i, q__2.i = vec.r * q__3.i + vec.i * q__3.r; cladiv_(&q__1, &q__2, &a11); x11.r = q__1.r, x11.i = q__1.i; if (scaloc != 1.f) { i__1 = *n; for (j = 1; j <= i__1; ++j) { csscal_(m, &scaloc, &c___ref(1, j), &c__1); /* L100: */ } *scale *= scaloc; } i__1 = c___subscr(k, l); c__[i__1].r = x11.r, c__[i__1].i = x11.i; /* L110: */ } /* L120: */ } } return 0; /* End of CTRSYL */ } /* ctrsyl_ */
/* Subroutine */ int chemm_(char *side, char *uplo, integer *m, integer *n, complex *alpha, complex *a, integer *lda, complex *b, integer *ldb, complex *beta, complex *c__, integer *ldc) { /* System generated locals */ integer a_dim1, a_offset, b_dim1, b_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6; real r__1; complex q__1, q__2, q__3, q__4, q__5; /* Builtin functions */ void r_cnjg(complex *, complex *); /* Local variables */ static integer info; static complex temp1, temp2; static integer i__, j, k; extern logical lsame_(char *, char *); static integer nrowa; static logical upper; extern /* Subroutine */ int xerbla_(char *, integer *); #define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] #define b_subscr(a_1,a_2) (a_2)*b_dim1 + a_1 #define b_ref(a_1,a_2) b[b_subscr(a_1,a_2)] #define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1 #define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)] /* Purpose ======= CHEMM performs one of the matrix-matrix operations C := alpha*A*B + beta*C, or C := alpha*B*A + beta*C, where alpha and beta are scalars, A is an hermitian matrix and B and C are m by n matrices. Parameters ========== SIDE - CHARACTER*1. On entry, SIDE specifies whether the hermitian matrix A appears on the left or right in the operation as follows: SIDE = 'L' or 'l' C := alpha*A*B + beta*C, SIDE = 'R' or 'r' C := alpha*B*A + beta*C, Unchanged on exit. UPLO - CHARACTER*1. On entry, UPLO specifies whether the upper or lower triangular part of the hermitian matrix A is to be referenced as follows: UPLO = 'U' or 'u' Only the upper triangular part of the hermitian matrix is to be referenced. UPLO = 'L' or 'l' Only the lower triangular part of the hermitian matrix is to be referenced. Unchanged on exit. M - INTEGER. On entry, M specifies the number of rows of the matrix C. M must be at least zero. Unchanged on exit. N - INTEGER. On entry, N specifies the number of columns of the matrix C. N must be at least zero. Unchanged on exit. ALPHA - COMPLEX . On entry, ALPHA specifies the scalar alpha. Unchanged on exit. A - COMPLEX array of DIMENSION ( LDA, ka ), where ka is m when SIDE = 'L' or 'l' and is n otherwise. Before entry with SIDE = 'L' or 'l', the m by m part of the array A must contain the hermitian matrix, such that when UPLO = 'U' or 'u', the leading m by m upper triangular part of the array A must contain the upper triangular part of the hermitian matrix and the strictly lower triangular part of A is not referenced, and when UPLO = 'L' or 'l', the leading m by m lower triangular part of the array A must contain the lower triangular part of the hermitian matrix and the strictly upper triangular part of A is not referenced. Before entry with SIDE = 'R' or 'r', the n by n part of the array A must contain the hermitian matrix, such that when UPLO = 'U' or 'u', the leading n by n upper triangular part of the array A must contain the upper triangular part of the hermitian matrix and the strictly lower triangular part of A is not referenced, and when UPLO = 'L' or 'l', the leading n by n lower triangular part of the array A must contain the lower triangular part of the hermitian matrix and the strictly upper triangular part of A is not referenced. Note that the imaginary parts of the diagonal elements need not be set, they are assumed to be zero. Unchanged on exit. LDA - INTEGER. On entry, LDA specifies the first dimension of A as declared in the calling (sub) program. When SIDE = 'L' or 'l' then LDA must be at least max( 1, m ), otherwise LDA must be at least max( 1, n ). Unchanged on exit. B - COMPLEX array of DIMENSION ( LDB, n ). Before entry, the leading m by n part of the array B must contain the matrix B. Unchanged on exit. LDB - INTEGER. On entry, LDB specifies the first dimension of B as declared in the calling (sub) program. LDB must be at least max( 1, m ). Unchanged on exit. BETA - COMPLEX . On entry, BETA specifies the scalar beta. When BETA is supplied as zero then C need not be set on input. Unchanged on exit. C - COMPLEX array of DIMENSION ( LDC, n ). Before entry, the leading m by n part of the array C must contain the matrix C, except when beta is zero, in which case C need not be set on entry. On exit, the array C is overwritten by the m by n updated matrix. LDC - INTEGER. On entry, LDC specifies the first dimension of C as declared in the calling (sub) program. LDC must be at least max( 1, m ). Unchanged on exit. Level 3 Blas routine. -- Written on 8-February-1989. Jack Dongarra, Argonne National Laboratory. Iain Duff, AERE Harwell. Jeremy Du Croz, Numerical Algorithms Group Ltd. Sven Hammarling, Numerical Algorithms Group Ltd. Set NROWA as the number of rows of A. Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; /* Function Body */ if (lsame_(side, "L")) { nrowa = *m; } else { nrowa = *n; } upper = lsame_(uplo, "U"); /* Test the input parameters. */ info = 0; if (! lsame_(side, "L") && ! lsame_(side, "R")) { info = 1; } else if (! upper && ! lsame_(uplo, "L")) { info = 2; } else if (*m < 0) { info = 3; } else if (*n < 0) { info = 4; } else if (*lda < max(1,nrowa)) { info = 7; } else if (*ldb < max(1,*m)) { info = 9; } else if (*ldc < max(1,*m)) { info = 12; } if (info != 0) { xerbla_("CHEMM ", &info); return 0; } /* Quick return if possible. */ if (*m == 0 || *n == 0 || alpha->r == 0.f && alpha->i == 0.f && (beta->r == 1.f && beta->i == 0.f)) { return 0; } /* And when alpha.eq.zero. */ if (alpha->r == 0.f && alpha->i == 0.f) { if (beta->r == 0.f && beta->i == 0.f) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); c__[i__3].r = 0.f, c__[i__3].i = 0.f; /* L10: */ } /* L20: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); i__4 = c___subscr(i__, j); q__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i, q__1.i = beta->r * c__[i__4].i + beta->i * c__[ i__4].r; c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; /* L30: */ } /* L40: */ } } return 0; } /* Start the operations. */ if (lsame_(side, "L")) { /* Form C := alpha*A*B + beta*C. */ if (upper) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = b_subscr(i__, j); q__1.r = alpha->r * b[i__3].r - alpha->i * b[i__3].i, q__1.i = alpha->r * b[i__3].i + alpha->i * b[i__3] .r; temp1.r = q__1.r, temp1.i = q__1.i; temp2.r = 0.f, temp2.i = 0.f; i__3 = i__ - 1; for (k = 1; k <= i__3; ++k) { i__4 = c___subscr(k, j); i__5 = c___subscr(k, j); i__6 = a_subscr(k, i__); q__2.r = temp1.r * a[i__6].r - temp1.i * a[i__6].i, q__2.i = temp1.r * a[i__6].i + temp1.i * a[ i__6].r; q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i + q__2.i; c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; i__4 = b_subscr(k, j); r_cnjg(&q__3, &a_ref(k, i__)); q__2.r = b[i__4].r * q__3.r - b[i__4].i * q__3.i, q__2.i = b[i__4].r * q__3.i + b[i__4].i * q__3.r; q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; temp2.r = q__1.r, temp2.i = q__1.i; /* L50: */ } if (beta->r == 0.f && beta->i == 0.f) { i__3 = c___subscr(i__, j); i__4 = a_subscr(i__, i__); r__1 = a[i__4].r; q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i; q__3.r = alpha->r * temp2.r - alpha->i * temp2.i, q__3.i = alpha->r * temp2.i + alpha->i * temp2.r; q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; } else { i__3 = c___subscr(i__, j); i__4 = c___subscr(i__, j); q__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] .i, q__3.i = beta->r * c__[i__4].i + beta->i * c__[i__4].r; i__5 = a_subscr(i__, i__); r__1 = a[i__5].r; q__4.r = r__1 * temp1.r, q__4.i = r__1 * temp1.i; q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i; q__5.r = alpha->r * temp2.r - alpha->i * temp2.i, q__5.i = alpha->r * temp2.i + alpha->i * temp2.r; q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i; c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; } /* L60: */ } /* L70: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { for (i__ = *m; i__ >= 1; --i__) { i__2 = b_subscr(i__, j); q__1.r = alpha->r * b[i__2].r - alpha->i * b[i__2].i, q__1.i = alpha->r * b[i__2].i + alpha->i * b[i__2] .r; temp1.r = q__1.r, temp1.i = q__1.i; temp2.r = 0.f, temp2.i = 0.f; i__2 = *m; for (k = i__ + 1; k <= i__2; ++k) { i__3 = c___subscr(k, j); i__4 = c___subscr(k, j); i__5 = a_subscr(k, i__); q__2.r = temp1.r * a[i__5].r - temp1.i * a[i__5].i, q__2.i = temp1.r * a[i__5].i + temp1.i * a[ i__5].r; q__1.r = c__[i__4].r + q__2.r, q__1.i = c__[i__4].i + q__2.i; c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; i__3 = b_subscr(k, j); r_cnjg(&q__3, &a_ref(k, i__)); q__2.r = b[i__3].r * q__3.r - b[i__3].i * q__3.i, q__2.i = b[i__3].r * q__3.i + b[i__3].i * q__3.r; q__1.r = temp2.r + q__2.r, q__1.i = temp2.i + q__2.i; temp2.r = q__1.r, temp2.i = q__1.i; /* L80: */ } if (beta->r == 0.f && beta->i == 0.f) { i__2 = c___subscr(i__, j); i__3 = a_subscr(i__, i__); r__1 = a[i__3].r; q__2.r = r__1 * temp1.r, q__2.i = r__1 * temp1.i; q__3.r = alpha->r * temp2.r - alpha->i * temp2.i, q__3.i = alpha->r * temp2.i + alpha->i * temp2.r; q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; c__[i__2].r = q__1.r, c__[i__2].i = q__1.i; } else { i__2 = c___subscr(i__, j); i__3 = c___subscr(i__, j); q__3.r = beta->r * c__[i__3].r - beta->i * c__[i__3] .i, q__3.i = beta->r * c__[i__3].i + beta->i * c__[i__3].r; i__4 = a_subscr(i__, i__); r__1 = a[i__4].r; q__4.r = r__1 * temp1.r, q__4.i = r__1 * temp1.i; q__2.r = q__3.r + q__4.r, q__2.i = q__3.i + q__4.i; q__5.r = alpha->r * temp2.r - alpha->i * temp2.i, q__5.i = alpha->r * temp2.i + alpha->i * temp2.r; q__1.r = q__2.r + q__5.r, q__1.i = q__2.i + q__5.i; c__[i__2].r = q__1.r, c__[i__2].i = q__1.i; } /* L90: */ } /* L100: */ } } } else { /* Form C := alpha*B*A + beta*C. */ i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = a_subscr(j, j); r__1 = a[i__2].r; q__1.r = r__1 * alpha->r, q__1.i = r__1 * alpha->i; temp1.r = q__1.r, temp1.i = q__1.i; if (beta->r == 0.f && beta->i == 0.f) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); i__4 = b_subscr(i__, j); q__1.r = temp1.r * b[i__4].r - temp1.i * b[i__4].i, q__1.i = temp1.r * b[i__4].i + temp1.i * b[i__4] .r; c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; /* L110: */ } } else { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); i__4 = c___subscr(i__, j); q__2.r = beta->r * c__[i__4].r - beta->i * c__[i__4].i, q__2.i = beta->r * c__[i__4].i + beta->i * c__[ i__4].r; i__5 = b_subscr(i__, j); q__3.r = temp1.r * b[i__5].r - temp1.i * b[i__5].i, q__3.i = temp1.r * b[i__5].i + temp1.i * b[i__5] .r; q__1.r = q__2.r + q__3.r, q__1.i = q__2.i + q__3.i; c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; /* L120: */ } } i__2 = j - 1; for (k = 1; k <= i__2; ++k) { if (upper) { i__3 = a_subscr(k, j); q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3] .r; temp1.r = q__1.r, temp1.i = q__1.i; } else { r_cnjg(&q__2, &a_ref(j, k)); q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i = alpha->r * q__2.i + alpha->i * q__2.r; temp1.r = q__1.r, temp1.i = q__1.i; } i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = c___subscr(i__, j); i__5 = c___subscr(i__, j); i__6 = b_subscr(i__, k); q__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i, q__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6] .r; q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i + q__2.i; c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; /* L130: */ } /* L140: */ } i__2 = *n; for (k = j + 1; k <= i__2; ++k) { if (upper) { r_cnjg(&q__2, &a_ref(j, k)); q__1.r = alpha->r * q__2.r - alpha->i * q__2.i, q__1.i = alpha->r * q__2.i + alpha->i * q__2.r; temp1.r = q__1.r, temp1.i = q__1.i; } else { i__3 = a_subscr(k, j); q__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, q__1.i = alpha->r * a[i__3].i + alpha->i * a[i__3] .r; temp1.r = q__1.r, temp1.i = q__1.i; } i__3 = *m; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = c___subscr(i__, j); i__5 = c___subscr(i__, j); i__6 = b_subscr(i__, k); q__2.r = temp1.r * b[i__6].r - temp1.i * b[i__6].i, q__2.i = temp1.r * b[i__6].i + temp1.i * b[i__6] .r; q__1.r = c__[i__5].r + q__2.r, q__1.i = c__[i__5].i + q__2.i; c__[i__4].r = q__1.r, c__[i__4].i = q__1.i; /* L150: */ } /* L160: */ } /* L170: */ } } return 0; /* End of CHEMM . */ } /* chemm_ */
/* Subroutine */ int zsyrk_(char *uplo, char *trans, integer *n, integer *k, doublecomplex *alpha, doublecomplex *a, integer *lda, doublecomplex * beta, doublecomplex *c__, integer *ldc) { /* System generated locals */ integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5, i__6; doublecomplex z__1, z__2, z__3; /* Local variables */ static integer info; static doublecomplex temp; static integer i__, j, l; extern logical lsame_(char *, char *); static integer nrowa; static logical upper; extern /* Subroutine */ int xerbla_(char *, integer *); #define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] #define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1 #define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)] /* Purpose ======= ZSYRK performs one of the symmetric rank k operations C := alpha*A*A' + beta*C, or C := alpha*A'*A + beta*C, where alpha and beta are scalars, C is an n by n symmetric matrix and A is an n by k matrix in the first case and a k by n matrix in the second case. Parameters ========== UPLO - CHARACTER*1. On entry, UPLO specifies whether the upper or lower triangular part of the array C is to be referenced as follows: UPLO = 'U' or 'u' Only the upper triangular part of C is to be referenced. UPLO = 'L' or 'l' Only the lower triangular part of C is to be referenced. Unchanged on exit. TRANS - CHARACTER*1. On entry, TRANS specifies the operation to be performed as follows: TRANS = 'N' or 'n' C := alpha*A*A' + beta*C. TRANS = 'T' or 't' C := alpha*A'*A + beta*C. Unchanged on exit. N - INTEGER. On entry, N specifies the order of the matrix C. N must be at least zero. Unchanged on exit. K - INTEGER. On entry with TRANS = 'N' or 'n', K specifies the number of columns of the matrix A, and on entry with TRANS = 'T' or 't', K specifies the number of rows of the matrix A. K must be at least zero. Unchanged on exit. ALPHA - COMPLEX*16 . On entry, ALPHA specifies the scalar alpha. Unchanged on exit. A - COMPLEX*16 array of DIMENSION ( LDA, ka ), where ka is k when TRANS = 'N' or 'n', and is n otherwise. Before entry with TRANS = 'N' or 'n', the leading n by k part of the array A must contain the matrix A, otherwise the leading k by n part of the array A must contain the matrix A. Unchanged on exit. LDA - INTEGER. On entry, LDA specifies the first dimension of A as declared in the calling (sub) program. When TRANS = 'N' or 'n' then LDA must be at least max( 1, n ), otherwise LDA must be at least max( 1, k ). Unchanged on exit. BETA - COMPLEX*16 . On entry, BETA specifies the scalar beta. Unchanged on exit. C - COMPLEX*16 array of DIMENSION ( LDC, n ). Before entry with UPLO = 'U' or 'u', the leading n by n upper triangular part of the array C must contain the upper triangular part of the symmetric matrix and the strictly lower triangular part of C is not referenced. On exit, the upper triangular part of the array C is overwritten by the upper triangular part of the updated matrix. Before entry with UPLO = 'L' or 'l', the leading n by n lower triangular part of the array C must contain the lower triangular part of the symmetric matrix and the strictly upper triangular part of C is not referenced. On exit, the lower triangular part of the array C is overwritten by the lower triangular part of the updated matrix. LDC - INTEGER. On entry, LDC specifies the first dimension of C as declared in the calling (sub) program. LDC must be at least max( 1, n ). Unchanged on exit. Level 3 Blas routine. -- Written on 8-February-1989. Jack Dongarra, Argonne National Laboratory. Iain Duff, AERE Harwell. Jeremy Du Croz, Numerical Algorithms Group Ltd. Sven Hammarling, Numerical Algorithms Group Ltd. Test the input parameters. Parameter adjustments */ a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; /* Function Body */ if (lsame_(trans, "N")) { nrowa = *n; } else { nrowa = *k; } upper = lsame_(uplo, "U"); info = 0; if (! upper && ! lsame_(uplo, "L")) { info = 1; } else if (! lsame_(trans, "N") && ! lsame_(trans, "T")) { info = 2; } else if (*n < 0) { info = 3; } else if (*k < 0) { info = 4; } else if (*lda < max(1,nrowa)) { info = 7; } else if (*ldc < max(1,*n)) { info = 10; } if (info != 0) { xerbla_("ZSYRK ", &info); return 0; } /* Quick return if possible. */ if (*n == 0 || (alpha->r == 0. && alpha->i == 0. || *k == 0) && (beta->r == 1. && beta->i == 0.)) { return 0; } /* And when alpha.eq.zero. */ if (alpha->r == 0. && alpha->i == 0.) { if (upper) { if (beta->r == 0. && beta->i == 0.) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); c__[i__3].r = 0., c__[i__3].i = 0.; /* L10: */ } /* L20: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); i__4 = c___subscr(i__, j); z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] .i, z__1.i = beta->r * c__[i__4].i + beta->i * c__[i__4].r; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L30: */ } /* L40: */ } } } else { if (beta->r == 0. && beta->i == 0.) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); c__[i__3].r = 0., c__[i__3].i = 0.; /* L50: */ } /* L60: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); i__4 = c___subscr(i__, j); z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] .i, z__1.i = beta->r * c__[i__4].i + beta->i * c__[i__4].r; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L70: */ } /* L80: */ } } } return 0; } /* Start the operations. */ if (lsame_(trans, "N")) { /* Form C := alpha*A*A' + beta*C. */ if (upper) { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (beta->r == 0. && beta->i == 0.) { i__2 = j; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); c__[i__3].r = 0., c__[i__3].i = 0.; /* L90: */ } } else if (beta->r != 1. || beta->i != 0.) { i__2 = j; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); i__4 = c___subscr(i__, j); z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] .i, z__1.i = beta->r * c__[i__4].i + beta->i * c__[i__4].r; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L100: */ } } i__2 = *k; for (l = 1; l <= i__2; ++l) { i__3 = a_subscr(j, l); if (a[i__3].r != 0. || a[i__3].i != 0.) { i__3 = a_subscr(j, l); z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, z__1.i = alpha->r * a[i__3].i + alpha->i * a[ i__3].r; temp.r = z__1.r, temp.i = z__1.i; i__3 = j; for (i__ = 1; i__ <= i__3; ++i__) { i__4 = c___subscr(i__, j); i__5 = c___subscr(i__, j); i__6 = a_subscr(i__, l); z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, z__2.i = temp.r * a[i__6].i + temp.i * a[ i__6].r; z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5] .i + z__2.i; c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; /* L110: */ } } /* L120: */ } /* L130: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { if (beta->r == 0. && beta->i == 0.) { i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); c__[i__3].r = 0., c__[i__3].i = 0.; /* L140: */ } } else if (beta->r != 1. || beta->i != 0.) { i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); i__4 = c___subscr(i__, j); z__1.r = beta->r * c__[i__4].r - beta->i * c__[i__4] .i, z__1.i = beta->r * c__[i__4].i + beta->i * c__[i__4].r; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L150: */ } } i__2 = *k; for (l = 1; l <= i__2; ++l) { i__3 = a_subscr(j, l); if (a[i__3].r != 0. || a[i__3].i != 0.) { i__3 = a_subscr(j, l); z__1.r = alpha->r * a[i__3].r - alpha->i * a[i__3].i, z__1.i = alpha->r * a[i__3].i + alpha->i * a[ i__3].r; temp.r = z__1.r, temp.i = z__1.i; i__3 = *n; for (i__ = j; i__ <= i__3; ++i__) { i__4 = c___subscr(i__, j); i__5 = c___subscr(i__, j); i__6 = a_subscr(i__, l); z__2.r = temp.r * a[i__6].r - temp.i * a[i__6].i, z__2.i = temp.r * a[i__6].i + temp.i * a[ i__6].r; z__1.r = c__[i__5].r + z__2.r, z__1.i = c__[i__5] .i + z__2.i; c__[i__4].r = z__1.r, c__[i__4].i = z__1.i; /* L160: */ } } /* L170: */ } /* L180: */ } } } else { /* Form C := alpha*A'*A + beta*C. */ if (upper) { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = j; for (i__ = 1; i__ <= i__2; ++i__) { temp.r = 0., temp.i = 0.; i__3 = *k; for (l = 1; l <= i__3; ++l) { i__4 = a_subscr(l, i__); i__5 = a_subscr(l, j); z__2.r = a[i__4].r * a[i__5].r - a[i__4].i * a[i__5] .i, z__2.i = a[i__4].r * a[i__5].i + a[i__4] .i * a[i__5].r; z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; temp.r = z__1.r, temp.i = z__1.i; /* L190: */ } if (beta->r == 0. && beta->i == 0.) { i__3 = c___subscr(i__, j); z__1.r = alpha->r * temp.r - alpha->i * temp.i, z__1.i = alpha->r * temp.i + alpha->i * temp.r; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; } else { i__3 = c___subscr(i__, j); z__2.r = alpha->r * temp.r - alpha->i * temp.i, z__2.i = alpha->r * temp.i + alpha->i * temp.r; i__4 = c___subscr(i__, j); z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] .i, z__3.i = beta->r * c__[i__4].i + beta->i * c__[i__4].r; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; } /* L200: */ } /* L210: */ } } else { i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = j; i__ <= i__2; ++i__) { temp.r = 0., temp.i = 0.; i__3 = *k; for (l = 1; l <= i__3; ++l) { i__4 = a_subscr(l, i__); i__5 = a_subscr(l, j); z__2.r = a[i__4].r * a[i__5].r - a[i__4].i * a[i__5] .i, z__2.i = a[i__4].r * a[i__5].i + a[i__4] .i * a[i__5].r; z__1.r = temp.r + z__2.r, z__1.i = temp.i + z__2.i; temp.r = z__1.r, temp.i = z__1.i; /* L220: */ } if (beta->r == 0. && beta->i == 0.) { i__3 = c___subscr(i__, j); z__1.r = alpha->r * temp.r - alpha->i * temp.i, z__1.i = alpha->r * temp.i + alpha->i * temp.r; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; } else { i__3 = c___subscr(i__, j); z__2.r = alpha->r * temp.r - alpha->i * temp.i, z__2.i = alpha->r * temp.i + alpha->i * temp.r; i__4 = c___subscr(i__, j); z__3.r = beta->r * c__[i__4].r - beta->i * c__[i__4] .i, z__3.i = beta->r * c__[i__4].i + beta->i * c__[i__4].r; z__1.r = z__2.r + z__3.r, z__1.i = z__2.i + z__3.i; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; } /* L230: */ } /* L240: */ } } } return 0; /* End of ZSYRK . */ } /* zsyrk_ */
/* Subroutine */ int zlacrm_(integer *m, integer *n, doublecomplex *a, integer *lda, doublereal *b, integer *ldb, doublecomplex *c__, integer *ldc, doublereal *rwork) { /* -- LAPACK auxiliary routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= ZLACRM performs a very simple matrix-matrix multiplication: C := A * B, where A is M by N and complex; B is N by N and real; C is M by N and complex. Arguments ========= M (input) INTEGER The number of rows of the matrix A and of the matrix C. M >= 0. N (input) INTEGER The number of columns and rows of the matrix B and the number of columns of the matrix C. N >= 0. A (input) COMPLEX*16 array, dimension (LDA, N) A contains the M by N matrix A. LDA (input) INTEGER The leading dimension of the array A. LDA >=max(1,M). B (input) DOUBLE PRECISION array, dimension (LDB, N) B contains the N by N matrix B. LDB (input) INTEGER The leading dimension of the array B. LDB >=max(1,N). C (input) COMPLEX*16 array, dimension (LDC, N) C contains the M by N matrix C. LDC (input) INTEGER The leading dimension of the array C. LDC >=max(1,N). RWORK (workspace) DOUBLE PRECISION array, dimension (2*M*N) ===================================================================== Quick return if possible. Parameter adjustments */ /* Table of constant values */ static doublereal c_b6 = 1.; static doublereal c_b7 = 0.; /* System generated locals */ integer b_dim1, b_offset, a_dim1, a_offset, c_dim1, c_offset, i__1, i__2, i__3, i__4, i__5; doublereal d__1; doublecomplex z__1; /* Builtin functions */ double d_imag(doublecomplex *); /* Local variables */ static integer i__, j, l; extern /* Subroutine */ int dgemm_(char *, char *, integer *, integer *, integer *, doublereal *, doublereal *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *); #define a_subscr(a_1,a_2) (a_2)*a_dim1 + a_1 #define a_ref(a_1,a_2) a[a_subscr(a_1,a_2)] #define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1 #define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)] a_dim1 = *lda; a_offset = 1 + a_dim1 * 1; a -= a_offset; b_dim1 = *ldb; b_offset = 1 + b_dim1 * 1; b -= b_offset; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; --rwork; /* Function Body */ if (*m == 0 || *n == 0) { return 0; } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = a_subscr(i__, j); rwork[(j - 1) * *m + i__] = a[i__3].r; /* L10: */ } /* L20: */ } l = *m * *n + 1; dgemm_("N", "N", m, n, n, &c_b6, &rwork[1], m, &b[b_offset], ldb, &c_b7, & rwork[l], m); i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); i__4 = l + (j - 1) * *m + i__ - 1; c__[i__3].r = rwork[i__4], c__[i__3].i = 0.; /* L30: */ } /* L40: */ } i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { rwork[(j - 1) * *m + i__] = d_imag(&a_ref(i__, j)); /* L50: */ } /* L60: */ } dgemm_("N", "N", m, n, n, &c_b6, &rwork[1], m, &b[b_offset], ldb, &c_b7, & rwork[l], m); i__1 = *n; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); i__4 = c___subscr(i__, j); d__1 = c__[i__4].r; i__5 = l + (j - 1) * *m + i__ - 1; z__1.r = d__1, z__1.i = rwork[i__5]; c__[i__3].r = z__1.r, c__[i__3].i = z__1.i; /* L70: */ } /* L80: */ } return 0; /* End of ZLACRM */ } /* zlacrm_ */
/* Subroutine */ int clarfb_(char *side, char *trans, char *direct, char * storev, integer *m, integer *n, integer *k, complex *v, integer *ldv, complex *t, integer *ldt, complex *c__, integer *ldc, complex *work, integer *ldwork) { /* -- LAPACK auxiliary routine (version 3.0) -- Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., Courant Institute, Argonne National Lab, and Rice University September 30, 1994 Purpose ======= CLARFB applies a complex block reflector H or its transpose H' to a complex M-by-N matrix C, from either the left or the right. Arguments ========= SIDE (input) CHARACTER*1 = 'L': apply H or H' from the Left = 'R': apply H or H' from the Right TRANS (input) CHARACTER*1 = 'N': apply H (No transpose) = 'C': apply H' (Conjugate transpose) DIRECT (input) CHARACTER*1 Indicates how H is formed from a product of elementary reflectors = 'F': H = H(1) H(2) . . . H(k) (Forward) = 'B': H = H(k) . . . H(2) H(1) (Backward) STOREV (input) CHARACTER*1 Indicates how the vectors which define the elementary reflectors are stored: = 'C': Columnwise = 'R': Rowwise M (input) INTEGER The number of rows of the matrix C. N (input) INTEGER The number of columns of the matrix C. K (input) INTEGER The order of the matrix T (= the number of elementary reflectors whose product defines the block reflector). V (input) COMPLEX array, dimension (LDV,K) if STOREV = 'C' (LDV,M) if STOREV = 'R' and SIDE = 'L' (LDV,N) if STOREV = 'R' and SIDE = 'R' The matrix V. See further details. LDV (input) INTEGER The leading dimension of the array V. If STOREV = 'C' and SIDE = 'L', LDV >= max(1,M); if STOREV = 'C' and SIDE = 'R', LDV >= max(1,N); if STOREV = 'R', LDV >= K. T (input) COMPLEX array, dimension (LDT,K) The triangular K-by-K matrix T in the representation of the block reflector. LDT (input) INTEGER The leading dimension of the array T. LDT >= K. C (input/output) COMPLEX array, dimension (LDC,N) On entry, the M-by-N matrix C. On exit, C is overwritten by H*C or H'*C or C*H or C*H'. LDC (input) INTEGER The leading dimension of the array C. LDC >= max(1,M). WORK (workspace) COMPLEX array, dimension (LDWORK,K) LDWORK (input) INTEGER The leading dimension of the array WORK. If SIDE = 'L', LDWORK >= max(1,N); if SIDE = 'R', LDWORK >= max(1,M). ===================================================================== Quick return if possible Parameter adjustments */ /* Table of constant values */ static complex c_b1 = {1.f,0.f}; static integer c__1 = 1; /* System generated locals */ integer c_dim1, c_offset, t_dim1, t_offset, v_dim1, v_offset, work_dim1, work_offset, i__1, i__2, i__3, i__4, i__5; complex q__1, q__2; /* Builtin functions */ void r_cnjg(complex *, complex *); /* Local variables */ static integer i__, j; extern /* Subroutine */ int cgemm_(char *, char *, integer *, integer *, integer *, complex *, complex *, integer *, complex *, integer *, complex *, complex *, integer *); extern logical lsame_(char *, char *); extern /* Subroutine */ int ccopy_(integer *, complex *, integer *, complex *, integer *), ctrmm_(char *, char *, char *, char *, integer *, integer *, complex *, complex *, integer *, complex *, integer *), clacgv_(integer *, complex *, integer *); static char transt[1]; #define work_subscr(a_1,a_2) (a_2)*work_dim1 + a_1 #define work_ref(a_1,a_2) work[work_subscr(a_1,a_2)] #define c___subscr(a_1,a_2) (a_2)*c_dim1 + a_1 #define c___ref(a_1,a_2) c__[c___subscr(a_1,a_2)] #define v_subscr(a_1,a_2) (a_2)*v_dim1 + a_1 #define v_ref(a_1,a_2) v[v_subscr(a_1,a_2)] v_dim1 = *ldv; v_offset = 1 + v_dim1 * 1; v -= v_offset; t_dim1 = *ldt; t_offset = 1 + t_dim1 * 1; t -= t_offset; c_dim1 = *ldc; c_offset = 1 + c_dim1 * 1; c__ -= c_offset; work_dim1 = *ldwork; work_offset = 1 + work_dim1 * 1; work -= work_offset; /* Function Body */ if (*m <= 0 || *n <= 0) { return 0; } if (lsame_(trans, "N")) { *(unsigned char *)transt = 'C'; } else { *(unsigned char *)transt = 'N'; } if (lsame_(storev, "C")) { if (lsame_(direct, "F")) { /* Let V = ( V1 ) (first K rows) ( V2 ) where V1 is unit lower triangular. */ if (lsame_(side, "L")) { /* Form H * C or H' * C where C = ( C1 ) ( C2 ) W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) W := C1' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { ccopy_(n, &c___ref(j, 1), ldc, &work_ref(1, j), &c__1); clacgv_(n, &work_ref(1, j), &c__1); /* L10: */ } /* W := W * V1 */ ctrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork); if (*m > *k) { /* W := W + C2'*V2 */ i__1 = *m - *k; cgemm_("Conjugate transpose", "No transpose", n, k, &i__1, &c_b1, &c___ref(*k + 1, 1), ldc, &v_ref(*k + 1, 1), ldv, &c_b1, &work[work_offset], ldwork); } /* W := W * T' or W * T */ ctrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork); /* C := C - V * W' */ if (*m > *k) { /* C2 := C2 - V2 * W' */ i__1 = *m - *k; q__1.r = -1.f, q__1.i = 0.f; cgemm_("No transpose", "Conjugate transpose", &i__1, n, k, &q__1, &v_ref(*k + 1, 1), ldv, &work[work_offset] , ldwork, &c_b1, &c___ref(*k + 1, 1), ldc); } /* W := W * V1' */ ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", n, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork); /* C1 := C1 - W' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(j, i__); i__4 = c___subscr(j, i__); r_cnjg(&q__2, &work_ref(i__, j)); q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i - q__2.i; c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; /* L20: */ } /* L30: */ } } else if (lsame_(side, "R")) { /* Form C * H or C * H' where C = ( C1 C2 ) W := C * V = (C1*V1 + C2*V2) (stored in WORK) W := C1 */ i__1 = *k; for (j = 1; j <= i__1; ++j) { ccopy_(m, &c___ref(1, j), &c__1, &work_ref(1, j), &c__1); /* L40: */ } /* W := W * V1 */ ctrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork); if (*n > *k) { /* W := W + C2 * V2 */ i__1 = *n - *k; cgemm_("No transpose", "No transpose", m, k, &i__1, &c_b1, &c___ref(1, *k + 1), ldc, &v_ref(*k + 1, 1), ldv, &c_b1, &work[work_offset], ldwork); } /* W := W * T or W * T' */ ctrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork); /* C := C - W * V' */ if (*n > *k) { /* C2 := C2 - W * V2' */ i__1 = *n - *k; q__1.r = -1.f, q__1.i = 0.f; cgemm_("No transpose", "Conjugate transpose", m, &i__1, k, &q__1, &work[work_offset], ldwork, &v_ref(*k + 1, 1), ldv, &c_b1, &c___ref(1, *k + 1), ldc); } /* W := W * V1' */ ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", m, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork); /* C1 := C1 - W */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); i__4 = c___subscr(i__, j); i__5 = work_subscr(i__, j); q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[ i__4].i - work[i__5].i; c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; /* L50: */ } /* L60: */ } } } else { /* Let V = ( V1 ) ( V2 ) (last K rows) where V2 is unit upper triangular. */ if (lsame_(side, "L")) { /* Form H * C or H' * C where C = ( C1 ) ( C2 ) W := C' * V = (C1'*V1 + C2'*V2) (stored in WORK) W := C2' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { ccopy_(n, &c___ref(*m - *k + j, 1), ldc, &work_ref(1, j), &c__1); clacgv_(n, &work_ref(1, j), &c__1); /* L70: */ } /* W := W * V2 */ ctrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b1, &v_ref(*m - *k + 1, 1), ldv, &work[work_offset], ldwork); if (*m > *k) { /* W := W + C1'*V1 */ i__1 = *m - *k; cgemm_("Conjugate transpose", "No transpose", n, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, & c_b1, &work[work_offset], ldwork); } /* W := W * T' or W * T */ ctrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork); /* C := C - V * W' */ if (*m > *k) { /* C1 := C1 - V1 * W' */ i__1 = *m - *k; q__1.r = -1.f, q__1.i = 0.f; cgemm_("No transpose", "Conjugate transpose", &i__1, n, k, &q__1, &v[v_offset], ldv, &work[work_offset], ldwork, &c_b1, &c__[c_offset], ldc); } /* W := W * V2' */ ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", n, k, &c_b1, &v_ref(*m - *k + 1, 1), ldv, &work[work_offset] , ldwork) ; /* C2 := C2 - W' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(*m - *k + j, i__); i__4 = c___subscr(*m - *k + j, i__); r_cnjg(&q__2, &work_ref(i__, j)); q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i - q__2.i; c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; /* L80: */ } /* L90: */ } } else if (lsame_(side, "R")) { /* Form C * H or C * H' where C = ( C1 C2 ) W := C * V = (C1*V1 + C2*V2) (stored in WORK) W := C2 */ i__1 = *k; for (j = 1; j <= i__1; ++j) { ccopy_(m, &c___ref(1, *n - *k + j), &c__1, &work_ref(1, j) , &c__1); /* L100: */ } /* W := W * V2 */ ctrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b1, &v_ref(*n - *k + 1, 1), ldv, &work[work_offset], ldwork); if (*n > *k) { /* W := W + C1 * V1 */ i__1 = *n - *k; cgemm_("No transpose", "No transpose", m, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, &c_b1, & work[work_offset], ldwork) ; } /* W := W * T or W * T' */ ctrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork); /* C := C - W * V' */ if (*n > *k) { /* C1 := C1 - W * V1' */ i__1 = *n - *k; q__1.r = -1.f, q__1.i = 0.f; cgemm_("No transpose", "Conjugate transpose", m, &i__1, k, &q__1, &work[work_offset], ldwork, &v[v_offset], ldv, &c_b1, &c__[c_offset], ldc); } /* W := W * V2' */ ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", m, k, &c_b1, &v_ref(*n - *k + 1, 1), ldv, &work[work_offset] , ldwork) ; /* C2 := C2 - W */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, *n - *k + j); i__4 = c___subscr(i__, *n - *k + j); i__5 = work_subscr(i__, j); q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[ i__4].i - work[i__5].i; c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; /* L110: */ } /* L120: */ } } } } else if (lsame_(storev, "R")) { if (lsame_(direct, "F")) { /* Let V = ( V1 V2 ) (V1: first K columns) where V1 is unit upper triangular. */ if (lsame_(side, "L")) { /* Form H * C or H' * C where C = ( C1 ) ( C2 ) W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) W := C1' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { ccopy_(n, &c___ref(j, 1), ldc, &work_ref(1, j), &c__1); clacgv_(n, &work_ref(1, j), &c__1); /* L130: */ } /* W := W * V1' */ ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", n, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork); if (*m > *k) { /* W := W + C2'*V2' */ i__1 = *m - *k; cgemm_("Conjugate transpose", "Conjugate transpose", n, k, &i__1, &c_b1, &c___ref(*k + 1, 1), ldc, &v_ref(1, *k + 1), ldv, &c_b1, &work[work_offset], ldwork); } /* W := W * T' or W * T */ ctrmm_("Right", "Upper", transt, "Non-unit", n, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork); /* C := C - V' * W' */ if (*m > *k) { /* C2 := C2 - V2' * W' */ i__1 = *m - *k; q__1.r = -1.f, q__1.i = 0.f; cgemm_("Conjugate transpose", "Conjugate transpose", & i__1, n, k, &q__1, &v_ref(1, *k + 1), ldv, &work[ work_offset], ldwork, &c_b1, &c___ref(*k + 1, 1), ldc); } /* W := W * V1 */ ctrmm_("Right", "Upper", "No transpose", "Unit", n, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork); /* C1 := C1 - W' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(j, i__); i__4 = c___subscr(j, i__); r_cnjg(&q__2, &work_ref(i__, j)); q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i - q__2.i; c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; /* L140: */ } /* L150: */ } } else if (lsame_(side, "R")) { /* Form C * H or C * H' where C = ( C1 C2 ) W := C * V' = (C1*V1' + C2*V2') (stored in WORK) W := C1 */ i__1 = *k; for (j = 1; j <= i__1; ++j) { ccopy_(m, &c___ref(1, j), &c__1, &work_ref(1, j), &c__1); /* L160: */ } /* W := W * V1' */ ctrmm_("Right", "Upper", "Conjugate transpose", "Unit", m, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork); if (*n > *k) { /* W := W + C2 * V2' */ i__1 = *n - *k; cgemm_("No transpose", "Conjugate transpose", m, k, &i__1, &c_b1, &c___ref(1, *k + 1), ldc, &v_ref(1, *k + 1), ldv, &c_b1, &work[work_offset], ldwork); } /* W := W * T or W * T' */ ctrmm_("Right", "Upper", trans, "Non-unit", m, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork); /* C := C - W * V */ if (*n > *k) { /* C2 := C2 - W * V2 */ i__1 = *n - *k; q__1.r = -1.f, q__1.i = 0.f; cgemm_("No transpose", "No transpose", m, &i__1, k, &q__1, &work[work_offset], ldwork, &v_ref(1, *k + 1), ldv, &c_b1, &c___ref(1, *k + 1), ldc); } /* W := W * V1 */ ctrmm_("Right", "Upper", "No transpose", "Unit", m, k, &c_b1, &v[v_offset], ldv, &work[work_offset], ldwork); /* C1 := C1 - W */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, j); i__4 = c___subscr(i__, j); i__5 = work_subscr(i__, j); q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[ i__4].i - work[i__5].i; c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; /* L170: */ } /* L180: */ } } } else { /* Let V = ( V1 V2 ) (V2: last K columns) where V2 is unit lower triangular. */ if (lsame_(side, "L")) { /* Form H * C or H' * C where C = ( C1 ) ( C2 ) W := C' * V' = (C1'*V1' + C2'*V2') (stored in WORK) W := C2' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { ccopy_(n, &c___ref(*m - *k + j, 1), ldc, &work_ref(1, j), &c__1); clacgv_(n, &work_ref(1, j), &c__1); /* L190: */ } /* W := W * V2' */ ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", n, k, &c_b1, &v_ref(1, *m - *k + 1), ldv, &work[work_offset] , ldwork) ; if (*m > *k) { /* W := W + C1'*V1' */ i__1 = *m - *k; cgemm_("Conjugate transpose", "Conjugate transpose", n, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, &c_b1, &work[work_offset], ldwork); } /* W := W * T' or W * T */ ctrmm_("Right", "Lower", transt, "Non-unit", n, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork); /* C := C - V' * W' */ if (*m > *k) { /* C1 := C1 - V1' * W' */ i__1 = *m - *k; q__1.r = -1.f, q__1.i = 0.f; cgemm_("Conjugate transpose", "Conjugate transpose", & i__1, n, k, &q__1, &v[v_offset], ldv, &work[ work_offset], ldwork, &c_b1, &c__[c_offset], ldc); } /* W := W * V2 */ ctrmm_("Right", "Lower", "No transpose", "Unit", n, k, &c_b1, &v_ref(1, *m - *k + 1), ldv, &work[work_offset], ldwork); /* C2 := C2 - W' */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *n; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(*m - *k + j, i__); i__4 = c___subscr(*m - *k + j, i__); r_cnjg(&q__2, &work_ref(i__, j)); q__1.r = c__[i__4].r - q__2.r, q__1.i = c__[i__4].i - q__2.i; c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; /* L200: */ } /* L210: */ } } else if (lsame_(side, "R")) { /* Form C * H or C * H' where C = ( C1 C2 ) W := C * V' = (C1*V1' + C2*V2') (stored in WORK) W := C2 */ i__1 = *k; for (j = 1; j <= i__1; ++j) { ccopy_(m, &c___ref(1, *n - *k + j), &c__1, &work_ref(1, j) , &c__1); /* L220: */ } /* W := W * V2' */ ctrmm_("Right", "Lower", "Conjugate transpose", "Unit", m, k, &c_b1, &v_ref(1, *n - *k + 1), ldv, &work[work_offset] , ldwork) ; if (*n > *k) { /* W := W + C1 * V1' */ i__1 = *n - *k; cgemm_("No transpose", "Conjugate transpose", m, k, &i__1, &c_b1, &c__[c_offset], ldc, &v[v_offset], ldv, & c_b1, &work[work_offset], ldwork); } /* W := W * T or W * T' */ ctrmm_("Right", "Lower", trans, "Non-unit", m, k, &c_b1, &t[ t_offset], ldt, &work[work_offset], ldwork); /* C := C - W * V */ if (*n > *k) { /* C1 := C1 - W * V1 */ i__1 = *n - *k; q__1.r = -1.f, q__1.i = 0.f; cgemm_("No transpose", "No transpose", m, &i__1, k, &q__1, &work[work_offset], ldwork, &v[v_offset], ldv, & c_b1, &c__[c_offset], ldc) ; } /* W := W * V2 */ ctrmm_("Right", "Lower", "No transpose", "Unit", m, k, &c_b1, &v_ref(1, *n - *k + 1), ldv, &work[work_offset], ldwork); /* C1 := C1 - W */ i__1 = *k; for (j = 1; j <= i__1; ++j) { i__2 = *m; for (i__ = 1; i__ <= i__2; ++i__) { i__3 = c___subscr(i__, *n - *k + j); i__4 = c___subscr(i__, *n - *k + j); i__5 = work_subscr(i__, j); q__1.r = c__[i__4].r - work[i__5].r, q__1.i = c__[ i__4].i - work[i__5].i; c__[i__3].r = q__1.r, c__[i__3].i = q__1.i; /* L230: */ } /* L240: */ } } } } return 0; /* End of CLARFB */ } /* clarfb_ */