libflame  revision_anchor
Functions
sorghr.c File Reference

(r)

Functions

int sorghr_ (integer *n, integer *ilo, integer *ihi, real *a, integer *lda, real *tau, real *work, integer *lwork, integer *info)
 

Function Documentation

◆ sorghr_()

int sorghr_ ( integer n,
integer ilo,
integer ihi,
real a,
integer lda,
real tau,
real work,
integer lwork,
integer info 
)
121 {
122  /* System generated locals */
123  integer a_dim1, a_offset, i__1, i__2;
124  /* Local variables */
125  integer i__, j, nb, nh, iinfo;
126  extern /* Subroutine */
127  int xerbla_(char *, integer *);
128  extern integer ilaenv_(integer *, char *, char *, integer *, integer *, integer *, integer *);
129  extern /* Subroutine */
130  int sorgqr_fla(integer *, integer *, integer *, real *, integer *, real *, real *, integer *, integer *);
131  integer lwkopt;
132  logical lquery;
133  /* -- LAPACK computational routine (version 3.4.0) -- */
134  /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
135  /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
136  /* November 2011 */
137  /* .. Scalar Arguments .. */
138  /* .. */
139  /* .. Array Arguments .. */
140  /* .. */
141  /* ===================================================================== */
142  /* .. Parameters .. */
143  /* .. */
144  /* .. Local Scalars .. */
145  /* .. */
146  /* .. External Subroutines .. */
147  /* .. */
148  /* .. External Functions .. */
149  /* .. */
150  /* .. Intrinsic Functions .. */
151  /* .. */
152  /* .. Executable Statements .. */
153  /* Test the input arguments */
154  /* Parameter adjustments */
155  a_dim1 = *lda;
156  a_offset = 1 + a_dim1;
157  a -= a_offset;
158  --tau;
159  --work;
160  /* Function Body */
161  *info = 0;
162  nh = *ihi - *ilo;
163  lquery = *lwork == -1;
164  if (*n < 0)
165  {
166  *info = -1;
167  }
168  else if (*ilo < 1 || *ilo > max(1,*n))
169  {
170  *info = -2;
171  }
172  else if (*ihi < min(*ilo,*n) || *ihi > *n)
173  {
174  *info = -3;
175  }
176  else if (*lda < max(1,*n))
177  {
178  *info = -5;
179  }
180  else if (*lwork < max(1,nh) && ! lquery)
181  {
182  *info = -8;
183  }
184  if (*info == 0)
185  {
186  nb = ilaenv_(&c__1, "SORGQR", " ", &nh, &nh, &nh, &c_n1);
187  lwkopt = max(1,nh) * nb;
188  work[1] = (real) lwkopt;
189  }
190  if (*info != 0)
191  {
192  i__1 = -(*info);
193  xerbla_("SORGHR", &i__1);
194  return 0;
195  }
196  else if (lquery)
197  {
198  return 0;
199  }
200  /* Quick return if possible */
201  if (*n == 0)
202  {
203  work[1] = 1.f;
204  return 0;
205  }
206  /* Shift the vectors which define the elementary reflectors one */
207  /* column to the right, and set the first ilo and the last n-ihi */
208  /* rows and columns to those of the unit matrix */
209  i__1 = *ilo + 1;
210  for (j = *ihi;
211  j >= i__1;
212  --j)
213  {
214  i__2 = j - 1;
215  for (i__ = 1;
216  i__ <= i__2;
217  ++i__)
218  {
219  a[i__ + j * a_dim1] = 0.f;
220  /* L10: */
221  }
222  i__2 = *ihi;
223  for (i__ = j + 1;
224  i__ <= i__2;
225  ++i__)
226  {
227  a[i__ + j * a_dim1] = a[i__ + (j - 1) * a_dim1];
228  /* L20: */
229  }
230  i__2 = *n;
231  for (i__ = *ihi + 1;
232  i__ <= i__2;
233  ++i__)
234  {
235  a[i__ + j * a_dim1] = 0.f;
236  /* L30: */
237  }
238  /* L40: */
239  }
240  i__1 = *ilo;
241  for (j = 1;
242  j <= i__1;
243  ++j)
244  {
245  i__2 = *n;
246  for (i__ = 1;
247  i__ <= i__2;
248  ++i__)
249  {
250  a[i__ + j * a_dim1] = 0.f;
251  /* L50: */
252  }
253  a[j + j * a_dim1] = 1.f;
254  /* L60: */
255  }
256  i__1 = *n;
257  for (j = *ihi + 1;
258  j <= i__1;
259  ++j)
260  {
261  i__2 = *n;
262  for (i__ = 1;
263  i__ <= i__2;
264  ++i__)
265  {
266  a[i__ + j * a_dim1] = 0.f;
267  /* L70: */
268  }
269  a[j + j * a_dim1] = 1.f;
270  /* L80: */
271  }
272  if (nh > 0)
273  {
274  /* Generate Q(ilo+1:ihi,ilo+1:ihi) */
275  sorgqr_fla(&nh, &nh, &nh, &a[*ilo + 1 + (*ilo + 1) * a_dim1], lda, &tau[* ilo], &work[1], lwork, &iinfo);
276  }
277  work[1] = (real) lwkopt;
278  return 0;
279  /* End of SORGHR */
280 }
int integer
Definition: FLA_f2c.h:25
int logical
Definition: FLA_f2c.h:36
float real
Definition: FLA_f2c.h:30
int sorgqr_fla(integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *work, integer *lwork, integer *info)
Definition: sorgqr.c:123

References sorgqr_fla().