00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013
00014
00015
00016
00017
00018
00019
00020
00021
00022
00023
00024
00025
00026
00027
00028
00029
00030
00031
00032
00033
00034
00035 #ifndef TEMPLATE_LAPACK_ORGQR_HEADER
00036 #define TEMPLATE_LAPACK_ORGQR_HEADER
00037
00038 #include "template_lapack_common.h"
00039
00040 template<class Treal>
00041 int template_lapack_orgqr(
00042 const integer *m,
00043 const integer *n,
00044 const integer *k,
00045 Treal * a,
00046 const integer *lda,
00047 const Treal *tau,
00048 Treal *work,
00049 const integer *lwork,
00050 integer *info
00051 )
00052 {
00053
00054
00055
00056
00057
00058
00059
00060
00061
00062
00063
00064
00065
00066
00067
00068
00069
00070
00071
00072
00073
00074
00075
00076
00077
00078
00079
00080
00081
00082
00083
00084
00085
00086
00087
00088
00089
00090
00091
00092
00093
00094
00095
00096
00097
00098
00099
00100
00101
00102
00103
00104
00105
00106
00107
00108
00109
00110
00111
00112
00113
00114
00115
00116
00117
00118
00119
00120
00121 integer c__1 = 1;
00122 integer c_n1 = -1;
00123 integer c__3 = 3;
00124 integer c__2 = 2;
00125
00126
00127 integer a_dim1, a_offset, i__1, i__2, i__3;
00128
00129 integer i__, j, l, nbmin, iinfo;
00130 integer ib, nb, ki, kk;
00131 integer nx;
00132 integer ldwork, lwkopt;
00133 logical lquery;
00134 integer iws;
00135 #define a_ref(a_1,a_2) a[(a_2)*a_dim1 + a_1]
00136
00137
00138 a_dim1 = *lda;
00139 a_offset = 1 + a_dim1 * 1;
00140 a -= a_offset;
00141 --tau;
00142 --work;
00143
00144
00145 ki = 0;
00146
00147 *info = 0;
00148 nb = template_lapack_ilaenv(&c__1, "DORGQR", " ", m, n, k, &c_n1, (ftnlen)6, (ftnlen)1);
00149 lwkopt = maxMACRO(1,*n) * nb;
00150 work[1] = (Treal) lwkopt;
00151 lquery = *lwork == -1;
00152 if (*m < 0) {
00153 *info = -1;
00154 } else if (*n < 0 || *n > *m) {
00155 *info = -2;
00156 } else if (*k < 0 || *k > *n) {
00157 *info = -3;
00158 } else if (*lda < maxMACRO(1,*m)) {
00159 *info = -5;
00160 } else if (*lwork < maxMACRO(1,*n) && ! lquery) {
00161 *info = -8;
00162 }
00163 if (*info != 0) {
00164 i__1 = -(*info);
00165 template_blas_erbla("ORGQR ", &i__1);
00166 return 0;
00167 } else if (lquery) {
00168 return 0;
00169 }
00170
00171
00172
00173 if (*n <= 0) {
00174 work[1] = 1.;
00175 return 0;
00176 }
00177
00178 nbmin = 2;
00179 nx = 0;
00180 iws = *n;
00181 if (nb > 1 && nb < *k) {
00182
00183
00184
00185
00186 i__1 = 0, i__2 = template_lapack_ilaenv(&c__3, "DORGQR", " ", m, n, k, &c_n1, (
00187 ftnlen)6, (ftnlen)1);
00188 nx = maxMACRO(i__1,i__2);
00189 if (nx < *k) {
00190
00191
00192
00193 ldwork = *n;
00194 iws = ldwork * nb;
00195 if (*lwork < iws) {
00196
00197
00198
00199
00200 nb = *lwork / ldwork;
00201
00202 i__1 = 2, i__2 = template_lapack_ilaenv(&c__2, "DORGQR", " ", m, n, k, &c_n1,
00203 (ftnlen)6, (ftnlen)1);
00204 nbmin = maxMACRO(i__1,i__2);
00205 }
00206 }
00207 }
00208
00209 if (nb >= nbmin && nb < *k && nx < *k) {
00210
00211
00212
00213
00214 ki = (*k - nx - 1) / nb * nb;
00215
00216 i__1 = *k, i__2 = ki + nb;
00217 kk = minMACRO(i__1,i__2);
00218
00219
00220
00221 i__1 = *n;
00222 for (j = kk + 1; j <= i__1; ++j) {
00223 i__2 = kk;
00224 for (i__ = 1; i__ <= i__2; ++i__) {
00225 a_ref(i__, j) = 0.;
00226
00227 }
00228
00229 }
00230 } else {
00231 kk = 0;
00232 }
00233
00234
00235
00236 if (kk < *n) {
00237 i__1 = *m - kk;
00238 i__2 = *n - kk;
00239 i__3 = *k - kk;
00240 template_lapack_org2r(&i__1, &i__2, &i__3, &a_ref(kk + 1, kk + 1), lda, &tau[kk + 1]
00241 , &work[1], &iinfo);
00242 }
00243
00244 if (kk > 0) {
00245
00246
00247
00248 i__1 = -nb;
00249 for (i__ = ki + 1; i__1 < 0 ? i__ >= 1 : i__ <= 1; i__ += i__1) {
00250
00251 i__2 = nb, i__3 = *k - i__ + 1;
00252 ib = minMACRO(i__2,i__3);
00253 if (i__ + ib <= *n) {
00254
00255
00256
00257
00258 i__2 = *m - i__ + 1;
00259 template_lapack_larft("Forward", "Columnwise", &i__2, &ib, &a_ref(i__, i__),
00260 lda, &tau[i__], &work[1], &ldwork);
00261
00262
00263
00264 i__2 = *m - i__ + 1;
00265 i__3 = *n - i__ - ib + 1;
00266 template_lapack_larfb("Left", "No transpose", "Forward", "Columnwise", &
00267 i__2, &i__3, &ib, &a_ref(i__, i__), lda, &work[1], &
00268 ldwork, &a_ref(i__, i__ + ib), lda, &work[ib + 1], &
00269 ldwork);
00270 }
00271
00272
00273
00274 i__2 = *m - i__ + 1;
00275 template_lapack_org2r(&i__2, &ib, &ib, &a_ref(i__, i__), lda, &tau[i__], &work[
00276 1], &iinfo);
00277
00278
00279
00280 i__2 = i__ + ib - 1;
00281 for (j = i__; j <= i__2; ++j) {
00282 i__3 = i__ - 1;
00283 for (l = 1; l <= i__3; ++l) {
00284 a_ref(l, j) = 0.;
00285
00286 }
00287
00288 }
00289
00290 }
00291 }
00292
00293 work[1] = (Treal) iws;
00294 return 0;
00295
00296
00297
00298 }
00299
00300 #undef a_ref
00301
00302
00303 #endif