libflame  revision_anchor
Functions
sorg2r.c File Reference

(r)

Functions

int sorg2r_fla (integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *work, integer *info)
 

Function Documentation

◆ sorg2r_fla()

int sorg2r_fla ( integer m,
integer n,
integer k,
real a,
integer lda,
real tau,
real work,
integer info 
)
106 {
107  /* System generated locals */
108  integer a_dim1, a_offset, i__1, i__2;
109  real r__1;
110  /* Local variables */
111  integer i__, j, l;
112  extern /* Subroutine */
113  int sscal_(integer *, real *, real *, integer *), slarf_(char *, integer *, integer *, real *, integer *, real *, real *, integer *, real *), xerbla_(char *, integer *);
114  /* -- LAPACK computational routine (version 3.4.2) -- */
115  /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
116  /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
117  /* September 2012 */
118  /* .. Scalar Arguments .. */
119  /* .. */
120  /* .. Array Arguments .. */
121  /* .. */
122  /* ===================================================================== */
123  /* .. Parameters .. */
124  /* .. */
125  /* .. Local Scalars .. */
126  /* .. */
127  /* .. External Subroutines .. */
128  /* .. */
129  /* .. Intrinsic Functions .. */
130  /* .. */
131  /* .. Executable Statements .. */
132  /* Test the input arguments */
133  /* Parameter adjustments */
134  a_dim1 = *lda;
135  a_offset = 1 + a_dim1;
136  a -= a_offset;
137  --tau;
138  --work;
139  /* Function Body */
140  *info = 0;
141  if (*m < 0)
142  {
143  *info = -1;
144  }
145  else if (*n < 0 || *n > *m)
146  {
147  *info = -2;
148  }
149  else if (*k < 0 || *k > *n)
150  {
151  *info = -3;
152  }
153  else if (*lda < max(1,*m))
154  {
155  *info = -5;
156  }
157  if (*info != 0)
158  {
159  i__1 = -(*info);
160  xerbla_("SORG2R", &i__1);
161  return 0;
162  }
163  /* Quick return if possible */
164  if (*n <= 0)
165  {
166  return 0;
167  }
168  /* Initialise columns k+1:n to columns of the unit matrix */
169  i__1 = *n;
170  for (j = *k + 1;
171  j <= i__1;
172  ++j)
173  {
174  i__2 = *m;
175  for (l = 1;
176  l <= i__2;
177  ++l)
178  {
179  a[l + j * a_dim1] = 0.f;
180  /* L10: */
181  }
182  a[j + j * a_dim1] = 1.f;
183  /* L20: */
184  }
185  for (i__ = *k;
186  i__ >= 1;
187  --i__)
188  {
189  /* Apply H(i) to A(i:m,i:n) from the left */
190  if (i__ < *n)
191  {
192  a[i__ + i__ * a_dim1] = 1.f;
193  i__1 = *m - i__ + 1;
194  i__2 = *n - i__;
195  slarf_("Left", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1, &tau[ i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
196  }
197  if (i__ < *m)
198  {
199  i__1 = *m - i__;
200  r__1 = -tau[i__];
201  sscal_(&i__1, &r__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
202  }
203  a[i__ + i__ * a_dim1] = 1.f - tau[i__];
204  /* Set A(1:i-1,i) to zero */
205  i__1 = i__ - 1;
206  for (l = 1;
207  l <= i__1;
208  ++l)
209  {
210  a[l + i__ * a_dim1] = 0.f;
211  /* L30: */
212  }
213  /* L40: */
214  }
215  return 0;
216  /* End of SORG2R */
217 }
int integer
Definition: FLA_f2c.h:25
float real
Definition: FLA_f2c.h:30

Referenced by sopgtr_(), and sorgqr_fla().