2 * This file is part of the GROMACS molecular simulation package.
4 * Copyright (c) 2012,2013, 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.
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.
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.
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.
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.
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.
37 #include "gmx_lapack.h"
38 #include "lapack_limits.h"
40 #include <types/simple.h>
43 F77_FUNC(sstein,SSTEIN)(int *n,
57 int z_dim1, z_offset, i__1, i__2, i__3;
58 float d__2, d__3, d__4, d__5;
60 int i__, j, b1, j1, bn;
61 float xj, scl, eps, sep, nrm, tol;
67 int iseed[4], gpind, iinfo;
69 int indrv1, indrv2, indrv3, indrv4, indrv5;
72 float onenrm, dtpcrt, pertol;
83 z_offset = 1 + z_dim1;
93 for (i__ = 1; i__ <= i__1; ++i__) {
99 } else if (*m < 0 || *m > *n) {
101 } else if (*ldz < (*n)) {
105 for (j = 2; j <= i__1; ++j) {
106 if (iblock[j] < iblock[j - 1]) {
110 if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) {
122 if (*n == 0 || *m == 0) {
124 } else if (*n == 1) {
125 z__[z_dim1 + 1] = 1.;
131 for (i__ = 1; i__ <= 4; ++i__) {
136 indrv2 = indrv1 + *n;
137 indrv3 = indrv2 + *n;
138 indrv4 = indrv3 + *n;
139 indrv5 = indrv4 + *n;
143 for (nblk = 1; nblk <= i__1; ++nblk) {
148 b1 = isplit[nblk - 1] + 1;
151 blksiz = bn - b1 + 1;
157 onenrm = fabs(d__[b1]) + fabs(e[b1]);
159 d__4 = fabs(d__[bn]) + fabs(e[bn - 1]);
160 onenrm = (d__3>d__4) ? d__3 : d__4;
162 for (i__ = b1 + 1; i__ <= i__2; ++i__) {
164 d__5 = fabs(d__[i__]) + fabs(e[i__ - 1]) + fabs(e[i__]);
165 onenrm = (d__4>d__5) ? d__4 : d__5;
167 ortol = onenrm * .001;
169 dtpcrt = sqrt(.1 / blksiz);
173 for (j = j1; j <= i__2; ++j) {
174 if (iblock[j] != nblk) {
182 work[indrv1 + 1] = 1.;
187 eps1 = fabs(eps * xj);
198 F77_FUNC(slarnv,SLARNV)(&c__2, iseed, &blksiz, &work[indrv1 + 1]);
200 F77_FUNC(scopy,SCOPY)(&blksiz, &d__[b1], &c__1, &work[indrv4 + 1], &c__1);
202 F77_FUNC(scopy,SCOPY)(&i__3, &e[b1], &c__1, &work[indrv2 + 2], &c__1);
204 F77_FUNC(scopy,SCOPY)(&i__3, &e[b1], &c__1, &work[indrv3 + 1], &c__1);
207 F77_FUNC(slagtf,SLAGTF)(&blksiz, &work[indrv4 + 1], &xj, &work[indrv2 + 2], &work[
208 indrv3 + 1], &tol, &work[indrv5 + 1], &iwork[1], &iinfo);
217 d__3 = fabs(work[indrv4 + blksiz]);
218 scl = blksiz * onenrm * ((d__2>d__3) ? d__2 : d__3) / F77_FUNC(sasum,SASUM)(&blksiz, &work[
220 F77_FUNC(sscal,SSCAL)(&blksiz, &scl, &work[indrv1 + 1], &c__1);
222 F77_FUNC(slagts,SLAGTS)(&c_n1, &blksiz, &work[indrv4 + 1], &work[indrv2 + 2], &
223 work[indrv3 + 1], &work[indrv5 + 1], &iwork[1], &work[
224 indrv1 + 1], &tol, &iinfo);
229 if (fabs(xj - xjm) > ortol) {
234 for (i__ = gpind; i__ <= i__3; ++i__) {
235 ztr = -F77_FUNC(sdot,SDOT)(&blksiz, &work[indrv1 + 1], &c__1, &z__[b1 +
236 i__ * z_dim1], &c__1);
237 F77_FUNC(saxpy,SAXPY)(&blksiz, &ztr, &z__[b1 + i__ * z_dim1], &c__1, &
238 work[indrv1 + 1], &c__1);
243 jmax = F77_FUNC(isamax,ISAMAX)(&blksiz, &work[indrv1 + 1], &c__1);
244 nrm = fabs(work[indrv1 + jmax]);
261 scl = 1. / F77_FUNC(snrm2,SNRM2)(&blksiz, &work[indrv1 + 1], &c__1);
262 jmax = F77_FUNC(isamax,ISAMAX)(&blksiz, &work[indrv1 + 1], &c__1);
263 if (work[indrv1 + jmax] < 0.) {
266 F77_FUNC(sscal,SSCAL)(&blksiz, &scl, &work[indrv1 + 1], &c__1);
269 for (i__ = 1; i__ <= i__3; ++i__) {
270 z__[i__ + j * z_dim1] = 0.;
273 for (i__ = 1; i__ <= i__3; ++i__) {
274 z__[b1 + i__ - 1 + j * z_dim1] = work[indrv1 + i__];