libflame  revision_anchor
Functions
sorm2r.c File Reference

(r)

Functions

int sorm2r_fla (char *side, char *trans, integer *m, integer *n, integer *k, real *a, integer *lda, real *tau, real *c__, integer *ldc, real *work, integer *info)
 

Function Documentation

◆ sorm2r_fla()

int sorm2r_fla ( char *  side,
char *  trans,
integer m,
integer n,
integer k,
real a,
integer lda,
real tau,
real c__,
integer ldc,
real work,
integer info 
)

Referenced by sormqr_fla().

152 {
153  /* System generated locals */
154  integer a_dim1, a_offset, c_dim1, c_offset, i__1, i__2;
155  /* Local variables */
156  integer i__, i1, i2, i3, ic, jc, mi, ni, nq;
157  real aii;
158  logical left;
159  extern logical lsame_(char *, char *);
160  extern /* Subroutine */
161  int slarf_(char *, integer *, integer *, real *, integer *, real *, real *, integer *, real *), xerbla_( char *, integer *);
162  logical notran;
163  /* -- LAPACK computational routine (version 3.4.2) -- */
164  /* -- LAPACK is a software package provided by Univ. of Tennessee, -- */
165  /* -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..-- */
166  /* September 2012 */
167  /* .. Scalar Arguments .. */
168  /* .. */
169  /* .. Array Arguments .. */
170  /* .. */
171  /* ===================================================================== */
172  /* .. Parameters .. */
173  /* .. */
174  /* .. Local Scalars .. */
175  /* .. */
176  /* .. External Functions .. */
177  /* .. */
178  /* .. External Subroutines .. */
179  /* .. */
180  /* .. Intrinsic Functions .. */
181  /* .. */
182  /* .. Executable Statements .. */
183  /* Test the input arguments */
184  /* Parameter adjustments */
185  a_dim1 = *lda;
186  a_offset = 1 + a_dim1;
187  a -= a_offset;
188  --tau;
189  c_dim1 = *ldc;
190  c_offset = 1 + c_dim1;
191  c__ -= c_offset;
192  --work;
193  /* Function Body */
194  *info = 0;
195  left = lsame_(side, "L");
196  notran = lsame_(trans, "N");
197  /* NQ is the order of Q */
198  if (left)
199  {
200  nq = *m;
201  }
202  else
203  {
204  nq = *n;
205  }
206  if (! left && ! lsame_(side, "R"))
207  {
208  *info = -1;
209  }
210  else if (! notran && ! lsame_(trans, "T"))
211  {
212  *info = -2;
213  }
214  else if (*m < 0)
215  {
216  *info = -3;
217  }
218  else if (*n < 0)
219  {
220  *info = -4;
221  }
222  else if (*k < 0 || *k > nq)
223  {
224  *info = -5;
225  }
226  else if (*lda < max(1,nq))
227  {
228  *info = -7;
229  }
230  else if (*ldc < max(1,*m))
231  {
232  *info = -10;
233  }
234  if (*info != 0)
235  {
236  i__1 = -(*info);
237  xerbla_("SORM2R", &i__1);
238  return 0;
239  }
240  /* Quick return if possible */
241  if (*m == 0 || *n == 0 || *k == 0)
242  {
243  return 0;
244  }
245  if (left && ! notran || ! left && notran)
246  {
247  i1 = 1;
248  i2 = *k;
249  i3 = 1;
250  }
251  else
252  {
253  i1 = *k;
254  i2 = 1;
255  i3 = -1;
256  }
257  if (left)
258  {
259  ni = *n;
260  jc = 1;
261  }
262  else
263  {
264  mi = *m;
265  ic = 1;
266  }
267  i__1 = i2;
268  i__2 = i3;
269  for (i__ = i1;
270  i__2 < 0 ? i__ >= i__1 : i__ <= i__1;
271  i__ += i__2)
272  {
273  if (left)
274  {
275  /* H(i) is applied to C(i:m,1:n) */
276  mi = *m - i__ + 1;
277  ic = i__;
278  }
279  else
280  {
281  /* H(i) is applied to C(1:m,i:n) */
282  ni = *n - i__ + 1;
283  jc = i__;
284  }
285  /* Apply H(i) */
286  aii = a[i__ + i__ * a_dim1];
287  a[i__ + i__ * a_dim1] = 1.f;
288  slarf_(side, &mi, &ni, &a[i__ + i__ * a_dim1], &c__1, &tau[i__], &c__[ ic + jc * c_dim1], ldc, &work[1]);
289  a[i__ + i__ * a_dim1] = aii;
290  /* L10: */
291  }
292  return 0;
293  /* End of SORM2R */
294 }
float real
Definition: FLA_f2c.h:30
int logical
Definition: FLA_f2c.h:36
int integer
Definition: FLA_f2c.h:25