src/gmxlib/gmx_lapack/sorg2r.c

   1 #include <math.h>
   2
   3 #include "gmx_blas.h"
   4 #include "gmx_lapack.h"
   5
   6 void
   7 F77_FUNC(sorg2r,SORG2R)(int *m,
   8                         int *n,
   9                         int *k,
  10                         float *a,
  11                         int *lda,
  12                         float *tau,
  13                         float *work,
  14                         int *info)
  15 {
  16     int a_dim1, a_offset, i__1, i__2;
  17     float r__1;
  18     int c__1 = 1;
  19
  20     int i__, j, l;
  21
  22     a_dim1 = *lda;
  23     a_offset = 1 + a_dim1;
  24     a -= a_offset;
  25     --tau;
  26     --work;
  27
  28     *info = 0;
  29
  30     if (*n <= 0) {
  31         return;
  32     }
  33
  34     i__1 = *n;
  35     for (j = *k + 1; j <= i__1; ++j) {
  36         i__2 = *m;
  37         for (l = 1; l <= i__2; ++l) {
  38             a[l + j * a_dim1] = 0.0;
  39         }
  40         a[j + j * a_dim1] = 1.0;
  41     }
  42     for (i__ = *k; i__ >= 1; --i__) {
  43         if (i__ < *n) {
  44             a[i__ + i__ * a_dim1] = 1.0;
  45             i__1 = *m - i__ + 1;
  46             i__2 = *n - i__;
  47             F77_FUNC(slarf,SLARF)("L", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1,
  48                               &tau[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
  49         }
  50         if (i__ < *m) {
  51             i__1 = *m - i__;
  52             r__1 = -tau[i__];
  53             F77_FUNC(sscal,SSCAL)(&i__1, &r__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
  54         }
  55         a[i__ + i__ * a_dim1] = 1.0 - tau[i__];
  56         i__1 = i__ - 1;
  57         for (l = 1; l <= i__1; ++l) {
  58             a[l + i__ * a_dim1] = 0.0;
  59         }
  60     }
  61     return;
  62
  63 }
  64
  65