1 /* ./src_f77/sgeql2.f -- translated by f2c (version 20030320).
2 You must link the resulting object file with the libraries:
3 -lf2c -lm (in that order)
4 */
5
6 #include <punc/vf2c.h>
7
8 /* Table of constant values */
9
10 static integer c__1 = 1;
11
sgeql2_(integer * m,integer * n,real * a,integer * lda,real * tau,real * work,integer * info)12 /* Subroutine */ int sgeql2_(integer *m, integer *n, real *a, integer *lda,
13 real *tau, real *work, integer *info)
14 {
15 /* System generated locals */
16 integer a_dim1, a_offset, i__1, i__2;
17
18 /* Local variables */
19 static integer i__, k;
20 static real aii;
21 extern /* Subroutine */ int slarf_(char *, integer *, integer *, real *,
22 integer *, real *, real *, integer *, real *, ftnlen), xerbla_(
23 char *, integer *, ftnlen), slarfg_(integer *, real *, real *,
24 integer *, real *);
25
26
27 /* -- LAPACK routine (version 3.0) -- */
28 /* Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd., */
29 /* Courant Institute, Argonne National Lab, and Rice University */
30 /* February 29, 1992 */
31
32 /* .. Scalar Arguments .. */
33 /* .. */
34 /* .. Array Arguments .. */
35 /* .. */
36
37 /* Purpose */
38 /* ======= */
39
40 /* SGEQL2 computes a QL factorization of a real m by n matrix A: */
41 /* A = Q * L. */
42
43 /* Arguments */
44 /* ========= */
45
46 /* M (input) INTEGER */
47 /* The number of rows of the matrix A. M >= 0. */
48
49 /* N (input) INTEGER */
50 /* The number of columns of the matrix A. N >= 0. */
51
52 /* A (input/output) REAL array, dimension (LDA,N) */
53 /* On entry, the m by n matrix A. */
54 /* On exit, if m >= n, the lower triangle of the subarray */
55 /* A(m-n+1:m,1:n) contains the n by n lower triangular matrix L; */
56 /* if m <= n, the elements on and below the (n-m)-th */
57 /* superdiagonal contain the m by n lower trapezoidal matrix L; */
58 /* the remaining elements, with the array TAU, represent the */
59 /* orthogonal matrix Q as a product of elementary reflectors */
60 /* (see Further Details). */
61
62 /* LDA (input) INTEGER */
63 /* The leading dimension of the array A. LDA >= max(1,M). */
64
65 /* TAU (output) REAL array, dimension (min(M,N)) */
66 /* The scalar factors of the elementary reflectors (see Further */
67 /* Details). */
68
69 /* WORK (workspace) REAL array, dimension (N) */
70
71 /* INFO (output) INTEGER */
72 /* = 0: successful exit */
73 /* < 0: if INFO = -i, the i-th argument had an illegal value */
74
75 /* Further Details */
76 /* =============== */
77
78 /* The matrix Q is represented as a product of elementary reflectors */
79
80 /* Q = H(k) . . . H(2) H(1), where k = min(m,n). */
81
82 /* Each H(i) has the form */
83
84 /* H(i) = I - tau * v * v' */
85
86 /* where tau is a real scalar, and v is a real vector with */
87 /* v(m-k+i+1:m) = 0 and v(m-k+i) = 1; v(1:m-k+i-1) is stored on exit in */
88 /* A(1:m-k+i-1,n-k+i), and tau in TAU(i). */
89
90 /* ===================================================================== */
91
92 /* .. Parameters .. */
93 /* .. */
94 /* .. Local Scalars .. */
95 /* .. */
96 /* .. External Subroutines .. */
97 /* .. */
98 /* .. Intrinsic Functions .. */
99 /* .. */
100 /* .. Executable Statements .. */
101
102 /* Test the input arguments */
103
104 /* Parameter adjustments */
105 a_dim1 = *lda;
106 a_offset = 1 + a_dim1;
107 a -= a_offset;
108 --tau;
109 --work;
110
111 /* Function Body */
112 *info = 0;
113 if (*m < 0) {
114 *info = -1;
115 } else if (*n < 0) {
116 *info = -2;
117 } else if (*lda < max(1,*m)) {
118 *info = -4;
119 }
120 if (*info != 0) {
121 i__1 = -(*info);
122 xerbla_("SGEQL2", &i__1, (ftnlen)6);
123 return 0;
124 }
125
126 k = min(*m,*n);
127
128 for (i__ = k; i__ >= 1; --i__) {
129
130 /* Generate elementary reflector H(i) to annihilate */
131 /* A(1:m-k+i-1,n-k+i) */
132
133 i__1 = *m - k + i__;
134 slarfg_(&i__1, &a[*m - k + i__ + (*n - k + i__) * a_dim1], &a[(*n - k
135 + i__) * a_dim1 + 1], &c__1, &tau[i__]);
136
137 /* Apply H(i) to A(1:m-k+i,1:n-k+i-1) from the left */
138
139 aii = a[*m - k + i__ + (*n - k + i__) * a_dim1];
140 a[*m - k + i__ + (*n - k + i__) * a_dim1] = 1.f;
141 i__1 = *m - k + i__;
142 i__2 = *n - k + i__ - 1;
143 slarf_("Left", &i__1, &i__2, &a[(*n - k + i__) * a_dim1 + 1], &c__1, &
144 tau[i__], &a[a_offset], lda, &work[1], (ftnlen)4);
145 a[*m - k + i__ + (*n - k + i__) * a_dim1] = aii;
146 /* L10: */
147 }
148 return 0;
149
150 /* End of SGEQL2 */
151
152 } /* sgeql2_ */
153
154