src/gmxlib/gmx_lapack/dlarfg.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 #include <types/simple.h>
  37
  38 #include "gmx_blas.h"
  39 #include "gmx_lapack.h"
  40 #include "lapack_limits.h"
  41
  42
  43 void
  44 F77_FUNC(dlarfg,DLARFG)(int   *n,
  45                         double *alpha,
  46                         double *x,
  47                         int    *incx,
  48                         double *tau)
  49 {
  50   double xnorm,t;
  51   int    ti1,knt,j;
  52   double minval,safmin,rsafmn,beta;
  53
  54   if(*n<=1) {
  55     *tau = 0;
  56     return;
  57   }
  58
  59   ti1 = *n-1;
  60
  61   xnorm = F77_FUNC(dnrm2,DNRM2)(&ti1,x,incx);
  62
  63   if(fabs(xnorm)<GMX_DOUBLE_MIN) {
  64     *tau = 0.0;
  65   } else {
  66
  67     t = F77_FUNC(dlapy2,DLAPY2)(alpha,&xnorm);
  68
  69     if(*alpha<0)
  70       beta = t;
  71     else
  72       beta = -t;
  73
  74     minval = GMX_DOUBLE_MIN;
  75
  76     safmin = minval*(1.0+GMX_DOUBLE_EPS) / GMX_DOUBLE_EPS;
  77
  78
  79     if(fabs(beta)<safmin) {
  80
  81       knt = 0;
  82       rsafmn = 1.0 / safmin;
  83
  84       while(fabs(beta)<safmin) {
  85         knt++;
  86         ti1 = *n-1;
  87         F77_FUNC(dscal,DSCAL)(&ti1,&rsafmn,x,incx);
  88         beta *= rsafmn;
  89         *alpha *= rsafmn;
  90       }
  91
  92       /* safmin <= beta <= 1 now */
  93       ti1 = *n-1;
  94       xnorm = F77_FUNC(dnrm2,DNRM2)(&ti1,x,incx);
  95       t = F77_FUNC(dlapy2,DLAPY2)(alpha,&xnorm);
  96
  97       if(*alpha<0)
  98         beta = t;
  99       else
 100         beta = -t;
 101
 102       *tau = (beta-*alpha)/beta;
 103
 104       ti1= *n-1;
 105       t = 1.0/(*alpha-beta);
 106       F77_FUNC(dscal,DSCAL)(&ti1,&t,x,incx);
 107
 108       *alpha = beta;
 109       for(j=0;j<knt;j++)
 110         *alpha *= safmin;
 111     } else {
 112       *tau = (beta-*alpha)/beta;
 113       ti1= *n-1;
 114       t = 1.0/(*alpha-beta);
 115       F77_FUNC(dscal,DSCAL)(&ti1,&t,x,incx);
 116       *alpha = beta;
 117     }
 118   }
 119
 120   return;
 121 }