00001
00002
00003
00004
00005
00006
00007
00008
00009
00010
00011
00012
00013 #include "f2c.h"
00014 #include "blaswrap.h"
00015
00016
00017
00018 static complex c_b2 = {1.f,0.f};
00019 static integer c__1 = 1;
00020 static integer c_n1 = -1;
00021
00022 int cggglm_(integer *n, integer *m, integer *p, complex *a,
00023 integer *lda, complex *b, integer *ldb, complex *d__, complex *x,
00024 complex *y, complex *work, integer *lwork, integer *info)
00025 {
00026
00027 integer a_dim1, a_offset, b_dim1, b_offset, i__1, i__2, i__3, i__4;
00028 complex q__1;
00029
00030
00031 integer i__, nb, np, nb1, nb2, nb3, nb4, lopt;
00032 extern int cgemv_(char *, integer *, integer *, complex *
00033 , complex *, integer *, complex *, integer *, complex *, complex *
00034 , integer *), ccopy_(integer *, complex *, integer *,
00035 complex *, integer *), cggqrf_(integer *, integer *, integer *,
00036 complex *, integer *, complex *, complex *, integer *, complex *,
00037 complex *, integer *, integer *), xerbla_(char *, integer *);
00038 extern integer ilaenv_(integer *, char *, char *, integer *, integer *,
00039 integer *, integer *);
00040 integer lwkmin;
00041 extern int cunmqr_(char *, char *, integer *, integer *,
00042 integer *, complex *, integer *, complex *, complex *, integer *,
00043 complex *, integer *, integer *), cunmrq_(char *,
00044 char *, integer *, integer *, integer *, complex *, integer *,
00045 complex *, complex *, integer *, complex *, integer *, integer *);
00046 integer lwkopt;
00047 logical lquery;
00048 extern int ctrtrs_(char *, char *, char *, integer *,
00049 integer *, complex *, integer *, complex *, integer *, integer *);
00050
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
00122
00123
00124
00125
00126
00127
00128
00129
00130
00131
00132
00133
00134
00135
00136
00137
00138
00139
00140
00141
00142
00143
00144
00145
00146
00147
00148
00149
00150
00151
00152
00153
00154
00155
00156
00157
00158
00159
00160
00161
00162
00163
00164
00165
00166
00167
00168
00169
00170
00171
00172
00173 a_dim1 = *lda;
00174 a_offset = 1 + a_dim1;
00175 a -= a_offset;
00176 b_dim1 = *ldb;
00177 b_offset = 1 + b_dim1;
00178 b -= b_offset;
00179 --d__;
00180 --x;
00181 --y;
00182 --work;
00183
00184
00185 *info = 0;
00186 np = min(*n,*p);
00187 lquery = *lwork == -1;
00188 if (*n < 0) {
00189 *info = -1;
00190 } else if (*m < 0 || *m > *n) {
00191 *info = -2;
00192 } else if (*p < 0 || *p < *n - *m) {
00193 *info = -3;
00194 } else if (*lda < max(1,*n)) {
00195 *info = -5;
00196 } else if (*ldb < max(1,*n)) {
00197 *info = -7;
00198 }
00199
00200
00201
00202 if (*info == 0) {
00203 if (*n == 0) {
00204 lwkmin = 1;
00205 lwkopt = 1;
00206 } else {
00207 nb1 = ilaenv_(&c__1, "CGEQRF", " ", n, m, &c_n1, &c_n1);
00208 nb2 = ilaenv_(&c__1, "CGERQF", " ", n, m, &c_n1, &c_n1);
00209 nb3 = ilaenv_(&c__1, "CUNMQR", " ", n, m, p, &c_n1);
00210 nb4 = ilaenv_(&c__1, "CUNMRQ", " ", n, m, p, &c_n1);
00211
00212 i__1 = max(nb1,nb2), i__1 = max(i__1,nb3);
00213 nb = max(i__1,nb4);
00214 lwkmin = *m + *n + *p;
00215 lwkopt = *m + np + max(*n,*p) * nb;
00216 }
00217 work[1].r = (real) lwkopt, work[1].i = 0.f;
00218
00219 if (*lwork < lwkmin && ! lquery) {
00220 *info = -12;
00221 }
00222 }
00223
00224 if (*info != 0) {
00225 i__1 = -(*info);
00226 xerbla_("CGGGLM", &i__1);
00227 return 0;
00228 } else if (lquery) {
00229 return 0;
00230 }
00231
00232
00233
00234 if (*n == 0) {
00235 return 0;
00236 }
00237
00238
00239
00240
00241
00242
00243
00244
00245
00246
00247 i__1 = *lwork - *m - np;
00248 cggqrf_(n, m, p, &a[a_offset], lda, &work[1], &b[b_offset], ldb, &work[*m
00249 + 1], &work[*m + np + 1], &i__1, info);
00250 i__1 = *m + np + 1;
00251 lopt = work[i__1].r;
00252
00253
00254
00255
00256 i__1 = max(1,*n);
00257 i__2 = *lwork - *m - np;
00258 cunmqr_("Left", "Conjugate transpose", n, &c__1, m, &a[a_offset], lda, &
00259 work[1], &d__[1], &i__1, &work[*m + np + 1], &i__2, info);
00260
00261 i__3 = *m + np + 1;
00262 i__1 = lopt, i__2 = (integer) work[i__3].r;
00263 lopt = max(i__1,i__2);
00264
00265
00266
00267 if (*n > *m) {
00268 i__1 = *n - *m;
00269 i__2 = *n - *m;
00270 ctrtrs_("Upper", "No transpose", "Non unit", &i__1, &c__1, &b[*m + 1
00271 + (*m + *p - *n + 1) * b_dim1], ldb, &d__[*m + 1], &i__2,
00272 info);
00273
00274 if (*info > 0) {
00275 *info = 1;
00276 return 0;
00277 }
00278
00279 i__1 = *n - *m;
00280 ccopy_(&i__1, &d__[*m + 1], &c__1, &y[*m + *p - *n + 1], &c__1);
00281 }
00282
00283
00284
00285 i__1 = *m + *p - *n;
00286 for (i__ = 1; i__ <= i__1; ++i__) {
00287 i__2 = i__;
00288 y[i__2].r = 0.f, y[i__2].i = 0.f;
00289
00290 }
00291
00292
00293
00294 i__1 = *n - *m;
00295 q__1.r = -1.f, q__1.i = -0.f;
00296 cgemv_("No transpose", m, &i__1, &q__1, &b[(*m + *p - *n + 1) * b_dim1 +
00297 1], ldb, &y[*m + *p - *n + 1], &c__1, &c_b2, &d__[1], &c__1);
00298
00299
00300
00301 if (*m > 0) {
00302 ctrtrs_("Upper", "No Transpose", "Non unit", m, &c__1, &a[a_offset],
00303 lda, &d__[1], m, info);
00304
00305 if (*info > 0) {
00306 *info = 2;
00307 return 0;
00308 }
00309
00310
00311
00312 ccopy_(m, &d__[1], &c__1, &x[1], &c__1);
00313 }
00314
00315
00316
00317
00318 i__1 = 1, i__2 = *n - *p + 1;
00319 i__3 = max(1,*p);
00320 i__4 = *lwork - *m - np;
00321 cunmrq_("Left", "Conjugate transpose", p, &c__1, &np, &b[max(i__1, i__2)+
00322 b_dim1], ldb, &work[*m + 1], &y[1], &i__3, &work[*m + np + 1], &
00323 i__4, info);
00324
00325 i__4 = *m + np + 1;
00326 i__2 = lopt, i__3 = (integer) work[i__4].r;
00327 i__1 = *m + np + max(i__2,i__3);
00328 work[1].r = (real) i__1, work[1].i = 0.f;
00329
00330 return 0;
00331
00332
00333
00334 }