src/gmxlib/gmx_lapack/sorg2r.c

   1 /*
   2  * This file is part of the GROMACS molecular simulation package.
   3  *
   4  * Copyright (c) 2012, by the GROMACS development team, led by
   5  * David van der Spoel, Berk Hess, Erik Lindahl, and including many
   6  * others, as listed in the AUTHORS file in the top-level source
   7  * directory and at http://www.gromacs.org.
   8  *
   9  * GROMACS is free software; you can redistribute it and/or
  10  * modify it under the terms of the GNU Lesser General Public License
  11  * as published by the Free Software Foundation; either version 2.1
  12  * of the License, or (at your option) any later version.
  13  *
  14  * GROMACS is distributed in the hope that it will be useful,
  15  * but WITHOUT ANY WARRANTY; without even the implied warranty of
  16  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  17  * Lesser General Public License for more details.
  18  *
  19  * You should have received a copy of the GNU Lesser General Public
  20  * License along with GROMACS; if not, see
  21  * http://www.gnu.org/licenses, or write to the Free Software Foundation,
  22  * Inc., 51 Franklin Street, Fifth Floor, Boston, MA  02110-1301  USA.
  23  *
  24  * If you want to redistribute modifications to GROMACS, please
  25  * consider that scientific software is very special. Version
  26  * control is crucial - bugs must be traceable. We will be happy to
  27  * consider code for inclusion in the official distribution, but
  28  * derived work must not be called official GROMACS. Details are found
  29  * in the README & COPYING files - if they are missing, get the
  30  * official version at http://www.gromacs.org.
  31  *
  32  * To help us fund GROMACS development, we humbly ask that you cite
  33  * the research papers on the package. Check out http://www.gromacs.org.
  34  */
  35 #include <math.h>
  36
  37 #include "gmx_blas.h"
  38 #include "gmx_lapack.h"
  39
  40 void
  41 F77_FUNC(sorg2r,SORG2R)(int *m,
  42                         int *n,
  43                         int *k,
  44                         float *a,
  45                         int *lda,
  46                         float *tau,
  47                         float *work,
  48                         int *info)
  49 {
  50     int a_dim1, a_offset, i__1, i__2;
  51     float r__1;
  52     int c__1 = 1;
  53
  54     int i__, j, l;
  55
  56     a_dim1 = *lda;
  57     a_offset = 1 + a_dim1;
  58     a -= a_offset;
  59     --tau;
  60     --work;
  61
  62     *info = 0;
  63
  64     if (*n <= 0) {
  65         return;
  66     }
  67
  68     i__1 = *n;
  69     for (j = *k + 1; j <= i__1; ++j) {
  70         i__2 = *m;
  71         for (l = 1; l <= i__2; ++l) {
  72             a[l + j * a_dim1] = 0.0;
  73         }
  74         a[j + j * a_dim1] = 1.0;
  75     }
  76     for (i__ = *k; i__ >= 1; --i__) {
  77         if (i__ < *n) {
  78             a[i__ + i__ * a_dim1] = 1.0;
  79             i__1 = *m - i__ + 1;
  80             i__2 = *n - i__;
  81             F77_FUNC(slarf,SLARF)("L", &i__1, &i__2, &a[i__ + i__ * a_dim1], &c__1,
  82                               &tau[i__], &a[i__ + (i__ + 1) * a_dim1], lda, &work[1]);
  83         }
  84         if (i__ < *m) {
  85             i__1 = *m - i__;
  86             r__1 = -tau[i__];
  87             F77_FUNC(sscal,SSCAL)(&i__1, &r__1, &a[i__ + 1 + i__ * a_dim1], &c__1);
  88         }
  89         a[i__ + i__ * a_dim1] = 1.0 - tau[i__];
  90         i__1 = i__ - 1;
  91         for (l = 1; l <= i__1; ++l) {
  92             a[l + i__ * a_dim1] = 0.0;
  93         }
  94     }
  95     return;
  96
  97 }
  98
  99