libflame
revision_anchor
|
Functions | |
int | dopgtr_ (char *uplo, integer *n, doublereal *ap, doublereal *tau, doublereal *q, integer *ldq, doublereal *work, integer *info) |
int dopgtr_ | ( | char * | uplo, |
integer * | n, | ||
doublereal * | ap, | ||
doublereal * | tau, | ||
doublereal * | q, | ||
integer * | ldq, | ||
doublereal * | work, | ||
integer * | info | ||
) |
References dorg2r_fla().
{ /* System generated locals */ integer q_dim1, q_offset, i__1, i__2, i__3; /* Local variables */ integer i__, j, ij; extern logical lsame_(char *, char *); integer iinfo; logical upper; extern /* Subroutine */ int dorg2l_(integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), dorg2r_fla(integer *, integer *, integer *, doublereal *, integer *, doublereal *, doublereal *, integer *), xerbla_(char *, integer *); /* -- LAPACK computational routine (version 3.4.0) -- */ /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */ /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */ /* November 2011 */ /* .. Scalar Arguments .. */ /* .. */ /* .. Array Arguments .. */ /* .. */ /* ===================================================================== */ /* .. Parameters .. */ /* .. */ /* .. Local Scalars .. */ /* .. */ /* .. External Functions .. */ /* .. */ /* .. External Subroutines .. */ /* .. */ /* .. Intrinsic Functions .. */ /* .. */ /* .. Executable Statements .. */ /* Test the input arguments */ /* Parameter adjustments */ --ap; --tau; q_dim1 = *ldq; q_offset = 1 + q_dim1; q -= q_offset; --work; /* Function Body */ *info = 0; upper = lsame_(uplo, "U"); if (! upper && ! lsame_(uplo, "L")) { *info = -1; } else if (*n < 0) { *info = -2; } else if (*ldq < max(1,*n)) { *info = -6; } if (*info != 0) { i__1 = -(*info); xerbla_("DOPGTR", &i__1); return 0; } /* Quick return if possible */ if (*n == 0) { return 0; } if (upper) { /* Q was determined by a call to DSPTRD with UPLO = 'U' */ /* Unpack the vectors which define the elementary reflectors and */ /* set the last row and column of Q equal to those of the unit */ /* matrix */ ij = 2; i__1 = *n - 1; for (j = 1; j <= i__1; ++j) { i__2 = j - 1; for (i__ = 1; i__ <= i__2; ++i__) { q[i__ + j * q_dim1] = ap[ij]; ++ij; /* L10: */ } ij += 2; q[*n + j * q_dim1] = 0.; /* L20: */ } i__1 = *n - 1; for (i__ = 1; i__ <= i__1; ++i__) { q[i__ + *n * q_dim1] = 0.; /* L30: */ } q[*n + *n * q_dim1] = 1.; /* Generate Q(1:n-1,1:n-1) */ i__1 = *n - 1; i__2 = *n - 1; i__3 = *n - 1; dorg2l_(&i__1, &i__2, &i__3, &q[q_offset], ldq, &tau[1], &work[1], & iinfo); } else { /* Q was determined by a call to DSPTRD with UPLO = 'L'. */ /* Unpack the vectors which define the elementary reflectors and */ /* set the first row and column of Q equal to those of the unit */ /* matrix */ q[q_dim1 + 1] = 1.; i__1 = *n; for (i__ = 2; i__ <= i__1; ++i__) { q[i__ + q_dim1] = 0.; /* L40: */ } ij = 3; i__1 = *n; for (j = 2; j <= i__1; ++j) { q[j * q_dim1 + 1] = 0.; i__2 = *n; for (i__ = j + 1; i__ <= i__2; ++i__) { q[i__ + j * q_dim1] = ap[ij]; ++ij; /* L50: */ } ij += 2; /* L60: */ } if (*n > 1) { /* Generate Q(2:n,2:n) */ i__1 = *n - 1; i__2 = *n - 1; i__3 = *n - 1; dorg2r_fla(&i__1, &i__2, &i__3, &q[(q_dim1 << 1) + 2], ldq, &tau[1], &work[1], &iinfo); } } return 0; /* End of DOPGTR */ }