CFD/hypre
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity
2dd7550c83
hypre/lapack/dlasq5.c
hill66 402d34179c Updated license info.
2006-09-22 22:06:21 +00:00

239 lines
6.2 KiB
C
Raw Blame History

/*BHEADER**********************************************************************
* Copyright (c) 2006 The Regents of the University of California.
* Produced at the Lawrence Livermore National Laboratory.
* Written by the HYPRE team. UCRL-CODE-222953.
* All rights reserved.
*
* This file is part of HYPRE (see http://www.llnl.gov/CASC/hypre/).
* Please see the COPYRIGHT_and_LICENSE file for the copyright notice,
* disclaimer, contact information and the GNU Lesser General Public License.
*
* HYPRE is free software; you can redistribute it and/or modify it under the
* terms of the GNU General Public License (as published by the Free Software
* Foundation) version 2.1 dated February 1999.
*
* HYPRE is distributed in the hope that it will be useful, but WITHOUT ANY
* WARRANTY; without even the IMPLIED WARRANTY OF MERCHANTABILITY or FITNESS
* FOR A PARTICULAR PURPOSE. See the terms and conditions of the GNU General
* Public License for more details.
*
* You should have received a copy of the GNU Lesser General Public License
* along with this program; if not, write to the Free Software Foundation,
* Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
*
* $Revision$
***********************************************************************EHEADER*/
#include "hypre_lapack.h"
#include "f2c.h"
/* Subroutine */ int dlasq5_(integer *i0, integer *n0, doublereal *z__,
integer *pp, doublereal *tau, doublereal *dmin__, doublereal *dmin1,
doublereal *dmin2, doublereal *dn, doublereal *dnm1, doublereal *dnm2,
logical *ieee)
{
/* -- LAPACK auxiliary routine (version 3.0) --
Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
Courant Institute, Argonne National Lab, and Rice University
May 17, 2000
Purpose
=======
DLASQ5 computes one dqds transform in ping-pong form, one
version for IEEE machines another for non IEEE machines.
Arguments
=========
I0 (input) INTEGER
First index.
N0 (input) INTEGER
Last index.
Z (input) DOUBLE PRECISION array, dimension ( 4*N )
Z holds the qd array. EMIN is stored in Z(4*N0) to avoid
an extra argument.
PP (input) INTEGER
PP=0 for ping, PP=1 for pong.
TAU (input) DOUBLE PRECISION
This is the shift.
DMIN (output) DOUBLE PRECISION
Minimum value of d.
DMIN1 (output) DOUBLE PRECISION
Minimum value of d, excluding D( N0 ).
DMIN2 (output) DOUBLE PRECISION
Minimum value of d, excluding D( N0 ) and D( N0-1 ).
DN (output) DOUBLE PRECISION
d(N0), the last value of d.
DNM1 (output) DOUBLE PRECISION
d(N0-1).
DNM2 (output) DOUBLE PRECISION
d(N0-2).
IEEE (input) LOGICAL
Flag for IEEE or non IEEE arithmetic.
=====================================================================
Parameter adjustments */
/* System generated locals */
integer i__1;
doublereal d__1, d__2;
/* Local variables */
static doublereal emin, temp, d__;
static integer j4, j4p2;
--z__;
/* Function Body */
if (*n0 - *i0 - 1 <= 0) {
return 0;
}
j4 = (*i0 << 2) + *pp - 3;
emin = z__[j4 + 4];
d__ = z__[j4] - *tau;
*dmin__ = d__;
*dmin1 = -z__[j4];
if (*ieee) {
/* Code for IEEE arithmetic. */
if (*pp == 0) {
i__1 = (*n0 - 3) << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 2] = d__ + z__[j4 - 1];
temp = z__[j4 + 1] / z__[j4 - 2];
d__ = d__ * temp - *tau;
*dmin__ = min(*dmin__,d__);
z__[j4] = z__[j4 - 1] * temp;
/* Computing MIN */
d__1 = z__[j4];
emin = min(d__1,emin);
/* L10: */
}
} else {
i__1 = (*n0 - 3) << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 3] = d__ + z__[j4];
temp = z__[j4 + 2] / z__[j4 - 3];
d__ = d__ * temp - *tau;
*dmin__ = min(*dmin__,d__);
z__[j4 - 1] = z__[j4] * temp;
/* Computing MIN */
d__1 = z__[j4 - 1];
emin = min(d__1,emin);
/* L20: */
}
}
/* Unroll last two steps. */
*dnm2 = d__;
*dmin2 = *dmin__;
j4 = ((*n0 - 2) << 2) - *pp;
j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm2 + z__[j4p2];
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau;
*dmin__ = min(*dmin__,*dnm1);
*dmin1 = *dmin__;
j4 += 4;
j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm1 + z__[j4p2];
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau;
*dmin__ = min(*dmin__,*dn);
} else {
/* Code for non IEEE arithmetic. */
if (*pp == 0) {
i__1 = (*n0 - 3) << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 2] = d__ + z__[j4 - 1];
if (d__ < 0.) {
return 0;
} else {
z__[j4] = z__[j4 + 1] * (z__[j4 - 1] / z__[j4 - 2]);
d__ = z__[j4 + 1] * (d__ / z__[j4 - 2]) - *tau;
}
*dmin__ = min(*dmin__,d__);
/* Computing MIN */
d__1 = emin, d__2 = z__[j4];
emin = min(d__1,d__2);
/* L30: */
}
} else {
i__1 = (*n0 - 3) << 2;
for (j4 = *i0 << 2; j4 <= i__1; j4 += 4) {
z__[j4 - 3] = d__ + z__[j4];
if (d__ < 0.) {
return 0;
} else {
z__[j4 - 1] = z__[j4 + 2] * (z__[j4] / z__[j4 - 3]);
d__ = z__[j4 + 2] * (d__ / z__[j4 - 3]) - *tau;
}
*dmin__ = min(*dmin__,d__);
/* Computing MIN */
d__1 = emin, d__2 = z__[j4 - 1];
emin = min(d__1,d__2);
/* L40: */
}
}
/* Unroll last two steps. */
*dnm2 = d__;
*dmin2 = *dmin__;
j4 = ((*n0 - 2) << 2) - *pp;
j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm2 + z__[j4p2];
if (*dnm2 < 0.) {
return 0;
} else {
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dnm1 = z__[j4p2 + 2] * (*dnm2 / z__[j4 - 2]) - *tau;
}
*dmin__ = min(*dmin__,*dnm1);
*dmin1 = *dmin__;
j4 += 4;
j4p2 = j4 + (*pp << 1) - 1;
z__[j4 - 2] = *dnm1 + z__[j4p2];
if (*dnm1 < 0.) {
return 0;
} else {
z__[j4] = z__[j4p2 + 2] * (z__[j4p2] / z__[j4 - 2]);
*dn = z__[j4p2 + 2] * (*dnm1 / z__[j4 - 2]) - *tau;
}
*dmin__ = min(*dmin__,*dn);
}
z__[j4 + 2] = *dn;
z__[(*n0 << 2) - *pp] = emin;
return 0;
/* End of DLASQ5 */
} /* dlasq5_ */
Reference in New Issue View Git Blame Copy Permalink