mirror of https://github.com/opencv/opencv.git
Open Source Computer Vision Library
https://opencv.org/
You can not select more than 25 topics
Topics must start with a letter or number, can include dashes ('-') and can be up to 35 characters long.
193 lines
5.2 KiB
193 lines
5.2 KiB
/* slarrk.f -- translated by f2c (version 20061008). |
|
You must link the resulting object file with libf2c: |
|
on Microsoft Windows system, link with libf2c.lib; |
|
on Linux or Unix systems, link with .../path/to/libf2c.a -lm |
|
or, if you install libf2c.a in a standard place, with -lf2c -lm |
|
-- in that order, at the end of the command line, as in |
|
cc *.o -lf2c -lm |
|
Source for libf2c is in /netlib/f2c/libf2c.zip, e.g., |
|
|
|
http://www.netlib.org/f2c/libf2c.zip |
|
*/ |
|
|
|
#include "clapack.h" |
|
|
|
|
|
/* Subroutine */ int slarrk_(integer *n, integer *iw, real *gl, real *gu, |
|
real *d__, real *e2, real *pivmin, real *reltol, real *w, real *werr, |
|
integer *info) |
|
{ |
|
/* System generated locals */ |
|
integer i__1; |
|
real r__1, r__2; |
|
|
|
/* Builtin functions */ |
|
double log(doublereal); |
|
|
|
/* Local variables */ |
|
integer i__, it; |
|
real mid, eps, tmp1, tmp2, left, atoli, right; |
|
integer itmax; |
|
real rtoli, tnorm; |
|
extern doublereal slamch_(char *); |
|
integer negcnt; |
|
|
|
|
|
/* -- LAPACK auxiliary routine (version 3.2) -- */ |
|
/* Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd.. */ |
|
/* November 2006 */ |
|
|
|
/* .. Scalar Arguments .. */ |
|
/* .. */ |
|
/* .. Array Arguments .. */ |
|
/* .. */ |
|
|
|
/* Purpose */ |
|
/* ======= */ |
|
|
|
/* SLARRK computes one eigenvalue of a symmetric tridiagonal */ |
|
/* matrix T to suitable accuracy. This is an auxiliary code to be */ |
|
/* called from SSTEMR. */ |
|
|
|
/* To avoid overflow, the matrix must be scaled so that its */ |
|
/* largest element is no greater than overflow**(1/2) * */ |
|
/* underflow**(1/4) in absolute value, and for greatest */ |
|
/* accuracy, it should not be much smaller than that. */ |
|
|
|
/* See W. Kahan "Accurate Eigenvalues of a Symmetric Tridiagonal */ |
|
/* Matrix", Report CS41, Computer Science Dept., Stanford */ |
|
/* University, July 21, 1966. */ |
|
|
|
/* Arguments */ |
|
/* ========= */ |
|
|
|
/* N (input) INTEGER */ |
|
/* The order of the tridiagonal matrix T. N >= 0. */ |
|
|
|
/* IW (input) INTEGER */ |
|
/* The index of the eigenvalues to be returned. */ |
|
|
|
/* GL (input) REAL */ |
|
/* GU (input) REAL */ |
|
/* An upper and a lower bound on the eigenvalue. */ |
|
|
|
/* D (input) REAL array, dimension (N) */ |
|
/* The n diagonal elements of the tridiagonal matrix T. */ |
|
|
|
/* E2 (input) REAL array, dimension (N-1) */ |
|
/* The (n-1) squared off-diagonal elements of the tridiagonal matrix T. */ |
|
|
|
/* PIVMIN (input) REAL */ |
|
/* The minimum pivot allowed in the Sturm sequence for T. */ |
|
|
|
/* RELTOL (input) REAL */ |
|
/* The minimum relative width of an interval. When an interval */ |
|
/* is narrower than RELTOL times the larger (in */ |
|
/* magnitude) endpoint, then it is considered to be */ |
|
/* sufficiently small, i.e., converged. Note: this should */ |
|
/* always be at least radix*machine epsilon. */ |
|
|
|
/* W (output) REAL */ |
|
|
|
/* WERR (output) REAL */ |
|
/* The error bound on the corresponding eigenvalue approximation */ |
|
/* in W. */ |
|
|
|
/* INFO (output) INTEGER */ |
|
/* = 0: Eigenvalue converged */ |
|
/* = -1: Eigenvalue did NOT converge */ |
|
|
|
/* Internal Parameters */ |
|
/* =================== */ |
|
|
|
/* FUDGE REAL , default = 2 */ |
|
/* A "fudge factor" to widen the Gershgorin intervals. */ |
|
|
|
/* ===================================================================== */ |
|
|
|
/* .. Parameters .. */ |
|
/* .. */ |
|
/* .. Local Scalars .. */ |
|
/* .. */ |
|
/* .. External Functions .. */ |
|
/* .. */ |
|
/* .. Intrinsic Functions .. */ |
|
/* .. */ |
|
/* .. Executable Statements .. */ |
|
|
|
/* Get machine constants */ |
|
/* Parameter adjustments */ |
|
--e2; |
|
--d__; |
|
|
|
/* Function Body */ |
|
eps = slamch_("P"); |
|
/* Computing MAX */ |
|
r__1 = dabs(*gl), r__2 = dabs(*gu); |
|
tnorm = dmax(r__1,r__2); |
|
rtoli = *reltol; |
|
atoli = *pivmin * 4.f; |
|
itmax = (integer) ((log(tnorm + *pivmin) - log(*pivmin)) / log(2.f)) + 2; |
|
*info = -1; |
|
left = *gl - tnorm * 2.f * eps * *n - *pivmin * 4.f; |
|
right = *gu + tnorm * 2.f * eps * *n + *pivmin * 4.f; |
|
it = 0; |
|
L10: |
|
|
|
/* Check if interval converged or maximum number of iterations reached */ |
|
|
|
tmp1 = (r__1 = right - left, dabs(r__1)); |
|
/* Computing MAX */ |
|
r__1 = dabs(right), r__2 = dabs(left); |
|
tmp2 = dmax(r__1,r__2); |
|
/* Computing MAX */ |
|
r__1 = max(atoli,*pivmin), r__2 = rtoli * tmp2; |
|
if (tmp1 < dmax(r__1,r__2)) { |
|
*info = 0; |
|
goto L30; |
|
} |
|
if (it > itmax) { |
|
goto L30; |
|
} |
|
|
|
/* Count number of negative pivots for mid-point */ |
|
|
|
++it; |
|
mid = (left + right) * .5f; |
|
negcnt = 0; |
|
tmp1 = d__[1] - mid; |
|
if (dabs(tmp1) < *pivmin) { |
|
tmp1 = -(*pivmin); |
|
} |
|
if (tmp1 <= 0.f) { |
|
++negcnt; |
|
} |
|
|
|
i__1 = *n; |
|
for (i__ = 2; i__ <= i__1; ++i__) { |
|
tmp1 = d__[i__] - e2[i__ - 1] / tmp1 - mid; |
|
if (dabs(tmp1) < *pivmin) { |
|
tmp1 = -(*pivmin); |
|
} |
|
if (tmp1 <= 0.f) { |
|
++negcnt; |
|
} |
|
/* L20: */ |
|
} |
|
if (negcnt >= *iw) { |
|
right = mid; |
|
} else { |
|
left = mid; |
|
} |
|
goto L10; |
|
L30: |
|
|
|
/* Converged or maximum number of iterations reached */ |
|
|
|
*w = (left + right) * .5f; |
|
*werr = (r__1 = right - left, dabs(r__1)) * .5f; |
|
return 0; |
|
|
|
/* End of SLARRK */ |
|
|
|
} /* slarrk_ */
|
|
|