00001 /* zgeqrs.f -- translated by f2c (version 20061008). 00002 You must link the resulting object file with libf2c: 00003 on Microsoft Windows system, link with libf2c.lib; 00004 on Linux or Unix systems, link with .../path/to/libf2c.a -lm 00005 or, if you install libf2c.a in a standard place, with -lf2c -lm 00006 -- in that order, at the end of the command line, as in 00007 cc *.o -lf2c -lm 00008 Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., 00009 00010 http://www.netlib.org/f2c/libf2c.zip 00011 */ 00012 00013 #include "f2c.h" 00014 #include "blaswrap.h" 00015 00016 /* Table of constant values */ 00017 00018 static doublecomplex c_b1 = {1.,0.}; 00019 00020 /* Subroutine */ int zgeqrs_(integer *m, integer *n, integer *nrhs, 00021 doublecomplex *a, integer *lda, doublecomplex *tau, doublecomplex *b, 00022 integer *ldb, doublecomplex *work, integer *lwork, integer *info) 00023 { 00024 /* System generated locals */ 00025 integer a_dim1, a_offset, b_dim1, b_offset, i__1; 00026 00027 /* Local variables */ 00028 extern /* Subroutine */ int ztrsm_(char *, char *, char *, char *, 00029 integer *, integer *, doublecomplex *, doublecomplex *, integer *, 00030 doublecomplex *, integer *), 00031 xerbla_(char *, integer *), zunmqr_(char *, char *, 00032 integer *, integer *, integer *, doublecomplex *, integer *, 00033 doublecomplex *, doublecomplex *, integer *, doublecomplex *, 00034 integer *, integer *); 00035 00036 00037 /* -- LAPACK routine (version 3.1) -- */ 00038 /* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ 00039 /* November 2006 */ 00040 00041 /* .. Scalar Arguments .. */ 00042 /* .. */ 00043 /* .. Array Arguments .. */ 00044 /* .. */ 00045 00046 /* Purpose */ 00047 /* ======= */ 00048 00049 /* Solve the least squares problem */ 00050 /* min || A*X - B || */ 00051 /* using the QR factorization */ 00052 /* A = Q*R */ 00053 /* computed by ZGEQRF. */ 00054 00055 /* Arguments */ 00056 /* ========= */ 00057 00058 /* M (input) INTEGER */ 00059 /* The number of rows of the matrix A. M >= 0. */ 00060 00061 /* N (input) INTEGER */ 00062 /* The number of columns of the matrix A. M >= N >= 0. */ 00063 00064 /* NRHS (input) INTEGER */ 00065 /* The number of columns of B. NRHS >= 0. */ 00066 00067 /* A (input) COMPLEX*16 array, dimension (LDA,N) */ 00068 /* Details of the QR factorization of the original matrix A as */ 00069 /* returned by ZGEQRF. */ 00070 00071 /* LDA (input) INTEGER */ 00072 /* The leading dimension of the array A. LDA >= M. */ 00073 00074 /* TAU (input) COMPLEX*16 array, dimension (N) */ 00075 /* Details of the orthogonal matrix Q. */ 00076 00077 /* B (input/output) COMPLEX*16 array, dimension (LDB,NRHS) */ 00078 /* On entry, the m-by-nrhs right hand side matrix B. */ 00079 /* On exit, the n-by-nrhs solution matrix X. */ 00080 00081 /* LDB (input) INTEGER */ 00082 /* The leading dimension of the array B. LDB >= M. */ 00083 00084 /* WORK (workspace) COMPLEX*16 array, dimension (LWORK) */ 00085 00086 /* LWORK (input) INTEGER */ 00087 /* The length of the array WORK. LWORK must be at least NRHS, */ 00088 /* and should be at least NRHS*NB, where NB is the block size */ 00089 /* for this environment. */ 00090 00091 /* INFO (output) INTEGER */ 00092 /* = 0: successful exit */ 00093 /* < 0: if INFO = -i, the i-th argument had an illegal value */ 00094 00095 /* ===================================================================== */ 00096 00097 /* .. Parameters .. */ 00098 /* .. */ 00099 /* .. External Subroutines .. */ 00100 /* .. */ 00101 /* .. Intrinsic Functions .. */ 00102 /* .. */ 00103 /* .. Executable Statements .. */ 00104 00105 /* Test the input arguments. */ 00106 00107 /* Parameter adjustments */ 00108 a_dim1 = *lda; 00109 a_offset = 1 + a_dim1; 00110 a -= a_offset; 00111 --tau; 00112 b_dim1 = *ldb; 00113 b_offset = 1 + b_dim1; 00114 b -= b_offset; 00115 --work; 00116 00117 /* Function Body */ 00118 *info = 0; 00119 if (*m < 0) { 00120 *info = -1; 00121 } else if (*n < 0 || *n > *m) { 00122 *info = -2; 00123 } else if (*nrhs < 0) { 00124 *info = -3; 00125 } else if (*lda < max(1,*m)) { 00126 *info = -5; 00127 } else if (*ldb < max(1,*m)) { 00128 *info = -8; 00129 } else if (*lwork < 1 || *lwork < *nrhs && *m > 0 && *n > 0) { 00130 *info = -10; 00131 } 00132 if (*info != 0) { 00133 i__1 = -(*info); 00134 xerbla_("ZGEQRS", &i__1); 00135 return 0; 00136 } 00137 00138 /* Quick return if possible */ 00139 00140 if (*n == 0 || *nrhs == 0 || *m == 0) { 00141 return 0; 00142 } 00143 00144 /* B := Q' * B */ 00145 00146 zunmqr_("Left", "Conjugate transpose", m, nrhs, n, &a[a_offset], lda, & 00147 tau[1], &b[b_offset], ldb, &work[1], lwork, info); 00148 00149 /* Solve R*X = B(1:n,:) */ 00150 00151 ztrsm_("Left", "Upper", "No transpose", "Non-unit", n, nrhs, &c_b1, &a[ 00152 a_offset], lda, &b[b_offset], ldb); 00153 00154 return 0; 00155 00156 /* End of ZGEQRS */ 00157 00158 } /* zgeqrs_ */