/* DECK GAMR */
doublereal gamr_(real *x)
{
/* System generated locals */
real ret_val;
/* Local variables */
extern doublereal gamma_(real *);
static integer irold;
static real alngx;
extern /* Subroutine */ int xgetf_(integer *);
static real sgngx;
extern /* Subroutine */ int xsetf_(integer *), algams_(real *, real *,
real *), xerclr_(void);
/* ***BEGIN PROLOGUE GAMR */
/* ***PURPOSE Compute the reciprocal of the Gamma function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C7A */
/* ***TYPE SINGLE PRECISION (GAMR-S, DGAMR-D, CGAMR-C) */
/* ***KEYWORDS FNLIB, RECIPROCAL GAMMA FUNCTION, SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* GAMR is a single precision function that evaluates the reciprocal */
/* of the gamma function for single precision argument X. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED ALGAMS, GAMMA, XERCLR, XGETF, XSETF */
/* ***REVISION HISTORY (YYMMDD) */
/* 770701 DATE WRITTEN */
/* 861211 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900727 Added EXTERNAL statement. (WRB) */
/* ***END PROLOGUE GAMR */
/* ***FIRST EXECUTABLE STATEMENT GAMR */
ret_val = 0.f;
if (*x <= 0.f && r_int(x) == *x) {
return ret_val;
}
xgetf_(&irold);
xsetf_(&c__1);
if (dabs(*x) > 10.f) {
goto L10;
}
ret_val = 1.f / gamma_(x);
xerclr_();
xsetf_(&irold);
return ret_val;
L10:
algams_(x, &alngx, &sgngx);
xerclr_();
xsetf_(&irold);
ret_val = sgngx * exp(-alngx);
return ret_val;
} /* gamr_ */
void DynamicSlidingModeControllerTaskSpace::starting(const ros::Time& time)
{
// get joint positions
for(int i=0; i < joint_handles_.size(); i++)
{
joint_msr_states_.q(i) = joint_handles_[i].getPosition();
joint_msr_states_.qdot(i) = joint_handles_[i].getVelocity();
joint_des_states_.q(i) = joint_msr_states_.q(i);
sigma_(i) = 0;
// coefficients > 0
Kd_(i) = 10;
gamma_(i) = 1;
alpha_(i) = 12;
lambda_(i) = 1;
k_(i) = 3;
}
//x_des_ = KDL::Frame(KDL::Rotation::RPY(0,0,0),KDL::Vector(-0.4,0.3,1.5));
cmd_flag_ = 0;
step_ = 0;
}
/* DECK BESYNU */
/* Subroutine */ int besynu_(real *x, real *fnu, integer *n, real *y)
{
/* Initialized data */
static real x1 = 3.f;
static real x2 = 20.f;
static real pi = 3.14159265358979f;
static real rthpi = .797884560802865f;
static real hpi = 1.5707963267949f;
static real cc[8] = { .577215664901533f,-.0420026350340952f,
-.0421977345555443f,.007218943246663f,-2.152416741149e-4f,
-2.01348547807e-5f,1.133027232e-6f,6.116095e-9f };
/* System generated locals */
integer i__1;
real r__1, r__2;
/* Local variables */
static real a[120], f, g;
static integer i__, j, k;
static real p, q, s, a1, a2, g1, g2, s1, s2, t1, t2, cb[120], fc, ak, bk,
ck, fk, fn, rb[120];
static integer kk;
static real cs, sa, sb, cx;
static integer nn;
static real tb, fx, tm, pt, rs, ss, st, rx, cp1, cp2, cs1, cs2, rp1, rp2,
rs1, rs2, cbk, cck, arg, rbk, rck, fhs, fks, cpt, dnu, fmu;
static integer inu;
static real tol, etx, smu, rpt, dnu2, coef, relb, flrx;
extern doublereal gamma_(real *);
static real etest;
extern doublereal r1mach_(integer *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE BESYNU */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to BESY */
/* ***LIBRARY SLATEC */
/* ***TYPE SINGLE PRECISION (BESYNU-S, DBSYNU-D) */
/* ***AUTHOR Amos, D. E., (SNLA) */
/* ***DESCRIPTION */
/* Abstract */
/* BESYNU computes N member sequences of Y Bessel functions */
/* Y/SUB(FNU+I-1)/(X), I=1,N for non-negative orders FNU and */
/* positive X. Equations of the references are implemented on */
/* small orders DNU for Y/SUB(DNU)/(X) and Y/SUB(DNU+1)/(X). */
/* Forward recursion with the three term recursion relation */
/* generates higher orders FNU+I-1, I=1,...,N. */
/* To start the recursion FNU is normalized to the interval */
/* -0.5.LE.DNU.LT.0.5. A special form of the power series is */
/* implemented on 0.LT.X.LE.X1 while the Miller algorithm for the */
/* K Bessel function in terms of the confluent hypergeometric */
/* function U(FNU+0.5,2*FNU+1,I*X) is implemented on X1.LT.X.LE.X */
/* Here I is the complex number SQRT(-1.). */
/* For X.GT.X2, the asymptotic expansion for large X is used. */
/* When FNU is a half odd integer, a special formula for */
/* DNU=-0.5 and DNU+1.0=0.5 is used to start the recursion. */
/* BESYNU assumes that a significant digit SINH(X) function is */
/* available. */
/* Description of Arguments */
/* Input */
/* X - X.GT.0.0E0 */
/* FNU - Order of initial Y function, FNU.GE.0.0E0 */
/* N - Number of members of the sequence, N.GE.1 */
/* Output */
/* Y - A vector whose first N components contain values */
/* for the sequence Y(I)=Y/SUB(FNU+I-1), I=1,N. */
/* Error Conditions */
/* Improper input arguments - a fatal error */
/* Overflow - a fatal error */
/* ***SEE ALSO BESY */
/* ***REFERENCES N. M. Temme, On the numerical evaluation of the ordinary */
/* Bessel function of the second kind, Journal of */
/* Computational Physics 21, (1976), pp. 343-350. */
/* N. M. Temme, On the numerical evaluation of the modified */
/* Bessel function of the third kind, Journal of */
/* Computational Physics 19, (1975), pp. 324-337. */
/* ***ROUTINES CALLED GAMMA, R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 800501 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 900328 Added TYPE section. (WRB) */
/* 900727 Added EXTERNAL statement. (WRB) */
/* 910408 Updated the AUTHOR and REFERENCES sections. (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE BESYNU */
/* Parameter adjustments */
--y;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT BESYNU */
ak = r1mach_(&c__3);
tol = dmax(ak,1e-15f);
if (*x <= 0.f) {
goto L270;
}
if (*fnu < 0.f) {
goto L280;
}
if (*n < 1) {
goto L290;
}
rx = 2.f / *x;
inu = (integer) (*fnu + .5f);
dnu = *fnu - inu;
if (dabs(dnu) == .5f) {
goto L260;
}
dnu2 = 0.f;
if (dabs(dnu) < tol) {
goto L10;
}
dnu2 = dnu * dnu;
L10:
if (*x > x1) {
goto L120;
}
/* SERIES FOR X.LE.X1 */
a1 = 1.f - dnu;
a2 = dnu + 1.f;
t1 = 1.f / gamma_(&a1);
t2 = 1.f / gamma_(&a2);
if (dabs(dnu) > .1f) {
goto L40;
}
/* SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) */
s = cc[0];
ak = 1.f;
for (k = 2; k <= 8; ++k) {
ak *= dnu2;
tm = cc[k - 1] * ak;
s += tm;
if (dabs(tm) < tol) {
goto L30;
}
/* L20: */
}
L30:
g1 = -(s + s);
goto L50;
L40:
g1 = (t1 - t2) / dnu;
L50:
g2 = t1 + t2;
smu = 1.f;
fc = 1.f / pi;
flrx = log(rx);
fmu = dnu * flrx;
tm = 0.f;
if (dnu == 0.f) {
goto L60;
}
tm = sin(dnu * hpi) / dnu;
tm = (dnu + dnu) * tm * tm;
fc = dnu / sin(dnu * pi);
if (fmu != 0.f) {
smu = sinh(fmu) / fmu;
}
L60:
f = fc * (g1 * cosh(fmu) + g2 * flrx * smu);
fx = exp(fmu);
p = fc * t1 * fx;
q = fc * t2 / fx;
g = f + tm * q;
ak = 1.f;
ck = 1.f;
bk = 1.f;
s1 = g;
s2 = p;
if (inu > 0 || *n > 1) {
goto L90;
}
if (*x < tol) {
goto L80;
}
cx = *x * *x * .25f;
L70:
f = (ak * f + p + q) / (bk - dnu2);
p /= ak - dnu;
q /= ak + dnu;
g = f + tm * q;
ck = -ck * cx / ak;
t1 = ck * g;
s1 += t1;
bk = bk + ak + ak + 1.f;
ak += 1.f;
s = dabs(t1) / (dabs(s1) + 1.f);
if (s > tol) {
goto L70;
}
L80:
y[1] = -s1;
return 0;
L90:
if (*x < tol) {
goto L110;
}
cx = *x * *x * .25f;
L100:
f = (ak * f + p + q) / (bk - dnu2);
p /= ak - dnu;
q /= ak + dnu;
g = f + tm * q;
ck = -ck * cx / ak;
t1 = ck * g;
s1 += t1;
t2 = ck * (p - ak * g);
s2 += t2;
bk = bk + ak + ak + 1.f;
ak += 1.f;
s = dabs(t1) / (dabs(s1) + 1.f) + dabs(t2) / (dabs(s2) + 1.f);
if (s > tol) {
goto L100;
}
L110:
s2 = -s2 * rx;
s1 = -s1;
goto L160;
L120:
coef = rthpi / sqrt(*x);
if (*x > x2) {
goto L210;
}
/* MILLER ALGORITHM FOR X1.LT.X.LE.X2 */
etest = cos(pi * dnu) / (pi * *x * tol);
fks = 1.f;
fhs = .25f;
fk = 0.f;
rck = 2.f;
cck = *x + *x;
rp1 = 0.f;
cp1 = 0.f;
rp2 = 1.f;
cp2 = 0.f;
k = 0;
L130:
++k;
fk += 1.f;
ak = (fhs - dnu2) / (fks + fk);
pt = fk + 1.f;
rbk = rck / pt;
cbk = cck / pt;
rpt = rp2;
cpt = cp2;
rp2 = rbk * rpt - cbk * cpt - ak * rp1;
cp2 = cbk * rpt + rbk * cpt - ak * cp1;
rp1 = rpt;
cp1 = cpt;
rb[k - 1] = rbk;
cb[k - 1] = cbk;
a[k - 1] = ak;
rck += 2.f;
fks = fks + fk + fk + 1.f;
fhs = fhs + fk + fk;
/* Computing MAX */
r__1 = dabs(rp1), r__2 = dabs(cp1);
pt = dmax(r__1,r__2);
/* Computing 2nd power */
r__1 = rp1 / pt;
/* Computing 2nd power */
r__2 = cp1 / pt;
fc = r__1 * r__1 + r__2 * r__2;
pt = pt * sqrt(fc) * fk;
if (etest > pt) {
goto L130;
}
kk = k;
rs = 1.f;
cs = 0.f;
rp1 = 0.f;
cp1 = 0.f;
rp2 = 1.f;
cp2 = 0.f;
i__1 = k;
for (i__ = 1; i__ <= i__1; ++i__) {
rpt = rp2;
cpt = cp2;
rp2 = (rb[kk - 1] * rpt - cb[kk - 1] * cpt - rp1) / a[kk - 1];
cp2 = (cb[kk - 1] * rpt + rb[kk - 1] * cpt - cp1) / a[kk - 1];
rp1 = rpt;
cp1 = cpt;
rs += rp2;
cs += cp2;
--kk;
/* L140: */
}
/* Computing MAX */
r__1 = dabs(rs), r__2 = dabs(cs);
pt = dmax(r__1,r__2);
/* Computing 2nd power */
r__1 = rs / pt;
/* Computing 2nd power */
r__2 = cs / pt;
fc = r__1 * r__1 + r__2 * r__2;
pt *= sqrt(fc);
rs1 = (rp2 * (rs / pt) + cp2 * (cs / pt)) / pt;
cs1 = (cp2 * (rs / pt) - rp2 * (cs / pt)) / pt;
fc = hpi * (dnu - .5f) - *x;
p = cos(fc);
q = sin(fc);
s1 = (cs1 * q - rs1 * p) * coef;
if (inu > 0 || *n > 1) {
goto L150;
}
y[1] = s1;
return 0;
L150:
/* Computing MAX */
r__1 = dabs(rp2), r__2 = dabs(cp2);
pt = dmax(r__1,r__2);
/* Computing 2nd power */
r__1 = rp2 / pt;
/* Computing 2nd power */
r__2 = cp2 / pt;
fc = r__1 * r__1 + r__2 * r__2;
pt *= sqrt(fc);
rpt = dnu + .5f - (rp1 * (rp2 / pt) + cp1 * (cp2 / pt)) / pt;
cpt = *x - (cp1 * (rp2 / pt) - rp1 * (cp2 / pt)) / pt;
cs2 = cs1 * cpt - rs1 * rpt;
rs2 = rpt * cs1 + rs1 * cpt;
s2 = (rs2 * q + cs2 * p) * coef / *x;
/* FORWARD RECURSION ON THE THREE TERM RECURSION RELATION */
L160:
ck = (dnu + dnu + 2.f) / *x;
if (*n == 1) {
--inu;
}
if (inu > 0) {
goto L170;
}
if (*n > 1) {
goto L190;
}
s1 = s2;
goto L190;
L170:
i__1 = inu;
for (i__ = 1; i__ <= i__1; ++i__) {
st = s2;
s2 = ck * s2 - s1;
s1 = st;
ck += rx;
/* L180: */
}
if (*n == 1) {
s1 = s2;
}
L190:
y[1] = s1;
if (*n == 1) {
return 0;
}
y[2] = s2;
if (*n == 2) {
return 0;
}
i__1 = *n;
for (i__ = 3; i__ <= i__1; ++i__) {
y[i__] = ck * y[i__ - 1] - y[i__ - 2];
ck += rx;
/* L200: */
}
return 0;
/* ASYMPTOTIC EXPANSION FOR LARGE X, X.GT.X2 */
L210:
nn = 2;
if (inu == 0 && *n == 1) {
nn = 1;
}
dnu2 = dnu + dnu;
fmu = 0.f;
if (dabs(dnu2) < tol) {
goto L220;
}
fmu = dnu2 * dnu2;
L220:
arg = *x - hpi * (dnu + .5f);
sa = sin(arg);
sb = cos(arg);
etx = *x * 8.f;
i__1 = nn;
for (k = 1; k <= i__1; ++k) {
s1 = s2;
t2 = (fmu - 1.f) / etx;
ss = t2;
relb = tol * dabs(t2);
t1 = etx;
s = 1.f;
fn = 1.f;
ak = 0.f;
for (j = 1; j <= 13; ++j) {
t1 += etx;
ak += 8.f;
fn += ak;
t2 = -t2 * (fmu - fn) / t1;
s += t2;
t1 += etx;
ak += 8.f;
fn += ak;
t2 = t2 * (fmu - fn) / t1;
ss += t2;
if (dabs(t2) <= relb) {
goto L240;
}
/* L230: */
}
L240:
s2 = coef * (s * sa + ss * sb);
fmu = fmu + dnu * 8.f + 4.f;
tb = sa;
sa = -sb;
sb = tb;
/* L250: */
}
if (nn > 1) {
goto L160;
}
s1 = s2;
goto L190;
/* FNU=HALF ODD INTEGER CASE */
L260:
coef = rthpi / sqrt(*x);
s1 = coef * sin(*x);
s2 = -coef * cos(*x);
goto L160;
L270:
xermsg_("SLATEC", "BESYNU", "X NOT GREATER THAN ZERO", &c__2, &c__1, (
ftnlen)6, (ftnlen)6, (ftnlen)23);
return 0;
L280:
xermsg_("SLATEC", "BESYNU", "FNU NOT ZERO OR POSITIVE", &c__2, &c__1, (
ftnlen)6, (ftnlen)6, (ftnlen)24);
return 0;
L290:
xermsg_("SLATEC", "BESYNU", "N NOT GREATER THAN 0", &c__2, &c__1, (ftnlen)
6, (ftnlen)6, (ftnlen)20);
return 0;
} /* besynu_ */
/* DECK CHU */
doublereal chu_(real *a, real *b, real *x)
{
/* Initialized data */
static real pi = 3.14159265358979324f;
static real eps = 0.f;
/* System generated locals */
integer i__1;
real ret_val, r__1, r__2, r__3;
doublereal d__1, d__2;
/* Local variables */
static integer i__, m, n;
static real t, a0, b0, c0, xi, xn, xi1, sum;
extern doublereal gamr_(real *);
static real beps;
extern doublereal poch_(real *, real *);
static real alnx, pch1i;
extern doublereal poch1_(real *, real *), r9chu_(real *, real *, real *);
static real xeps1;
extern doublereal gamma_(real *);
static real aintb;
static integer istrt;
static real pch1ai;
extern doublereal r1mach_(integer *);
static real gamri1, pochai, gamrni, factor;
extern doublereal exprel_(real *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
static real xtoeps;
/* ***BEGIN PROLOGUE CHU */
/* ***PURPOSE Compute the logarithmic confluent hypergeometric function. */
/* ***LIBRARY SLATEC (FNLIB) */
/* ***CATEGORY C11 */
/* ***TYPE SINGLE PRECISION (CHU-S, DCHU-D) */
/* ***KEYWORDS FNLIB, LOGARITHMIC CONFLUENT HYPERGEOMETRIC FUNCTION, */
/* SPECIAL FUNCTIONS */
/* ***AUTHOR Fullerton, W., (LANL) */
/* ***DESCRIPTION */
/* CHU computes the logarithmic confluent hypergeometric function, */
/* U(A,B,X). */
/* Input Parameters: */
/* A real */
/* B real */
/* X real and positive */
/* This routine is not valid when 1+A-B is close to zero if X is small. */
/* ***REFERENCES (NONE) */
/* ***ROUTINES CALLED EXPREL, GAMMA, GAMR, POCH, POCH1, R1MACH, R9CHU, */
/* XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 770801 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890531 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900315 CALLs to XERROR changed to CALLs to XERMSG. (THJ) */
/* 900727 Added EXTERNAL statement. (WRB) */
/* ***END PROLOGUE CHU */
/* ***FIRST EXECUTABLE STATEMENT CHU */
if (eps == 0.f) {
eps = r1mach_(&c__3);
}
if (*x == 0.f) {
xermsg_("SLATEC", "CHU", "X IS ZERO SO CHU IS INFINITE", &c__1, &c__2,
(ftnlen)6, (ftnlen)3, (ftnlen)28);
}
if (*x < 0.f) {
xermsg_("SLATEC", "CHU", "X IS NEGATIVE, USE CCHU", &c__2, &c__2, (
ftnlen)6, (ftnlen)3, (ftnlen)23);
}
/* Computing MAX */
r__2 = dabs(*a);
/* Computing MAX */
r__3 = (r__1 = *a + 1.f - *b, dabs(r__1));
if (dmax(r__2,1.f) * dmax(r__3,1.f) < dabs(*x) * .99f) {
goto L120;
}
/* THE ASCENDING SERIES WILL BE USED, BECAUSE THE DESCENDING RATIONAL */
/* APPROXIMATION (WHICH IS BASED ON THE ASYMPTOTIC SERIES) IS UNSTABLE. */
if ((r__1 = *a + 1.f - *b, dabs(r__1)) < sqrt(eps)) {
xermsg_("SLATEC", "CHU", "ALGORITHM IS BAD WHEN 1+A-B IS NEAR ZERO F"
"OR SMALL X", &c__10, &c__2, (ftnlen)6, (ftnlen)3, (ftnlen)52);
}
r__1 = *b + .5f;
aintb = r_int(&r__1);
if (*b < 0.f) {
r__1 = *b - .5f;
aintb = r_int(&r__1);
}
beps = *b - aintb;
n = aintb;
alnx = log(*x);
xtoeps = exp(-beps * alnx);
/* EVALUATE THE FINITE SUM. ----------------------------------------- */
if (n >= 1) {
goto L40;
}
/* CONSIDER THE CASE B .LT. 1.0 FIRST. */
sum = 1.f;
if (n == 0) {
goto L30;
}
t = 1.f;
m = -n;
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
xi1 = (real) (i__ - 1);
t = t * (*a + xi1) * *x / ((*b + xi1) * (xi1 + 1.f));
sum += t;
/* L20: */
}
L30:
r__1 = *a + 1.f - *b;
r__2 = -(*a);
sum = poch_(&r__1, &r__2) * sum;
goto L70;
/* NOW CONSIDER THE CASE B .GE. 1.0. */
L40:
sum = 0.f;
m = n - 2;
if (m < 0) {
goto L70;
}
t = 1.f;
sum = 1.f;
if (m == 0) {
goto L60;
}
i__1 = m;
for (i__ = 1; i__ <= i__1; ++i__) {
xi = (real) i__;
t = t * (*a - *b + xi) * *x / ((1.f - *b + xi) * xi);
sum += t;
/* L50: */
}
L60:
r__1 = *b - 1.f;
i__1 = 1 - n;
sum = gamma_(&r__1) * gamr_(a) * pow_ri(x, &i__1) * xtoeps * sum;
/* NOW EVALUATE THE INFINITE SUM. ----------------------------------- */
L70:
istrt = 0;
if (n < 1) {
istrt = 1 - n;
}
xi = (real) istrt;
r__1 = *a + 1.f - *b;
factor = pow_ri(&c_b25, &n) * gamr_(&r__1) * pow_ri(x, &istrt);
if (beps != 0.f) {
factor = factor * beps * pi / sin(beps * pi);
}
pochai = poch_(a, &xi);
r__1 = xi + 1.f;
gamri1 = gamr_(&r__1);
r__1 = aintb + xi;
gamrni = gamr_(&r__1);
r__1 = xi - beps;
r__2 = xi + 1.f - beps;
b0 = factor * poch_(a, &r__1) * gamrni * gamr_(&r__2);
if ((r__1 = xtoeps - 1.f, dabs(r__1)) > .5f) {
goto L90;
}
/* X**(-BEPS) IS CLOSE TO 1.0, SO WE MUST BE CAREFUL IN EVALUATING */
/* THE DIFFERENCES */
r__1 = *a + xi;
r__2 = -beps;
pch1ai = poch1_(&r__1, &r__2);
r__1 = xi + 1.f - beps;
pch1i = poch1_(&r__1, &beps);
r__1 = *b + xi;
r__2 = -beps;
c0 = factor * pochai * gamrni * gamri1 * (-poch1_(&r__1, &r__2) + pch1ai
- pch1i + beps * pch1ai * pch1i);
/* XEPS1 = (1.0 - X**(-BEPS)) / BEPS */
r__1 = -beps * alnx;
xeps1 = alnx * exprel_(&r__1);
ret_val = sum + c0 + xeps1 * b0;
xn = (real) n;
for (i__ = 1; i__ <= 1000; ++i__) {
xi = (real) (istrt + i__);
xi1 = (real) (istrt + i__ - 1);
b0 = (*a + xi1 - beps) * b0 * *x / ((xn + xi1) * (xi - beps));
c0 = (*a + xi1) * c0 * *x / ((*b + xi1) * xi) - ((*a - 1.f) * (xn +
xi * 2.f - 1.f) + xi * (xi - beps)) * b0 / (xi * (*b + xi1) *
(*a + xi1 - beps));
t = c0 + xeps1 * b0;
ret_val += t;
if (dabs(t) < eps * dabs(ret_val)) {
goto L130;
}
/* L80: */
}
xermsg_("SLATEC", "CHU", "NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING "
"SERIES", &c__3, &c__2, (ftnlen)6, (ftnlen)3, (ftnlen)52);
/* X**(-BEPS) IS VERY DIFFERENT FROM 1.0, SO THE STRAIGHTFORWARD */
/* FORMULATION IS STABLE. */
L90:
r__1 = *b + xi;
a0 = factor * pochai * gamr_(&r__1) * gamri1 / beps;
b0 = xtoeps * b0 / beps;
ret_val = sum + a0 - b0;
for (i__ = 1; i__ <= 1000; ++i__) {
xi = (real) (istrt + i__);
xi1 = (real) (istrt + i__ - 1);
a0 = (*a + xi1) * a0 * *x / ((*b + xi1) * xi);
b0 = (*a + xi1 - beps) * b0 * *x / ((aintb + xi1) * (xi - beps));
t = a0 - b0;
ret_val += t;
if (dabs(t) < eps * dabs(ret_val)) {
goto L130;
}
/* L100: */
}
xermsg_("SLATEC", "CHU", "NO CONVERGENCE IN 1000 TERMS OF THE ASCENDING "
"SERIES", &c__3, &c__2, (ftnlen)6, (ftnlen)3, (ftnlen)52);
/* USE LUKE-S RATIONAL APPROX IN THE ASYMPTOTIC REGION. */
L120:
d__1 = (doublereal) (*x);
d__2 = (doublereal) (-(*a));
ret_val = pow_dd(&d__1, &d__2) * r9chu_(a, b, x);
L130:
return ret_val;
} /* chu_ */
int recur(int n,int ipoly, double al, double be, double *a, double *b)
{
/* System generated locals */
double r__1, r__2, r__3;
int ierr;
/* Local variables */
int k;
double alpbe, t;
double almach, be2, al2, fkm1;
/* This subroutine generates the coefficients a(k),b(k), k=0,1,...,n-1, */
/* in the recurrence relation */
/* p(k+1)(x)=(x-a(k))*p(k)(x)-b(k)*p(k-1)(x), */
/* k=0,1,...,n-1, */
/* p(-1)(x)=0, p(0)(x)=1, */
/* for some classical (monic) orthogonal polynomials, and sets b(0) */
/* equal to the total mass of the weight distribution. The results are */
/* stored in the arrays a,b, which hold, respectively, the coefficients */
/* a(k-1),b(k-1), k=1,2,...,n. */
/* Input: n - - the number of recursion coefficients desired */
/* ipoly-int identifying the polynomial as follows: */
/* 1=Legendre polynomial on (-1,1) */
/* 2=Legendre polynomial on (0,1) */
/* 3=Chebyshev polynomial of the first kind */
/* 4=Chebyshev polynomial of the second kind */
/* 5=Jacobi polynomial with parameters al=-.5,be=.5 */
/* 6=Jacobi polynomial with parameters al,be */
/* 7=generalized Laguerre polynomial with */
/* parameter al */
/* 8=Hermite polynomial */
/* al,be-input parameters for Jacobi and generalized */
/* Laguerre polynomials */
/* Output: a,b - arrays containing, respectively, the recursion */
/* coefficients a(k-1),b(k-1), k=1,2,...,n. */
/* ierr -an error flag, equal to 0 on normal return, */
/* equal to 1 if al or be are out of range */
/* when ipoly=6 or ipoly=7, equal to 2 if b(0) */
/* overflows when ipoly=6 or ipoly=7, equal to 3 */
/* if n is out of range, and equal to 4 if ipoly */
/* is not an admissible int. In the case ierr=2, */
/* the coefficient b(0) is set equal to the largest */
/* machine-representable number. */
/* The subroutine calls for the function subroutines r1mach,gamma and */
/* alga. The routines gamma and alga, which are included in this file, */
/* evaluate respectively the gamma function and its logarithm for */
/* positive arguments. They are used only in the cases ipoly=6 and */
/* ipoly=7. */
/* Function Body */
if (n < 1) {
return(3);
}
almach = log(DBL_MAX);
ierr = 0;
for (k = 0; k < n; ++k) {
a[k] = 0.;
}
if (ipoly == 1) {
b[0] = 2.;
if (n == 1) {
return(0);
}
for (k = 1; k < n; ++k) {
fkm1 = k;
b[k] = 1. / (4. - 1. /(fkm1 * fkm1));
}
return 0;
} else if (ipoly == 2) {
a[0] = .5;
b[0] = 1.;
if (n == 1) {
return 0 ;
}
for (k = 1; k <= n; ++k) {
a[k] = .5;
fkm1 = k;
b[k] = .25 / (4. - 1. / (fkm1 * fkm1));
}
return 0;
} else if (ipoly == 3) {
b[0] = atan(1.) * 4.;
if (n == 1) {
return 0;
}
b[1] = .5;
if (n == 2) {
return 0;
}
for (k = 2; k < n; ++k) {
b[k] = .25;
}
return 0;
} else if (ipoly == 4) {
b[0] = atan(1.) * 2.;
if (n == 1) {
return 0;
}
for (k = 1; k < n; ++k) {
b[k] = .25;
}
return 0;
} else if (ipoly == 5) {
b[0] = atan(1.) * 4.;
a[0] = .5;
if (n == 1) {
return 0;
}
for (k = 1; k < n; ++k) {
b[k] = .25;
}
return 0;
} else if (ipoly == 6) {
if (al <= -1. || be <= -1.) {
return 1;
} else {
alpbe = al + be;
a[0] = (be - al) / (alpbe + 2.);
r__1 = al + 1.;
r__2 = be + 1.;
r__3 = alpbe + 2.;
t = (alpbe + 1.) * log(2.) + alga_(r__1) + alga_(
r__2) - alga_(r__3);
if (t > almach) {
ierr = 2;
b[0] = DBL_MAX;
} else {
b[0] = exp(t);
}
if (n == 1) {
return 0;
}
al2 = al * al;
be2 = be * be;
a[1] = (be2 - al2) / ((alpbe + 2.) * (alpbe + 4.));
/* Computing 2nd power */
r__1 = alpbe + 2.;
b[1] = (al + 1.) * 4. * (be + 1.) / ((
alpbe + 3.) * (r__1 * r__1));
if (n == 2) {
return 0;
}
for (k = 2; k < n; ++k) {
fkm1 = k;
a[k] = (be2 - al2) * .25 / (fkm1 * fkm1 * (alpbe * (
float).5 / fkm1 + 1.) * ((alpbe + 2.) *
.5 / fkm1 + 1.));
/* Computing 2nd power */
r__1 = alpbe * .5 / fkm1 + 1.;
b[k] = (al / fkm1 + 1.) * .25 * (be / fkm1 + (
float)1.) * (alpbe / fkm1 + 1.) / (((alpbe + (
float)1.) * .5 / fkm1 + 1.) * ((alpbe -
1.) * .5 / fkm1 + 1.) * (r__1 *
r__1));
}
return 0;
}
} else if (ipoly == 7) {
if (al <= -1.) {
return 1;
} else {
a[0] = al + 1.;
r__1 = al + 1.;
b[0] = gamma_(r__1, &ierr);
if (ierr == 2) {
b[0] = DBL_MAX;
}
if (n == 1) {
return 0;
}
for (k = 0; k < n; ++k) {
fkm1 = k;
a[k] = fkm1 * 2. + al + 1.;
b[k] = fkm1 * (fkm1 + al);
}
return 0;
}
} else if (ipoly == 8) {
b[0] = sqrt(atan( 1.) * 4.);
if (n == 1) {
return 0;
}
for (k = 1; k <= n; ++k) {
b[k] = k * .5;
}
return 0;
} else {
ierr = 4;
}
return(ierr);
} /* recur_ */