2 #include "../gmx_blas.h"
3 #include "../gmx_lapack.h"
4 #include "lapack_limits.h"
6 #include "gromacs/utility/real.h"
9 F77_FUNC(sstein,SSTEIN)(int *n,
23 int z_dim1, z_offset, i__1, i__2, i__3;
24 float d__2, d__3, d__4, d__5;
26 int i__, j, b1, j1, bn;
27 float xj, scl, eps, sep, nrm, tol;
33 int iseed[4], gpind, iinfo;
35 int indrv1, indrv2, indrv3, indrv4, indrv5;
38 float onenrm, dtpcrt, pertol;
49 z_offset = 1 + z_dim1;
59 for (i__ = 1; i__ <= i__1; ++i__) {
65 } else if (*m < 0 || *m > *n) {
67 } else if (*ldz < (*n)) {
71 for (j = 2; j <= i__1; ++j) {
72 if (iblock[j] < iblock[j - 1]) {
76 if (iblock[j] == iblock[j - 1] && w[j] < w[j - 1]) {
88 if (*n == 0 || *m == 0) {
97 for (i__ = 1; i__ <= 4; ++i__) {
102 indrv2 = indrv1 + *n;
103 indrv3 = indrv2 + *n;
104 indrv4 = indrv3 + *n;
105 indrv5 = indrv4 + *n;
109 for (nblk = 1; nblk <= i__1; ++nblk) {
114 b1 = isplit[nblk - 1] + 1;
117 blksiz = bn - b1 + 1;
123 onenrm = fabs(d__[b1]) + fabs(e[b1]);
125 d__4 = fabs(d__[bn]) + fabs(e[bn - 1]);
126 onenrm = (d__3>d__4) ? d__3 : d__4;
128 for (i__ = b1 + 1; i__ <= i__2; ++i__) {
130 d__5 = fabs(d__[i__]) + fabs(e[i__ - 1]) + fabs(e[i__]);
131 onenrm = (d__4>d__5) ? d__4 : d__5;
133 ortol = onenrm * .001;
135 dtpcrt = sqrt(.1 / blksiz);
139 for (j = j1; j <= i__2; ++j) {
140 if (iblock[j] != nblk) {
148 work[indrv1 + 1] = 1.;
153 eps1 = fabs(eps * xj);
164 F77_FUNC(slarnv,SLARNV)(&c__2, iseed, &blksiz, &work[indrv1 + 1]);
166 F77_FUNC(scopy,SCOPY)(&blksiz, &d__[b1], &c__1, &work[indrv4 + 1], &c__1);
168 F77_FUNC(scopy,SCOPY)(&i__3, &e[b1], &c__1, &work[indrv2 + 2], &c__1);
170 F77_FUNC(scopy,SCOPY)(&i__3, &e[b1], &c__1, &work[indrv3 + 1], &c__1);
173 F77_FUNC(slagtf,SLAGTF)(&blksiz, &work[indrv4 + 1], &xj, &work[indrv2 + 2], &work[
174 indrv3 + 1], &tol, &work[indrv5 + 1], &iwork[1], &iinfo);
183 d__3 = fabs(work[indrv4 + blksiz]);
184 scl = blksiz * onenrm * ((d__2>d__3) ? d__2 : d__3) / F77_FUNC(sasum,SASUM)(&blksiz, &work[
186 F77_FUNC(sscal,SSCAL)(&blksiz, &scl, &work[indrv1 + 1], &c__1);
188 F77_FUNC(slagts,SLAGTS)(&c_n1, &blksiz, &work[indrv4 + 1], &work[indrv2 + 2], &
189 work[indrv3 + 1], &work[indrv5 + 1], &iwork[1], &work[
190 indrv1 + 1], &tol, &iinfo);
195 if (fabs(xj - xjm) > ortol) {
200 for (i__ = gpind; i__ <= i__3; ++i__) {
201 ztr = -F77_FUNC(sdot,SDOT)(&blksiz, &work[indrv1 + 1], &c__1, &z__[b1 +
202 i__ * z_dim1], &c__1);
203 F77_FUNC(saxpy,SAXPY)(&blksiz, &ztr, &z__[b1 + i__ * z_dim1], &c__1, &
204 work[indrv1 + 1], &c__1);
209 jmax = F77_FUNC(isamax,ISAMAX)(&blksiz, &work[indrv1 + 1], &c__1);
210 nrm = fabs(work[indrv1 + jmax]);
227 scl = 1. / F77_FUNC(snrm2,SNRM2)(&blksiz, &work[indrv1 + 1], &c__1);
228 jmax = F77_FUNC(isamax,ISAMAX)(&blksiz, &work[indrv1 + 1], &c__1);
229 if (work[indrv1 + jmax] < 0.) {
232 F77_FUNC(sscal,SSCAL)(&blksiz, &scl, &work[indrv1 + 1], &c__1);
235 for (i__ = 1; i__ <= i__3; ++i__) {
236 z__[i__ + j * z_dim1] = 0.;
239 for (i__ = 1; i__ <= i__3; ++i__) {
240 z__[b1 + i__ - 1 + j * z_dim1] = work[indrv1 + i__];