/* DECK DBSKIN */
/* Subroutine */ int dbskin_(doublereal *x, integer *n, integer *kode,
integer *m, doublereal *y, integer *nz, integer *ierr)
{
/* Initialized data */
static doublereal a[50] = { 1.,.5,.375,.3125,.2734375,.24609375,
.2255859375,.20947265625,.196380615234375,.1854705810546875,
.176197052001953125,.168188095092773438,.161180257797241211,
.154981017112731934,.149445980787277222,.144464448094367981,
.139949934091418982,.135833759559318423,.132060599571559578,
.128585320635465905,.125370687619579257,.122385671247684513,
.119604178719328047,.117004087877603524,.114566502713486784,
.112275172659217048,.110116034723462874,.108076848895250599,
.106146905164978267,.104316786110409676,.102578173008569515,
.100923686347140974,.0993467537479668965,.0978414999033007314,
.0964026543164874854,.0950254735405376642,.0937056752969190855,
.09243938238750126,.0912230747245078224,.0900535481254756708,
.0889278787739072249,.0878433924473961612,.0867976377754033498,
.0857883629175498224,.0848134951571231199,.0838711229887106408,
.0829594803475290034,.0820769326842574183,.0812219646354630702,
.0803931690779583449 };
static doublereal hrtpi = .886226925452758014;
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
/* Local variables */
static doublereal h__[31];
static integer i__, k;
static doublereal w;
static integer m3;
static doublereal t1, t2;
static integer ne;
static doublereal fn;
static integer il, kk;
static doublereal hn, gr;
static integer nl, nn, np, ns, nt;
static doublereal ss, xp, ys[3];
static integer i1m;
static doublereal exi[102], tol, yss[3];
static integer nflg, nlim;
static doublereal xlim;
static integer icase;
static doublereal enlim, xnlim;
extern doublereal d1mach_(integer *);
static integer ktrms;
extern integer i1mach_(integer *);
extern /* Subroutine */ int dbkias_(doublereal *, integer *, integer *,
doublereal *, doublereal *, integer *, integer *, doublereal *,
doublereal *, integer *);
extern doublereal dgamrn_(doublereal *);
extern /* Subroutine */ int dbkisr_(doublereal *, integer *, doublereal *,
integer *), dexint_(doublereal *, integer *, integer *, integer *
, doublereal *, doublereal *, integer *, integer *);
/* ***BEGIN PROLOGUE DBSKIN */
/* ***PURPOSE Compute repeated integrals of the K-zero Bessel function. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C10F */
/* ***TYPE DOUBLE PRECISION (BSKIN-S, DBSKIN-D) */
/* ***KEYWORDS BICKLEY FUNCTIONS, EXPONENTIAL INTEGRAL, */
/* INTEGRALS OF BESSEL FUNCTIONS, K-ZERO BESSEL FUNCTION */
/* ***AUTHOR Amos, D. E., (SNLA) */
/* ***DESCRIPTION */
/* The following definitions are used in DBSKIN: */
/* Definition 1 */
/* KI(0,X) = K-zero Bessel function. */
/* Definition 2 */
/* KI(N,X) = Bickley Function */
/* = integral from X to infinity of KI(N-1,t)dt */
/* for X .ge. 0 and N = 1,2,... */
/* _____________________________________________________________________ */
/* DBSKIN computes a sequence of Bickley functions (repeated integrals */
/* of the K0 Bessel function); i.e. for fixed X and N and for K=1,..., */
/* DBSKIN computes the sequence */
/* Y(K) = KI(N+K-1,X) for KODE=1 */
/* or */
/* Y(K) = EXP(X)*KI(N+K-1,X) for KODE=2, */
/* for N.ge.0 and X.ge.0 (N and X cannot be zero simultaneously). */
/* INPUT X is DOUBLE PRECISION */
/* X - Argument, X .ge. 0.0D0 */
/* N - Order of first member of the sequence N .ge. 0 */
/* KODE - Selection parameter */
/* KODE = 1 returns Y(K)= KI(N+K-1,X), K=1,M */
/* = 2 returns Y(K)=EXP(X)*KI(N+K-1,X), K=1,M */
/* M - Number of members in the sequence, M.ge.1 */
/* OUTPUT Y is a DOUBLE PRECISION VECTOR */
/* Y - A vector of dimension at least M containing the */
/* sequence selected by KODE. */
/* NZ - Underflow flag */
/* NZ = 0 means computation completed */
/* = 1 means an exponential underflow occurred on */
/* KODE=1. Y(K)=0.0D0, K=1,...,M is returned */
/* KODE=1 AND Y(K)=0.0E0, K=1,...,M IS RETURNED */
/* IERR - Error flag */
/* IERR=0, Normal return, computation completed */
/* IERR=1, Input error, no computation */
/* IERR=2, Error, no computation */
/* Algorithm termination condition not met */
/* The nominal computational accuracy is the maximum of unit */
/* roundoff (=D1MACH(4)) and 1.0D-18 since critical constants */
/* are given to only 18 digits. */
/* BSKIN is the single precision version of DBSKIN. */
/* *Long Description: */
/* Numerical recurrence on */
/* (L-1)*KI(L,X) = X(KI(L-3,X) - KI(L-1,X)) + (L-2)*KI(L-2,X) */
/* is stable where recurrence is carried forward or backward */
/* away from INT(X+0.5). The power series for indices 0,1 and 2 */
/* on 0.le.X.le.2 starts a stable recurrence for indices */
/* greater than 2. If N is sufficiently large (N.gt.NLIM), the */
/* uniform asymptotic expansion for N to INFINITY is more */
/* economical. On X.gt.2 the recursion is started by evaluating */
/* the uniform expansion for the three members whose indices are */
/* closest to INT(X+0.5) within the set N,...,N+M-1. Forward */
/* recurrence, backward recurrence or both complete the */
/* sequence depending on the relation of INT(X+0.5) to the */
/* indices N,...,N+M-1. */
/* ***REFERENCES D. E. Amos, Uniform asymptotic expansions for */
/* exponential integrals E(N,X) and Bickley functions */
/* KI(N,X), ACM Transactions on Mathematical Software, */
/* 1983. */
/* D. E. Amos, A portable Fortran subroutine for the */
/* Bickley functions KI(N,X), Algorithm 609, ACM */
/* Transactions on Mathematical Software, 1983. */
/* ***ROUTINES CALLED D1MACH, DBKIAS, DBKISR, DEXINT, DGAMRN, I1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 820601 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890911 Removed unnecessary intrinsics. (WRB) */
/* 891006 Cosmetic changes to prologue. (WRB) */
/* 891009 Removed unreferenced statement label. (WRB) */
/* 891009 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE DBSKIN */
/* ----------------------------------------------------------------------- */
/* COEFFICIENTS IN SERIES OF EXPONENTIAL INTEGRALS */
/* ----------------------------------------------------------------------- */
/* Parameter adjustments */
--y;
/* Function Body */
/* ----------------------------------------------------------------------- */
/* SQRT(PI)/2 */
/* ----------------------------------------------------------------------- */
/* ***FIRST EXECUTABLE STATEMENT DBSKIN */
*ierr = 0;
*nz = 0;
if (*x < 0.) {
*ierr = 1;
}
if (*n < 0) {
*ierr = 1;
}
if (*kode < 1 || *kode > 2) {
*ierr = 1;
}
if (*m < 1) {
*ierr = 1;
}
if (*x == 0. && *n == 0) {
*ierr = 1;
}
if (*ierr != 0) {
return 0;
}
if (*x == 0.) {
goto L300;
}
i1m = -i1mach_(&c__15);
t1 = d1mach_(&c__5) * 2.3026 * i1m;
xlim = t1 - 3.228086;
t2 = t1 + (*n + *m - 1);
if (t2 > 1e3) {
xlim = t1 - (log(t2) - .451583) * .5;
}
if (*x > xlim && *kode == 1) {
goto L320;
}
/* Computing MAX */
d__1 = d1mach_(&c__4);
tol = max(d__1,1e-18);
i1m = i1mach_(&c__14);
/* ----------------------------------------------------------------------- */
/* LN(NLIM) = 0.125*LN(EPS), NLIM = 2*KTRMS+N */
/* ----------------------------------------------------------------------- */
xnlim = (i1m - 1) * .287823 * d1mach_(&c__5);
enlim = exp(xnlim);
nlim = (integer) enlim + 2;
nlim = min(100,nlim);
nlim = max(20,nlim);
m3 = min(*m,3);
nl = *n + *m - 1;
if (*x > 2.) {
goto L130;
}
if (*n > nlim) {
goto L280;
}
/* ----------------------------------------------------------------------- */
/* COMPUTATION BY SERIES FOR 0.LE.X.LE.2 */
/* ----------------------------------------------------------------------- */
nflg = 0;
nn = *n;
if (nl <= 2) {
goto L60;
}
m3 = 3;
nn = 0;
nflg = 1;
L60:
xp = 1.;
if (*kode == 2) {
xp = exp(*x);
}
i__1 = m3;
for (i__ = 1; i__ <= i__1; ++i__) {
dbkisr_(x, &nn, &w, ierr);
if (*ierr != 0) {
return 0;
}
w *= xp;
if (nn < *n) {
goto L70;
}
kk = nn - *n + 1;
y[kk] = w;
L70:
ys[i__ - 1] = w;
++nn;
/* L80: */
}
if (nflg == 0) {
return 0;
}
ns = nn;
xp = 1.;
L90:
/* ----------------------------------------------------------------------- */
/* FORWARD RECURSION SCALED BY EXP(X) ON ICASE=0,1,2 */
/* ----------------------------------------------------------------------- */
fn = (doublereal) (ns - 1);
il = nl - ns + 1;
if (il <= 0) {
return 0;
}
i__1 = il;
for (i__ = 1; i__ <= i__1; ++i__) {
t1 = ys[1];
t2 = ys[2];
ys[2] = (*x * (ys[0] - ys[2]) + (fn - 1.) * ys[1]) / fn;
ys[1] = t2;
ys[0] = t1;
fn += 1.;
if (ns < *n) {
goto L100;
}
kk = ns - *n + 1;
y[kk] = ys[2] * xp;
L100:
++ns;
/* L110: */
}
return 0;
/* ----------------------------------------------------------------------- */
/* COMPUTATION BY ASYMPTOTIC EXPANSION FOR X.GT.2 */
/* ----------------------------------------------------------------------- */
L130:
w = *x + .5;
nt = (integer) w;
if (nl > nt) {
goto L270;
}
/* ----------------------------------------------------------------------- */
/* CASE NL.LE.NT, ICASE=0 */
/* ----------------------------------------------------------------------- */
icase = 0;
nn = nl;
/* Computing MIN */
i__1 = *m - m3;
nflg = min(i__1,1);
L140:
kk = (nlim - nn) / 2;
ktrms = max(0,kk);
ns = nn + 1;
np = nn - m3 + 1;
xp = 1.;
if (*kode == 1) {
xp = exp(-(*x));
}
i__1 = m3;
for (i__ = 1; i__ <= i__1; ++i__) {
kk = i__;
dbkias_(x, &np, &ktrms, a, &w, &kk, &ne, &gr, h__, ierr);
if (*ierr != 0) {
return 0;
}
ys[i__ - 1] = w;
++np;
/* L150: */
}
/* ----------------------------------------------------------------------- */
/* SUM SERIES OF EXPONENTIAL INTEGRALS BACKWARD */
/* ----------------------------------------------------------------------- */
if (ktrms == 0) {
goto L160;
}
ne = ktrms + ktrms + 1;
np = nn - m3 + 2;
dexint_(x, &np, &c__2, &ne, &tol, exi, nz, ierr);
if (*nz != 0) {
goto L320;
}
L160:
i__1 = m3;
for (i__ = 1; i__ <= i__1; ++i__) {
ss = 0.;
if (ktrms == 0) {
goto L180;
}
kk = i__ + ktrms + ktrms - 2;
il = ktrms;
i__2 = ktrms;
for (k = 1; k <= i__2; ++k) {
ss += a[il - 1] * exi[kk - 1];
kk += -2;
--il;
/* L170: */
}
L180:
ys[i__ - 1] += ss;
/* L190: */
}
if (icase == 1) {
goto L200;
}
if (nflg != 0) {
goto L220;
}
L200:
i__1 = m3;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = ys[i__ - 1] * xp;
/* L210: */
}
if (icase == 1 && nflg == 1) {
goto L90;
}
return 0;
L220:
/* ----------------------------------------------------------------------- */
/* BACKWARD RECURSION SCALED BY EXP(X) ICASE=0,2 */
/* ----------------------------------------------------------------------- */
kk = nn - *n + 1;
k = m3;
i__1 = m3;
for (i__ = 1; i__ <= i__1; ++i__) {
y[kk] = ys[k - 1] * xp;
yss[i__ - 1] = ys[i__ - 1];
--kk;
--k;
/* L230: */
}
il = kk;
if (il <= 0) {
goto L250;
}
fn = (doublereal) (nn - 3);
i__1 = il;
for (i__ = 1; i__ <= i__1; ++i__) {
t1 = ys[1];
t2 = ys[0];
ys[0] = ys[1] + ((fn + 2.) * ys[2] - (fn + 1.) * ys[0]) / *x;
ys[1] = t2;
ys[2] = t1;
y[kk] = ys[0] * xp;
--kk;
fn += -1.;
/* L240: */
}
L250:
if (icase != 2) {
return 0;
}
i__1 = m3;
for (i__ = 1; i__ <= i__1; ++i__) {
ys[i__ - 1] = yss[i__ - 1];
/* L260: */
}
goto L90;
L270:
if (*n < nt) {
goto L290;
}
/* ----------------------------------------------------------------------- */
/* ICASE=1, NT.LE.N.LE.NL WITH FORWARD RECURSION */
/* ----------------------------------------------------------------------- */
L280:
nn = *n + m3 - 1;
/* Computing MIN */
i__1 = *m - m3;
nflg = min(i__1,1);
icase = 1;
goto L140;
/* ----------------------------------------------------------------------- */
/* ICASE=2, N.LT.NT.LT.NL WITH BOTH FORWARD AND BACKWARD RECURSION */
/* ----------------------------------------------------------------------- */
L290:
nn = nt + 1;
/* Computing MIN */
i__1 = *m - m3;
nflg = min(i__1,1);
icase = 2;
goto L140;
/* ----------------------------------------------------------------------- */
/* X=0 CASE */
/* ----------------------------------------------------------------------- */
L300:
fn = (doublereal) (*n);
hn = fn * .5;
gr = dgamrn_(&hn);
y[1] = hrtpi * gr;
if (*m == 1) {
return 0;
}
y[2] = hrtpi / (hn * gr);
if (*m == 2) {
return 0;
}
i__1 = *m;
for (k = 3; k <= i__1; ++k) {
y[k] = fn * y[k - 2] / (fn + 1.);
fn += 1.;
/* L310: */
}
return 0;
/* ----------------------------------------------------------------------- */
/* UNDERFLOW ON KODE=1, X.GT.XLIM */
/* ----------------------------------------------------------------------- */
L320:
*nz = *m;
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
y[i__] = 0.;
/* L330: */
}
return 0;
} /* dbskin_ */
/* DECK CAIRY */
/* Subroutine */ int cairy_(complex *z__, integer *id, integer *kode, complex
*ai, integer *nz, integer *ierr)
{
/* Initialized data */
static real tth = .666666666666666667f;
static real c1 = .35502805388781724f;
static real c2 = .258819403792806799f;
static real coef = .183776298473930683f;
static complex cone = {1.f,0.f};
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
doublereal d__1, d__2;
complex q__1, q__2, q__3, q__4, q__5, q__6;
/* Local variables */
static integer k;
static real d1, d2;
static integer k1, k2;
static complex s1, s2, z3;
static real aa, bb, ad, ak, bk, ck, dk, az;
static complex cy[1];
static integer nn;
static real rl;
static integer mr;
static real zi, zr, az3, z3i, z3r, fid, dig, r1m5;
static complex csq;
static real fnu;
static complex zta;
static real tol;
static complex trm1, trm2;
static real sfac, alim, elim, alaz, atrm;
extern /* Subroutine */ int cacai_(complex *, real *, integer *, integer *
, integer *, complex *, integer *, real *, real *, real *, real *)
;
static integer iflag;
extern /* Subroutine */ int cbknu_(complex *, real *, integer *, integer *
, complex *, integer *, real *, real *, real *);
extern integer i1mach_(integer *);
extern doublereal r1mach_(integer *);
/* ***BEGIN PROLOGUE CAIRY */
/* ***PURPOSE Compute the Airy function Ai(z) or its derivative dAi/dz */
/* for complex argument z. A scaling option is available */
/* to help avoid underflow and overflow. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C10D */
/* ***TYPE COMPLEX (CAIRY-C, ZAIRY-C) */
/* ***KEYWORDS AIRY FUNCTION, BESSEL FUNCTION OF ORDER ONE THIRD, */
/* BESSEL FUNCTION OF ORDER TWO THIRDS */
/* ***AUTHOR Amos, D. E., (SNL) */
/* ***DESCRIPTION */
/* On KODE=1, CAIRY computes the complex Airy function Ai(z) */
/* or its derivative dAi/dz on ID=0 or ID=1 respectively. On */
/* KODE=2, a scaling option exp(zeta)*Ai(z) or exp(zeta)*dAi/dz */
/* is provided to remove the exponential decay in -pi/3<arg(z) */
/* <pi/3 and the exponential growth in pi/3<abs(arg(z))<pi where */
/* zeta=(2/3)*z**(3/2). */
/* While the Airy functions Ai(z) and dAi/dz are analytic in */
/* the whole z-plane, the corresponding scaled functions defined */
/* for KODE=2 have a cut along the negative real axis. */
/* Input */
/* Z - Argument of type COMPLEX */
/* ID - Order of derivative, ID=0 or ID=1 */
/* KODE - A parameter to indicate the scaling option */
/* KODE=1 returns */
/* AI=Ai(z) on ID=0 */
/* AI=dAi/dz on ID=1 */
/* at z=Z */
/* =2 returns */
/* AI=exp(zeta)*Ai(z) on ID=0 */
/* AI=exp(zeta)*dAi/dz on ID=1 */
/* at z=Z where zeta=(2/3)*z**(3/2) */
/* Output */
/* AI - Result of type COMPLEX */
/* NZ - Underflow indicator */
/* NZ=0 Normal return */
/* NZ=1 AI=0 due to underflow in */
/* -pi/3<arg(Z)<pi/3 on KODE=1 */
/* IERR - Error flag */
/* IERR=0 Normal return - COMPUTATION COMPLETED */
/* IERR=1 Input error - NO COMPUTATION */
/* IERR=2 Overflow - NO COMPUTATION */
/* (Re(Z) too large with KODE=1) */
/* IERR=3 Precision warning - COMPUTATION COMPLETED */
/* (Result has less than half precision) */
/* IERR=4 Precision error - NO COMPUTATION */
/* (Result has no precision) */
/* IERR=5 Algorithmic error - NO COMPUTATION */
/* (Termination condition not met) */
/* *Long Description: */
/* Ai(z) and dAi/dz are computed from K Bessel functions by */
/* Ai(z) = c*sqrt(z)*K(1/3,zeta) */
/* dAi/dz = -c* z *K(2/3,zeta) */
/* c = 1/(pi*sqrt(3)) */
/* zeta = (2/3)*z**(3/2) */
/* when abs(z)>1 and from power series when abs(z)<=1. */
/* In most complex variable computation, one must evaluate ele- */
/* mentary functions. When the magnitude of Z is large, losses */
/* of significance by argument reduction occur. Consequently, if */
/* the magnitude of ZETA=(2/3)*Z**(3/2) exceeds U1=SQRT(0.5/UR), */
/* then losses exceeding half precision are likely and an error */
/* flag IERR=3 is triggered where UR=R1MACH(4)=UNIT ROUNDOFF. */
/* Also, if the magnitude of ZETA is larger than U2=0.5/UR, then */
/* all significance is lost and IERR=4. In order to use the INT */
/* function, ZETA must be further restricted not to exceed */
/* U3=I1MACH(9)=LARGEST INTEGER. Thus, the magnitude of ZETA */
/* must be restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, */
/* and U3 are approximately 2.0E+3, 4.2E+6, 2.1E+9 in single */
/* precision and 4.7E+7, 2.3E+15, 2.1E+9 in double precision. */
/* This makes U2 limiting is single precision and U3 limiting */
/* in double precision. This means that the magnitude of Z */
/* cannot exceed approximately 3.4E+4 in single precision and */
/* 2.1E+6 in double precision. This also means that one can */
/* expect to retain, in the worst cases on 32-bit machines, */
/* no digits in single precision and only 6 digits in double */
/* precision. */
/* The approximate relative error in the magnitude of a complex */
/* Bessel function can be expressed as P*10**S where P=MAX(UNIT */
/* ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- */
/* sents the increase in error due to argument reduction in the */
/* elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), */
/* ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF */
/* ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may */
/* have only absolute accuracy. This is most likely to occur */
/* when one component (in magnitude) is larger than the other by */
/* several orders of magnitude. If one component is 10**K larger */
/* than the other, then one can expect only MAX(ABS(LOG10(P))-K, */
/* 0) significant digits; or, stated another way, when K exceeds */
/* the exponent of P, no significant digits remain in the smaller */
/* component. However, the phase angle retains absolute accuracy */
/* because, in complex arithmetic with precision P, the smaller */
/* component will not (as a rule) decrease below P times the */
/* magnitude of the larger component. In these extreme cases, */
/* the principal phase angle is on the order of +P, -P, PI/2-P, */
/* or -PI/2+P. */
/* ***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- */
/* matical Functions, National Bureau of Standards */
/* Applied Mathematics Series 55, U. S. Department */
/* of Commerce, Tenth Printing (1972) or later. */
/* 2. D. E. Amos, Computation of Bessel Functions of */
/* Complex Argument and Large Order, Report SAND83-0643, */
/* Sandia National Laboratories, Albuquerque, NM, May */
/* 1983. */
/* 3. D. E. Amos, A Subroutine Package for Bessel Functions */
/* of a Complex Argument and Nonnegative Order, Report */
/* SAND85-1018, Sandia National Laboratory, Albuquerque, */
/* NM, May 1985. */
/* 4. D. E. Amos, A portable package for Bessel functions */
/* of a complex argument and nonnegative order, ACM */
/* Transactions on Mathematical Software, 12 (September */
/* 1986), pp. 265-273. */
/* ***ROUTINES CALLED CACAI, CBKNU, I1MACH, R1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 830501 DATE WRITTEN */
/* 890801 REVISION DATE from Version 3.2 */
/* 910415 Prologue converted to Version 4.0 format. (BAB) */
/* 920128 Category corrected. (WRB) */
/* 920811 Prologue revised. (DWL) */
/* ***END PROLOGUE CAIRY */
/* ***FIRST EXECUTABLE STATEMENT CAIRY */
*ierr = 0;
*nz = 0;
if (*id < 0 || *id > 1) {
*ierr = 1;
}
if (*kode < 1 || *kode > 2) {
*ierr = 1;
}
if (*ierr != 0) {
return 0;
}
az = c_abs(z__);
/* Computing MAX */
r__1 = r1mach_(&c__4);
tol = dmax(r__1,1e-18f);
fid = (real) (*id);
if (az > 1.f) {
goto L60;
}
/* ----------------------------------------------------------------------- */
/* POWER SERIES FOR ABS(Z).LE.1. */
/* ----------------------------------------------------------------------- */
s1.r = cone.r, s1.i = cone.i;
s2.r = cone.r, s2.i = cone.i;
if (az < tol) {
goto L160;
}
aa = az * az;
if (aa < tol / az) {
goto L40;
}
trm1.r = cone.r, trm1.i = cone.i;
trm2.r = cone.r, trm2.i = cone.i;
atrm = 1.f;
q__2.r = z__->r * z__->r - z__->i * z__->i, q__2.i = z__->r * z__->i +
z__->i * z__->r;
q__1.r = q__2.r * z__->r - q__2.i * z__->i, q__1.i = q__2.r * z__->i +
q__2.i * z__->r;
z3.r = q__1.r, z3.i = q__1.i;
az3 = az * aa;
ak = fid + 2.f;
bk = 3.f - fid - fid;
ck = 4.f - fid;
dk = fid + 3.f + fid;
d1 = ak * dk;
d2 = bk * ck;
ad = dmin(d1,d2);
ak = fid * 9.f + 24.f;
bk = 30.f - fid * 9.f;
z3r = z3.r;
z3i = r_imag(&z3);
for (k = 1; k <= 25; ++k) {
r__1 = z3r / d1;
r__2 = z3i / d1;
q__2.r = r__1, q__2.i = r__2;
q__1.r = trm1.r * q__2.r - trm1.i * q__2.i, q__1.i = trm1.r * q__2.i
+ trm1.i * q__2.r;
trm1.r = q__1.r, trm1.i = q__1.i;
q__1.r = s1.r + trm1.r, q__1.i = s1.i + trm1.i;
s1.r = q__1.r, s1.i = q__1.i;
r__1 = z3r / d2;
r__2 = z3i / d2;
q__2.r = r__1, q__2.i = r__2;
q__1.r = trm2.r * q__2.r - trm2.i * q__2.i, q__1.i = trm2.r * q__2.i
+ trm2.i * q__2.r;
trm2.r = q__1.r, trm2.i = q__1.i;
q__1.r = s2.r + trm2.r, q__1.i = s2.i + trm2.i;
s2.r = q__1.r, s2.i = q__1.i;
atrm = atrm * az3 / ad;
d1 += ak;
d2 += bk;
ad = dmin(d1,d2);
if (atrm < tol * ad) {
goto L40;
}
ak += 18.f;
bk += 18.f;
/* L30: */
}
L40:
if (*id == 1) {
goto L50;
}
q__3.r = c1, q__3.i = 0.f;
q__2.r = s1.r * q__3.r - s1.i * q__3.i, q__2.i = s1.r * q__3.i + s1.i *
q__3.r;
q__5.r = z__->r * s2.r - z__->i * s2.i, q__5.i = z__->r * s2.i + z__->i *
s2.r;
q__6.r = c2, q__6.i = 0.f;
q__4.r = q__5.r * q__6.r - q__5.i * q__6.i, q__4.i = q__5.r * q__6.i +
q__5.i * q__6.r;
q__1.r = q__2.r - q__4.r, q__1.i = q__2.i - q__4.i;
ai->r = q__1.r, ai->i = q__1.i;
if (*kode == 1) {
return 0;
}
c_sqrt(&q__3, z__);
q__2.r = z__->r * q__3.r - z__->i * q__3.i, q__2.i = z__->r * q__3.i +
z__->i * q__3.r;
q__4.r = tth, q__4.i = 0.f;
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i +
q__2.i * q__4.r;
zta.r = q__1.r, zta.i = q__1.i;
c_exp(&q__2, &zta);
q__1.r = ai->r * q__2.r - ai->i * q__2.i, q__1.i = ai->r * q__2.i + ai->i
* q__2.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L50:
q__2.r = -s2.r, q__2.i = -s2.i;
q__3.r = c2, q__3.i = 0.f;
q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i +
q__2.i * q__3.r;
ai->r = q__1.r, ai->i = q__1.i;
if (az > tol) {
q__4.r = z__->r * z__->r - z__->i * z__->i, q__4.i = z__->r * z__->i
+ z__->i * z__->r;
q__3.r = q__4.r * s1.r - q__4.i * s1.i, q__3.i = q__4.r * s1.i +
q__4.i * s1.r;
r__1 = c1 / (fid + 1.f);
q__5.r = r__1, q__5.i = 0.f;
q__2.r = q__3.r * q__5.r - q__3.i * q__5.i, q__2.i = q__3.r * q__5.i
+ q__3.i * q__5.r;
q__1.r = ai->r + q__2.r, q__1.i = ai->i + q__2.i;
ai->r = q__1.r, ai->i = q__1.i;
}
if (*kode == 1) {
return 0;
}
c_sqrt(&q__3, z__);
q__2.r = z__->r * q__3.r - z__->i * q__3.i, q__2.i = z__->r * q__3.i +
z__->i * q__3.r;
q__4.r = tth, q__4.i = 0.f;
q__1.r = q__2.r * q__4.r - q__2.i * q__4.i, q__1.i = q__2.r * q__4.i +
q__2.i * q__4.r;
zta.r = q__1.r, zta.i = q__1.i;
c_exp(&q__2, &zta);
q__1.r = ai->r * q__2.r - ai->i * q__2.i, q__1.i = ai->r * q__2.i + ai->i
* q__2.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
/* ----------------------------------------------------------------------- */
/* CASE FOR ABS(Z).GT.1.0 */
/* ----------------------------------------------------------------------- */
L60:
fnu = (fid + 1.f) / 3.f;
/* ----------------------------------------------------------------------- */
/* SET PARAMETERS RELATED TO MACHINE CONSTANTS. */
/* TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. */
/* ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. */
/* EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND */
/* EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR */
/* UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. */
/* RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. */
/* DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). */
/* ----------------------------------------------------------------------- */
k1 = i1mach_(&c__12);
k2 = i1mach_(&c__13);
r1m5 = r1mach_(&c__5);
/* Computing MIN */
i__1 = abs(k1), i__2 = abs(k2);
k = min(i__1,i__2);
elim = (k * r1m5 - 3.f) * 2.303f;
k1 = i1mach_(&c__11) - 1;
aa = r1m5 * k1;
dig = dmin(aa,18.f);
aa *= 2.303f;
/* Computing MAX */
r__1 = -aa;
alim = elim + dmax(r__1,-41.45f);
rl = dig * 1.2f + 3.f;
alaz = log(az);
/* ----------------------------------------------------------------------- */
/* TEST FOR RANGE */
/* ----------------------------------------------------------------------- */
aa = .5f / tol;
bb = i1mach_(&c__9) * .5f;
aa = dmin(aa,bb);
d__1 = (doublereal) aa;
d__2 = (doublereal) tth;
aa = pow_dd(&d__1, &d__2);
if (az > aa) {
goto L260;
}
aa = sqrt(aa);
if (az > aa) {
*ierr = 3;
}
c_sqrt(&q__1, z__);
csq.r = q__1.r, csq.i = q__1.i;
q__2.r = z__->r * csq.r - z__->i * csq.i, q__2.i = z__->r * csq.i +
z__->i * csq.r;
q__3.r = tth, q__3.i = 0.f;
q__1.r = q__2.r * q__3.r - q__2.i * q__3.i, q__1.i = q__2.r * q__3.i +
q__2.i * q__3.r;
zta.r = q__1.r, zta.i = q__1.i;
/* ----------------------------------------------------------------------- */
/* RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL */
/* ----------------------------------------------------------------------- */
iflag = 0;
sfac = 1.f;
zi = r_imag(z__);
zr = z__->r;
ak = r_imag(&zta);
if (zr >= 0.f) {
goto L70;
}
bk = zta.r;
ck = -dabs(bk);
q__1.r = ck, q__1.i = ak;
zta.r = q__1.r, zta.i = q__1.i;
L70:
if (zi != 0.f) {
goto L80;
}
if (zr > 0.f) {
goto L80;
}
q__1.r = 0.f, q__1.i = ak;
zta.r = q__1.r, zta.i = q__1.i;
L80:
aa = zta.r;
if (aa >= 0.f && zr > 0.f) {
goto L100;
}
if (*kode == 2) {
goto L90;
}
/* ----------------------------------------------------------------------- */
/* OVERFLOW TEST */
/* ----------------------------------------------------------------------- */
if (aa > -alim) {
goto L90;
}
aa = -aa + alaz * .25f;
iflag = 1;
sfac = tol;
if (aa > elim) {
goto L240;
}
L90:
/* ----------------------------------------------------------------------- */
/* CBKNU AND CACAI RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2 */
/* ----------------------------------------------------------------------- */
mr = 1;
if (zi < 0.f) {
mr = -1;
}
cacai_(&zta, &fnu, kode, &mr, &c__1, cy, &nn, &rl, &tol, &elim, &alim);
if (nn < 0) {
goto L250;
}
*nz += nn;
goto L120;
L100:
if (*kode == 2) {
goto L110;
}
/* ----------------------------------------------------------------------- */
/* UNDERFLOW TEST */
/* ----------------------------------------------------------------------- */
if (aa < alim) {
goto L110;
}
aa = -aa - alaz * .25f;
iflag = 2;
sfac = 1.f / tol;
if (aa < -elim) {
goto L180;
}
L110:
cbknu_(&zta, &fnu, kode, &c__1, cy, nz, &tol, &elim, &alim);
L120:
q__2.r = coef, q__2.i = 0.f;
q__1.r = cy[0].r * q__2.r - cy[0].i * q__2.i, q__1.i = cy[0].r * q__2.i +
cy[0].i * q__2.r;
s1.r = q__1.r, s1.i = q__1.i;
if (iflag != 0) {
goto L140;
}
if (*id == 1) {
goto L130;
}
q__1.r = csq.r * s1.r - csq.i * s1.i, q__1.i = csq.r * s1.i + csq.i *
s1.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L130:
q__2.r = -z__->r, q__2.i = -z__->i;
q__1.r = q__2.r * s1.r - q__2.i * s1.i, q__1.i = q__2.r * s1.i + q__2.i *
s1.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L140:
q__2.r = sfac, q__2.i = 0.f;
q__1.r = s1.r * q__2.r - s1.i * q__2.i, q__1.i = s1.r * q__2.i + s1.i *
q__2.r;
s1.r = q__1.r, s1.i = q__1.i;
if (*id == 1) {
goto L150;
}
q__1.r = s1.r * csq.r - s1.i * csq.i, q__1.i = s1.r * csq.i + s1.i *
csq.r;
s1.r = q__1.r, s1.i = q__1.i;
r__1 = 1.f / sfac;
q__2.r = r__1, q__2.i = 0.f;
q__1.r = s1.r * q__2.r - s1.i * q__2.i, q__1.i = s1.r * q__2.i + s1.i *
q__2.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L150:
q__2.r = -s1.r, q__2.i = -s1.i;
q__1.r = q__2.r * z__->r - q__2.i * z__->i, q__1.i = q__2.r * z__->i +
q__2.i * z__->r;
s1.r = q__1.r, s1.i = q__1.i;
r__1 = 1.f / sfac;
q__2.r = r__1, q__2.i = 0.f;
q__1.r = s1.r * q__2.r - s1.i * q__2.i, q__1.i = s1.r * q__2.i + s1.i *
q__2.r;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L160:
aa = r1mach_(&c__1) * 1e3f;
s1.r = 0.f, s1.i = 0.f;
if (*id == 1) {
goto L170;
}
if (az > aa) {
q__2.r = c2, q__2.i = 0.f;
q__1.r = q__2.r * z__->r - q__2.i * z__->i, q__1.i = q__2.r * z__->i
+ q__2.i * z__->r;
s1.r = q__1.r, s1.i = q__1.i;
}
q__2.r = c1, q__2.i = 0.f;
q__1.r = q__2.r - s1.r, q__1.i = q__2.i - s1.i;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L170:
q__2.r = c2, q__2.i = 0.f;
q__1.r = -q__2.r, q__1.i = -q__2.i;
ai->r = q__1.r, ai->i = q__1.i;
aa = sqrt(aa);
if (az > aa) {
q__2.r = z__->r * z__->r - z__->i * z__->i, q__2.i = z__->r * z__->i
+ z__->i * z__->r;
q__1.r = q__2.r * .5f - q__2.i * 0.f, q__1.i = q__2.r * 0.f + q__2.i *
.5f;
s1.r = q__1.r, s1.i = q__1.i;
}
q__3.r = c1, q__3.i = 0.f;
q__2.r = s1.r * q__3.r - s1.i * q__3.i, q__2.i = s1.r * q__3.i + s1.i *
q__3.r;
q__1.r = ai->r + q__2.r, q__1.i = ai->i + q__2.i;
ai->r = q__1.r, ai->i = q__1.i;
return 0;
L180:
*nz = 1;
ai->r = 0.f, ai->i = 0.f;
return 0;
L240:
*nz = 0;
*ierr = 2;
return 0;
L250:
if (nn == -1) {
goto L240;
}
*nz = 0;
*ierr = 5;
return 0;
L260:
*ierr = 4;
*nz = 0;
return 0;
} /* cairy_ */
/* DECK BESJ */
/* Subroutine */ int besj_(real *x, real *alpha, integer *n, real *y, integer
*nz)
{
/* Initialized data */
static real rtwo = 1.34839972492648f;
static real pdf = .785398163397448f;
static real rttp = .797884560802865f;
static real pidt = 1.5707963267949f;
static real pp[4] = { 8.72909153935547f,.26569393226503f,
.124578576865586f,7.70133747430388e-4f };
static integer inlim = 150;
static real fnulim[2] = { 100.f,60.f };
/* System generated locals */
integer i__1;
real r__1;
/* Local variables */
static integer i__, k;
static real s, t;
static integer i1, i2;
static real s1, s2, t1, t2, ak, ap, fn, sa;
static integer kk, in, km;
static real sb, ta, tb;
static integer is, nn, kt, ns;
static real tm, wk[7], tx, xo2, dfn, akm, arg, fnf, fni, gln, ans, dtm,
tfn, fnu, tau, tol, etx, rtx, trx, fnp1, xo2l, sxo2, coef, earg,
relb;
static integer ialp;
static real rden;
static integer iflw;
static real slim, temp[3], rtol, elim1, fidal;
static integer idalp;
static real flgjy;
extern /* Subroutine */ int jairy_();
static real rzden, tolln;
extern /* Subroutine */ int asyjy_(U_fp, real *, real *, real *, integer *
, real *, real *, integer *);
extern integer i1mach_(integer *);
extern doublereal r1mach_(integer *);
static real dalpha;
extern doublereal alngam_(real *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE BESJ */
/* ***PURPOSE Compute an N member sequence of J Bessel functions */
/* J/SUB(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA */
/* and X. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C10A3 */
/* ***TYPE SINGLE PRECISION (BESJ-S, DBESJ-D) */
/* ***KEYWORDS J BESSEL FUNCTION, SPECIAL FUNCTIONS */
/* ***AUTHOR Amos, D. E., (SNLA) */
/* Daniel, S. L., (SNLA) */
/* Weston, M. K., (SNLA) */
/* ***DESCRIPTION */
/* Abstract */
/* BESJ computes an N member sequence of J Bessel functions */
/* J/sub(ALPHA+K-1)/(X), K=1,...,N for non-negative ALPHA and X. */
/* A combination of the power series, the asymptotic expansion */
/* for X to infinity and the uniform asymptotic expansion for */
/* NU to infinity are applied over subdivisions of the (NU,X) */
/* plane. For values of (NU,X) not covered by one of these */
/* formulae, the order is incremented or decremented by integer */
/* values into a region where one of the formulae apply. Backward */
/* recursion is applied to reduce orders by integer values except */
/* where the entire sequence lies in the oscillatory region. In */
/* this case forward recursion is stable and values from the */
/* asymptotic expansion for X to infinity start the recursion */
/* when it is efficient to do so. Leading terms of the series */
/* and uniform expansion are tested for underflow. If a sequence */
/* is requested and the last member would underflow, the result */
/* is set to zero and the next lower order tried, etc., until a */
/* member comes on scale or all members are set to zero. */
/* Overflow cannot occur. */
/* Description of Arguments */
/* Input */
/* X - X .GE. 0.0E0 */
/* ALPHA - order of first member of the sequence, */
/* ALPHA .GE. 0.0E0 */
/* N - number of members in the sequence, N .GE. 1 */
/* Output */
/* Y - a vector whose first N components contain */
/* values for J/sub(ALPHA+K-1)/(X), K=1,...,N */
/* NZ - number of components of Y set to zero due to */
/* underflow, */
/* NZ=0 , normal return, computation completed */
/* NZ .NE. 0, last NZ components of Y set to zero, */
/* Y(K)=0.0E0, K=N-NZ+1,...,N. */
/* Error Conditions */
/* Improper input arguments - a fatal error */
/* Underflow - a non-fatal error (NZ .NE. 0) */
/* ***REFERENCES D. E. Amos, S. L. Daniel and M. K. Weston, CDC 6600 */
/* subroutines IBESS and JBESS for Bessel functions */
/* I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0, ACM */
/* Transactions on Mathematical Software 3, (1977), */
/* pp. 76-92. */
/* F. W. J. Olver, Tables of Bessel Functions of Moderate */
/* or Large Orders, NPL Mathematical Tables 6, Her */
/* Majesty's Stationery Office, London, 1962. */
/* ***ROUTINES CALLED ALNGAM, ASYJY, I1MACH, JAIRY, R1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 750101 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) */
/* 900326 Removed duplicate information from DESCRIPTION section. */
/* (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE BESJ */
/* Parameter adjustments */
--y;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT BESJ */
*nz = 0;
kt = 1;
ns = 0;
/* I1MACH(14) REPLACES I1MACH(11) IN A DOUBLE PRECISION CODE */
/* I1MACH(15) REPLACES I1MACH(12) IN A DOUBLE PRECISION CODE */
ta = r1mach_(&c__3);
tol = dmax(ta,1e-15f);
i1 = i1mach_(&c__11) + 1;
i2 = i1mach_(&c__12);
tb = r1mach_(&c__5);
elim1 = (i2 * tb + 3.f) * -2.303f;
rtol = 1.f / tol;
slim = r1mach_(&c__1) * 1e3f * rtol;
/* TOLLN = -LN(TOL) */
tolln = tb * 2.303f * i1;
tolln = dmin(tolln,34.5388f);
if ((i__1 = *n - 1) < 0) {
goto L720;
} else if (i__1 == 0) {
goto L10;
} else {
goto L20;
}
L10:
kt = 2;
L20:
nn = *n;
if (*x < 0.f) {
goto L730;
} else if (*x == 0) {
goto L30;
} else {
goto L80;
}
L30:
if (*alpha < 0.f) {
goto L710;
} else if (*alpha == 0) {
goto L40;
} else {
goto L50;
}
L40:
y[1] = 1.f;
if (*n == 1) {
return 0;
}
i1 = 2;
goto L60;
L50:
i1 = 1;
L60:
i__1 = *n;
for (i__ = i1; i__ <= i__1; ++i__) {
y[i__] = 0.f;
/* L70: */
}
return 0;
L80:
if (*alpha < 0.f) {
goto L710;
}
ialp = (integer) (*alpha);
fni = (real) (ialp + *n - 1);
fnf = *alpha - ialp;
dfn = fni + fnf;
fnu = dfn;
xo2 = *x * .5f;
sxo2 = xo2 * xo2;
/* DECISION TREE FOR REGION WHERE SERIES, ASYMPTOTIC EXPANSION FOR X */
/* TO INFINITY AND ASYMPTOTIC EXPANSION FOR NU TO INFINITY ARE */
/* APPLIED. */
if (sxo2 <= fnu + 1.f) {
goto L90;
}
ta = dmax(20.f,fnu);
if (*x > ta) {
goto L120;
}
if (*x > 12.f) {
goto L110;
}
xo2l = log(xo2);
ns = (integer) (sxo2 - fnu) + 1;
goto L100;
L90:
fn = fnu;
fnp1 = fn + 1.f;
xo2l = log(xo2);
is = kt;
if (*x <= .5f) {
goto L330;
}
ns = 0;
L100:
fni += ns;
dfn = fni + fnf;
fn = dfn;
fnp1 = fn + 1.f;
is = kt;
if (*n - 1 + ns > 0) {
is = 3;
}
goto L330;
L110:
/* Computing MAX */
r__1 = 36.f - fnu;
ans = dmax(r__1,0.f);
ns = (integer) ans;
fni += ns;
dfn = fni + fnf;
fn = dfn;
is = kt;
if (*n - 1 + ns > 0) {
is = 3;
}
goto L130;
L120:
rtx = sqrt(*x);
tau = rtwo * rtx;
ta = tau + fnulim[kt - 1];
if (fnu <= ta) {
goto L480;
}
fn = fnu;
is = kt;
/* UNIFORM ASYMPTOTIC EXPANSION FOR NU TO INFINITY */
L130:
i1 = (i__1 = 3 - is, abs(i__1));
i1 = max(i1,1);
flgjy = 1.f;
asyjy_((U_fp)jairy_, x, &fn, &flgjy, &i1, &temp[is - 1], wk, &iflw);
if (iflw != 0) {
goto L380;
}
switch (is) {
case 1: goto L320;
case 2: goto L450;
case 3: goto L620;
}
L310:
temp[0] = temp[2];
kt = 1;
L320:
is = 2;
fni += -1.f;
dfn = fni + fnf;
fn = dfn;
if (i1 == 2) {
goto L450;
}
goto L130;
/* SERIES FOR (X/2)**2.LE.NU+1 */
L330:
gln = alngam_(&fnp1);
arg = fn * xo2l - gln;
if (arg < -elim1) {
goto L400;
}
earg = exp(arg);
L340:
s = 1.f;
if (*x < tol) {
goto L360;
}
ak = 3.f;
t2 = 1.f;
t = 1.f;
s1 = fn;
for (k = 1; k <= 17; ++k) {
s2 = t2 + s1;
t = -t * sxo2 / s2;
s += t;
if (dabs(t) < tol) {
goto L360;
}
t2 += ak;
ak += 2.f;
s1 += fn;
/* L350: */
}
L360:
temp[is - 1] = s * earg;
switch (is) {
case 1: goto L370;
case 2: goto L450;
case 3: goto L610;
}
L370:
earg = earg * fn / xo2;
fni += -1.f;
dfn = fni + fnf;
fn = dfn;
is = 2;
goto L340;
/* SET UNDERFLOW VALUE AND UPDATE PARAMETERS */
/* UNDERFLOW CAN ONLY OCCUR FOR NS=0 SINCE THE ORDER MUST BE */
/* LARGER THAN 36. THEREFORE, NS NEED NOT BE CONSIDERED. */
L380:
y[nn] = 0.f;
--nn;
fni += -1.f;
dfn = fni + fnf;
fn = dfn;
if ((i__1 = nn - 1) < 0) {
goto L440;
} else if (i__1 == 0) {
goto L390;
} else {
goto L130;
}
L390:
kt = 2;
is = 2;
goto L130;
L400:
y[nn] = 0.f;
--nn;
fnp1 = fn;
fni += -1.f;
dfn = fni + fnf;
fn = dfn;
if ((i__1 = nn - 1) < 0) {
goto L440;
} else if (i__1 == 0) {
goto L410;
} else {
goto L420;
}
L410:
kt = 2;
is = 2;
L420:
if (sxo2 <= fnp1) {
goto L430;
}
goto L130;
L430:
arg = arg - xo2l + log(fnp1);
if (arg < -elim1) {
goto L400;
}
goto L330;
L440:
*nz = *n - nn;
return 0;
/* BACKWARD RECURSION SECTION */
L450:
if (ns != 0) {
goto L451;
}
*nz = *n - nn;
if (kt == 2) {
goto L470;
}
/* BACKWARD RECUR FROM INDEX ALPHA+NN-1 TO ALPHA */
y[nn] = temp[0];
y[nn - 1] = temp[1];
if (nn == 2) {
return 0;
}
L451:
trx = 2.f / *x;
dtm = fni;
tm = (dtm + fnf) * trx;
ak = 1.f;
ta = temp[0];
tb = temp[1];
if (dabs(ta) > slim) {
goto L455;
}
ta *= rtol;
tb *= rtol;
ak = tol;
L455:
kk = 2;
in = ns - 1;
if (in == 0) {
goto L690;
}
if (ns != 0) {
goto L670;
}
k = nn - 2;
i__1 = nn;
for (i__ = 3; i__ <= i__1; ++i__) {
s = tb;
tb = tm * tb - ta;
ta = s;
y[k] = tb * ak;
--k;
dtm += -1.f;
tm = (dtm + fnf) * trx;
/* L460: */
}
return 0;
L470:
y[1] = temp[1];
return 0;
/* ASYMPTOTIC EXPANSION FOR X TO INFINITY WITH FORWARD RECURSION IN */
/* OSCILLATORY REGION X.GT.MAX(20, NU), PROVIDED THE LAST MEMBER */
/* OF THE SEQUENCE IS ALSO IN THE REGION. */
L480:
in = (integer) (*alpha - tau + 2.f);
if (in <= 0) {
goto L490;
}
idalp = ialp - in - 1;
kt = 1;
goto L500;
L490:
idalp = ialp;
in = 0;
L500:
is = kt;
fidal = (real) idalp;
dalpha = fidal + fnf;
arg = *x - pidt * dalpha - pdf;
sa = sin(arg);
sb = cos(arg);
coef = rttp / rtx;
etx = *x * 8.f;
L510:
dtm = fidal + fidal;
dtm *= dtm;
tm = 0.f;
if (fidal == 0.f && dabs(fnf) < tol) {
goto L520;
}
tm = fnf * 4.f * (fidal + fidal + fnf);
L520:
trx = dtm - 1.f;
t2 = (trx + tm) / etx;
s2 = t2;
relb = tol * dabs(t2);
t1 = etx;
s1 = 1.f;
fn = 1.f;
ak = 8.f;
for (k = 1; k <= 13; ++k) {
t1 += etx;
fn += ak;
trx = dtm - fn;
ap = trx + tm;
t2 = -t2 * ap / t1;
s1 += t2;
t1 += etx;
ak += 8.f;
fn += ak;
trx = dtm - fn;
ap = trx + tm;
t2 = t2 * ap / t1;
s2 += t2;
if (dabs(t2) <= relb) {
goto L540;
}
ak += 8.f;
/* L530: */
}
L540:
temp[is - 1] = coef * (s1 * sb - s2 * sa);
if (is == 2) {
goto L560;
}
fidal += 1.f;
dalpha = fidal + fnf;
is = 2;
tb = sa;
sa = -sb;
sb = tb;
goto L510;
/* FORWARD RECURSION SECTION */
L560:
if (kt == 2) {
goto L470;
}
s1 = temp[0];
s2 = temp[1];
tx = 2.f / *x;
tm = dalpha * tx;
if (in == 0) {
goto L580;
}
/* FORWARD RECUR TO INDEX ALPHA */
i__1 = in;
for (i__ = 1; i__ <= i__1; ++i__) {
s = s2;
s2 = tm * s2 - s1;
tm += tx;
s1 = s;
/* L570: */
}
if (nn == 1) {
goto L600;
}
s = s2;
s2 = tm * s2 - s1;
tm += tx;
s1 = s;
L580:
/* FORWARD RECUR FROM INDEX ALPHA TO ALPHA+N-1 */
y[1] = s1;
y[2] = s2;
if (nn == 2) {
return 0;
}
i__1 = nn;
for (i__ = 3; i__ <= i__1; ++i__) {
y[i__] = tm * y[i__ - 1] - y[i__ - 2];
tm += tx;
/* L590: */
}
return 0;
L600:
y[1] = s2;
return 0;
/* BACKWARD RECURSION WITH NORMALIZATION BY */
/* ASYMPTOTIC EXPANSION FOR NU TO INFINITY OR POWER SERIES. */
L610:
/* COMPUTATION OF LAST ORDER FOR SERIES NORMALIZATION */
/* Computing MAX */
r__1 = 3.f - fn;
akm = dmax(r__1,0.f);
km = (integer) akm;
tfn = fn + km;
ta = (gln + tfn - .9189385332f - .0833333333f / tfn) / (tfn + .5f);
ta = xo2l - ta;
tb = -(1.f - 1.5f / tfn) / tfn;
akm = tolln / (-ta + sqrt(ta * ta - tolln * tb)) + 1.5f;
in = km + (integer) akm;
goto L660;
L620:
/* COMPUTATION OF LAST ORDER FOR ASYMPTOTIC EXPANSION NORMALIZATION */
gln = wk[2] + wk[1];
if (wk[5] > 30.f) {
goto L640;
}
rden = (pp[3] * wk[5] + pp[2]) * wk[5] + 1.f;
rzden = pp[0] + pp[1] * wk[5];
ta = rzden / rden;
if (wk[0] < .1f) {
goto L630;
}
tb = gln / wk[4];
goto L650;
L630:
tb = ((wk[0] * .0887944358f + .167989473f) * wk[0] + 1.259921049f) / wk[6]
;
goto L650;
L640:
ta = tolln * .5f / wk[3];
ta = ((ta * .049382716f - .1111111111f) * ta + .6666666667f) * ta * wk[5];
if (wk[0] < .1f) {
goto L630;
}
tb = gln / wk[4];
L650:
in = (integer) (ta / tb + 1.5f);
if (in > inlim) {
goto L310;
}
L660:
dtm = fni + in;
trx = 2.f / *x;
tm = (dtm + fnf) * trx;
ta = 0.f;
tb = tol;
kk = 1;
ak = 1.f;
L670:
/* BACKWARD RECUR UNINDEXED AND SCALE WHEN MAGNITUDES ARE CLOSE TO */
/* UNDERFLOW LIMITS (LESS THAN SLIM=R1MACH(1)*1.0E+3/TOL) */
i__1 = in;
for (i__ = 1; i__ <= i__1; ++i__) {
s = tb;
tb = tm * tb - ta;
ta = s;
dtm += -1.f;
tm = (dtm + fnf) * trx;
/* L680: */
}
/* NORMALIZATION */
if (kk != 1) {
goto L690;
}
s = temp[2];
sa = ta / tb;
ta = s;
tb = s;
if (dabs(s) > slim) {
goto L685;
}
ta *= rtol;
tb *= rtol;
ak = tol;
L685:
ta *= sa;
kk = 2;
in = ns;
if (ns != 0) {
goto L670;
}
L690:
y[nn] = tb * ak;
*nz = *n - nn;
if (nn == 1) {
return 0;
}
k = nn - 1;
s = tb;
tb = tm * tb - ta;
ta = s;
y[k] = tb * ak;
if (nn == 2) {
return 0;
}
dtm += -1.f;
tm = (dtm + fnf) * trx;
k = nn - 2;
/* BACKWARD RECUR INDEXED */
i__1 = nn;
for (i__ = 3; i__ <= i__1; ++i__) {
s = tb;
tb = tm * tb - ta;
ta = s;
y[k] = tb * ak;
dtm += -1.f;
tm = (dtm + fnf) * trx;
--k;
/* L700: */
}
return 0;
L710:
xermsg_("SLATEC", "BESJ", "ORDER, ALPHA, LESS THAN ZERO.", &c__2, &c__1, (
ftnlen)6, (ftnlen)4, (ftnlen)29);
return 0;
L720:
xermsg_("SLATEC", "BESJ", "N LESS THAN ONE.", &c__2, &c__1, (ftnlen)6, (
ftnlen)4, (ftnlen)16);
return 0;
L730:
xermsg_("SLATEC", "BESJ", "X LESS THAN ZERO.", &c__2, &c__1, (ftnlen)6, (
ftnlen)4, (ftnlen)17);
return 0;
} /* besj_ */
/* DECK PSIFN */
/* Subroutine */ int psifn_(real *x, integer *n, integer *kode, integer *m,
real *ans, integer *nz, integer *ierr)
{
/* Initialized data */
static integer nmax = 100;
static real b[22] = { 1.f,-.5f,.166666666666666667f,
-.0333333333333333333f,.0238095238095238095f,
-.0333333333333333333f,.0757575757575757576f,
-.253113553113553114f,1.16666666666666667f,-7.09215686274509804f,
54.9711779448621554f,-529.124242424242424f,6192.1231884057971f,
-86580.2531135531136f,1425517.16666666667f,-27298231.067816092f,
601580873.900642368f,-15116315767.0921569f,429614643061.166667f,
-13711655205088.3328f,488332318973593.167f,-19296579341940068.1f }
;
/* System generated locals */
integer i__1, i__2;
real r__1, r__2;
/* Local variables */
static integer i__, j, k;
static real s, t, t1, t2, fn, ta;
static integer mm, nn, np;
static real fx, tk;
static integer mx, nx;
static real xm, tt, xq, den, arg, fln, fnp, r1m4, r1m5, fns, eps, rln,
tol, xln, trm[22], tss, tst, elim, xinc, xmin, tols, xdmy, yint,
trmr[100], rxsq, slope, xdmln, wdtol;
extern integer i1mach_(integer *);
extern doublereal r1mach_(integer *);
/* ***BEGIN PROLOGUE PSIFN */
/* ***PURPOSE Compute derivatives of the Psi function. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C7C */
/* ***TYPE SINGLE PRECISION (PSIFN-S, DPSIFN-D) */
/* ***KEYWORDS DERIVATIVES OF THE GAMMA FUNCTION, POLYGAMMA FUNCTION, */
/* PSI FUNCTION */
/* ***AUTHOR Amos, D. E., (SNLA) */
/* ***DESCRIPTION */
/* The following definitions are used in PSIFN: */
/* Definition 1 */
/* PSI(X) = d/dx (ln(GAMMA(X)), the first derivative of */
/* the LOG GAMMA function. */
/* Definition 2 */
/* K K */
/* PSI(K,X) = d /dx (PSI(X)), the K-th derivative of PSI(X). */
/* ___________________________________________________________________ */
/* PSIFN computes a sequence of SCALED derivatives of */
/* the PSI function; i.e. for fixed X and M it computes */
/* the M-member sequence */
/* ((-1)**(K+1)/GAMMA(K+1))*PSI(K,X) */
/* for K = N,...,N+M-1 */
/* where PSI(K,X) is as defined above. For KODE=1, PSIFN returns */
/* the scaled derivatives as described. KODE=2 is operative only */
/* when K=0 and in that case PSIFN returns -PSI(X) + LN(X). That */
/* is, the logarithmic behavior for large X is removed when KODE=1 */
/* and K=0. When sums or differences of PSI functions are computed */
/* the logarithmic terms can be combined analytically and computed */
/* separately to help retain significant digits. */
/* Note that CALL PSIFN(X,0,1,1,ANS) results in */
/* ANS = -PSI(X) */
/* Input */
/* X - Argument, X .gt. 0.0E0 */
/* N - First member of the sequence, 0 .le. N .le. 100 */
/* N=0 gives ANS(1) = -PSI(X) for KODE=1 */
/* -PSI(X)+LN(X) for KODE=2 */
/* KODE - Selection parameter */
/* KODE=1 returns scaled derivatives of the PSI */
/* function. */
/* KODE=2 returns scaled derivatives of the PSI */
/* function EXCEPT when N=0. In this case, */
/* ANS(1) = -PSI(X) + LN(X) is returned. */
/* M - Number of members of the sequence, M .ge. 1 */
/* Output */
/* ANS - A vector of length at least M whose first M */
/* components contain the sequence of derivatives */
/* scaled according to KODE. */
/* NZ - Underflow flag */
/* NZ.eq.0, A normal return */
/* NZ.ne.0, Underflow, last NZ components of ANS are */
/* set to zero, ANS(M-K+1)=0.0, K=1,...,NZ */
/* IERR - Error flag */
/* IERR=0, A normal return, computation completed */
/* IERR=1, Input error, no computation */
/* IERR=2, Overflow, X too small or N+M-1 too */
/* large or both */
/* IERR=3, Error, N too large. Dimensioned */
/* array TRMR(NMAX) is not large enough for N */
/* The nominal computational accuracy is the maximum of unit */
/* roundoff (=R1MACH(4)) and 1.0E-18 since critical constants */
/* are given to only 18 digits. */
/* DPSIFN is the Double Precision version of PSIFN. */
/* *Long Description: */
/* The basic method of evaluation is the asymptotic expansion */
/* for large X.ge.XMIN followed by backward recursion on a two */
/* term recursion relation */
/* W(X+1) + X**(-N-1) = W(X). */
/* This is supplemented by a series */
/* SUM( (X+K)**(-N-1) , K=0,1,2,... ) */
/* which converges rapidly for large N. Both XMIN and the */
/* number of terms of the series are calculated from the unit */
/* roundoff of the machine environment. */
/* ***REFERENCES Handbook of Mathematical Functions, National Bureau */
/* of Standards Applied Mathematics Series 55, edited */
/* by M. Abramowitz and I. A. Stegun, equations 6.3.5, */
/* 6.3.18, 6.4.6, 6.4.9 and 6.4.10, pp.258-260, 1964. */
/* D. E. Amos, A portable Fortran subroutine for */
/* derivatives of the Psi function, Algorithm 610, ACM */
/* Transactions on Mathematical Software 9, 4 (1983), */
/* pp. 494-502. */
/* ***ROUTINES CALLED I1MACH, R1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 820601 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) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE PSIFN */
/* Parameter adjustments */
--ans;
/* Function Body */
/* ----------------------------------------------------------------------- */
/* BERNOULLI NUMBERS */
/* ----------------------------------------------------------------------- */
/* ***FIRST EXECUTABLE STATEMENT PSIFN */
*ierr = 0;
*nz = 0;
if (*x <= 0.f) {
*ierr = 1;
}
if (*n < 0) {
*ierr = 1;
}
if (*kode < 1 || *kode > 2) {
*ierr = 1;
}
if (*m < 1) {
*ierr = 1;
}
if (*ierr != 0) {
return 0;
}
mm = *m;
/* Computing MIN */
i__1 = -i1mach_(&c__12), i__2 = i1mach_(&c__13);
nx = min(i__1,i__2);
r1m5 = r1mach_(&c__5);
r1m4 = r1mach_(&c__4) * .5f;
wdtol = dmax(r1m4,5e-19f);
/* ----------------------------------------------------------------------- */
/* ELIM = APPROXIMATE EXPONENTIAL OVER AND UNDERFLOW LIMIT */
/* ----------------------------------------------------------------------- */
elim = (nx * r1m5 - 3.f) * 2.302f;
xln = log(*x);
L41:
nn = *n + mm - 1;
fn = (real) nn;
fnp = fn + 1.f;
t = fnp * xln;
/* ----------------------------------------------------------------------- */
/* OVERFLOW AND UNDERFLOW TEST FOR SMALL AND LARGE X */
/* ----------------------------------------------------------------------- */
if (dabs(t) > elim) {
goto L290;
}
if (*x < wdtol) {
goto L260;
}
/* ----------------------------------------------------------------------- */
/* COMPUTE XMIN AND THE NUMBER OF TERMS OF THE SERIES, FLN+1 */
/* ----------------------------------------------------------------------- */
rln = r1m5 * i1mach_(&c__11);
rln = dmin(rln,18.06f);
fln = dmax(rln,3.f) - 3.f;
yint = fln * .4f + 3.5f;
slope = fln * (fln * 6.038e-4f + .008677f) + .21f;
xm = yint + slope * fn;
mx = (integer) xm + 1;
xmin = (real) mx;
if (*n == 0) {
goto L50;
}
xm = rln * -2.302f - dmin(0.f,xln);
fns = (real) (*n);
arg = xm / fns;
arg = dmin(0.f,arg);
eps = exp(arg);
xm = 1.f - eps;
if (dabs(arg) < .001f) {
xm = -arg;
}
fln = *x * xm / eps;
xm = xmin - *x;
if (xm > 7.f && fln < 15.f) {
goto L200;
}
L50:
xdmy = *x;
xdmln = xln;
xinc = 0.f;
if (*x >= xmin) {
goto L60;
}
nx = (integer) (*x);
xinc = xmin - nx;
xdmy = *x + xinc;
xdmln = log(xdmy);
L60:
/* ----------------------------------------------------------------------- */
/* GENERATE W(N+MM-1,X) BY THE ASYMPTOTIC EXPANSION */
/* ----------------------------------------------------------------------- */
t = fn * xdmln;
t1 = xdmln + xdmln;
t2 = t + xdmln;
/* Computing MAX */
r__1 = dabs(t), r__2 = dabs(t1), r__1 = max(r__1,r__2), r__2 = dabs(t2);
tk = dmax(r__1,r__2);
if (tk > elim) {
goto L380;
}
tss = exp(-t);
tt = .5f / xdmy;
t1 = tt;
tst = wdtol * tt;
if (nn != 0) {
t1 = tt + 1.f / fn;
}
rxsq = 1.f / (xdmy * xdmy);
ta = rxsq * .5f;
t = fnp * ta;
s = t * b[2];
if (dabs(s) < tst) {
goto L80;
}
tk = 2.f;
for (k = 4; k <= 22; ++k) {
t = t * ((tk + fn + 1.f) / (tk + 1.f)) * ((tk + fn) / (tk + 2.f)) *
rxsq;
trm[k - 1] = t * b[k - 1];
if ((r__1 = trm[k - 1], dabs(r__1)) < tst) {
goto L80;
}
s += trm[k - 1];
tk += 2.f;
/* L70: */
}
L80:
s = (s + t1) * tss;
if (xinc == 0.f) {
goto L100;
}
/* ----------------------------------------------------------------------- */
/* BACKWARD RECUR FROM XDMY TO X */
/* ----------------------------------------------------------------------- */
nx = (integer) xinc;
np = nn + 1;
if (nx > nmax) {
goto L390;
}
if (nn == 0) {
goto L160;
}
xm = xinc - 1.f;
fx = *x + xm;
/* ----------------------------------------------------------------------- */
/* THIS LOOP SHOULD NOT BE CHANGED. FX IS ACCURATE WHEN X IS SMALL */
/* ----------------------------------------------------------------------- */
i__1 = nx;
for (i__ = 1; i__ <= i__1; ++i__) {
i__2 = -np;
trmr[i__ - 1] = pow_ri(&fx, &i__2);
s += trmr[i__ - 1];
xm += -1.f;
fx = *x + xm;
/* L90: */
}
L100:
ans[mm] = s;
if (fn == 0.f) {
goto L180;
}
/* ----------------------------------------------------------------------- */
/* GENERATE LOWER DERIVATIVES, J.LT.N+MM-1 */
/* ----------------------------------------------------------------------- */
if (mm == 1) {
return 0;
}
i__1 = mm;
for (j = 2; j <= i__1; ++j) {
fnp = fn;
fn += -1.f;
tss *= xdmy;
t1 = tt;
if (fn != 0.f) {
t1 = tt + 1.f / fn;
}
t = fnp * ta;
s = t * b[2];
if (dabs(s) < tst) {
goto L120;
}
tk = fnp + 3.f;
for (k = 4; k <= 22; ++k) {
trm[k - 1] = trm[k - 1] * fnp / tk;
if ((r__1 = trm[k - 1], dabs(r__1)) < tst) {
goto L120;
}
s += trm[k - 1];
tk += 2.f;
/* L110: */
}
L120:
s = (s + t1) * tss;
if (xinc == 0.f) {
goto L140;
}
if (fn == 0.f) {
goto L160;
}
xm = xinc - 1.f;
fx = *x + xm;
i__2 = nx;
for (i__ = 1; i__ <= i__2; ++i__) {
trmr[i__ - 1] *= fx;
s += trmr[i__ - 1];
xm += -1.f;
fx = *x + xm;
/* L130: */
}
L140:
mx = mm - j + 1;
ans[mx] = s;
if (fn == 0.f) {
goto L180;
}
/* L150: */
}
return 0;
/* ----------------------------------------------------------------------- */
/* RECURSION FOR N = 0 */
/* ----------------------------------------------------------------------- */
L160:
i__1 = nx;
for (i__ = 1; i__ <= i__1; ++i__) {
s += 1.f / (*x + nx - i__);
/* L170: */
}
L180:
if (*kode == 2) {
goto L190;
}
ans[1] = s - xdmln;
return 0;
L190:
if (xdmy == *x) {
return 0;
}
xq = xdmy / *x;
ans[1] = s - log(xq);
return 0;
/* ----------------------------------------------------------------------- */
/* COMPUTE BY SERIES (X+K)**(-(N+1)) , K=0,1,2,... */
/* ----------------------------------------------------------------------- */
L200:
nn = (integer) fln + 1;
np = *n + 1;
t1 = (fns + 1.f) * xln;
t = exp(-t1);
s = t;
den = *x;
i__1 = nn;
for (i__ = 1; i__ <= i__1; ++i__) {
den += 1.f;
i__2 = -np;
trm[i__ - 1] = pow_ri(&den, &i__2);
s += trm[i__ - 1];
/* L210: */
}
ans[1] = s;
if (*n != 0) {
goto L220;
}
if (*kode == 2) {
ans[1] = s + xln;
}
L220:
if (mm == 1) {
return 0;
}
/* ----------------------------------------------------------------------- */
/* GENERATE HIGHER DERIVATIVES, J.GT.N */
/* ----------------------------------------------------------------------- */
tol = wdtol / 5.f;
i__1 = mm;
for (j = 2; j <= i__1; ++j) {
t /= *x;
s = t;
tols = t * tol;
den = *x;
i__2 = nn;
for (i__ = 1; i__ <= i__2; ++i__) {
den += 1.f;
trm[i__ - 1] /= den;
s += trm[i__ - 1];
if (trm[i__ - 1] < tols) {
goto L240;
}
/* L230: */
}
L240:
ans[j] = s;
/* L250: */
}
return 0;
/* ----------------------------------------------------------------------- */
/* SMALL X.LT.UNIT ROUND OFF */
/* ----------------------------------------------------------------------- */
L260:
i__1 = -(*n) - 1;
ans[1] = pow_ri(x, &i__1);
if (mm == 1) {
goto L280;
}
k = 1;
i__1 = mm;
for (i__ = 2; i__ <= i__1; ++i__) {
ans[k + 1] = ans[k] / *x;
++k;
/* L270: */
}
L280:
if (*n != 0) {
return 0;
}
if (*kode == 2) {
ans[1] += xln;
}
return 0;
L290:
if (t > 0.f) {
goto L380;
}
*nz = 0;
*ierr = 2;
return 0;
L380:
++(*nz);
ans[mm] = 0.f;
--mm;
if (mm == 0) {
return 0;
}
goto L41;
L390:
*ierr = 3;
*nz = 0;
return 0;
} /* psifn_ */
/* DECK MPBLAS */
/* Subroutine */ int mpblas_(integer *i1)
{
/* System generated locals */
integer i__1, i__2;
/* Local variables */
extern integer i1mach_(integer *);
static integer mpbexp;
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE MPBLAS */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DQDOTA and DQDOTI */
/* ***LIBRARY SLATEC */
/* ***TYPE ALL (MPBLAS-A) */
/* ***AUTHOR (UNKNOWN) */
/* ***DESCRIPTION */
/* This subroutine is called to set up Brent's 'mp' package */
/* for use by the extended precision inner products from the BLAS. */
/* In the SLATEC library we require the Extended Precision MP number */
/* to have a mantissa twice as long as Double Precision numbers. */
/* The calculation of MPT (and MPMXR which is the actual array size) */
/* in this routine will give 2x (or slightly more) on the machine */
/* that we are running on. The INTEGER array size of 30 was chosen */
/* to be slightly longer than the longest INTEGER array needed on */
/* any machine that we are currently aware of. */
/* ***SEE ALSO DQDOTA, DQDOTI */
/* ***REFERENCES R. P. Brent, A Fortran multiple-precision arithmetic */
/* package, ACM Transactions on Mathematical Software 4, */
/* 1 (March 1978), pp. 57-70. */
/* R. P. Brent, MP, a Fortran multiple-precision arithmetic */
/* package, Algorithm 524, ACM Transactions on Mathema- */
/* tical Software 4, 1 (March 1978), pp. 71-81. */
/* ***ROUTINES CALLED I1MACH, XERMSG */
/* ***COMMON BLOCKS MPCOM */
/* ***REVISION HISTORY (YYMMDD) */
/* 791001 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) */
/* 900402 Added TYPE section. (WRB) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* 930124 Increased Array size in MPCON for SUN -r8, and calculate */
/* size for Quad Precision for 2x DP. (RWC) */
/* ***END PROLOGUE MPBLAS */
/* ***FIRST EXECUTABLE STATEMENT MPBLAS */
*i1 = 1;
/* For full extended precision accuracy, MPB should be as large as */
/* possible, subject to the restrictions in Brent's paper. */
/* Statements below are for an integer wordlength of 48, 36, 32, */
/* 24, 18, and 16. Pick one, or generate a new one. */
/* 48 MPB = 4194304 */
/* 36 MPB = 65536 */
/* 32 MPB = 16384 */
/* 24 MPB = 1024 */
/* 18 MPB = 128 */
/* 16 MPB = 64 */
mpbexp = i1mach_(&c__8) / 2 - 2;
mpcom_1.mpb = pow_ii(&c__2, &mpbexp);
/* Set up remaining parameters */
/* UNIT FOR ERROR MESSAGES */
mpcom_1.mplun = i1mach_(&c__4);
/* NUMBER OF MP DIGITS */
mpcom_1.mpt = ((i1mach_(&c__14) << 1) + mpbexp - 1) / mpbexp;
/* DIMENSION OF R */
mpcom_1.mpmxr = mpcom_1.mpt + 4;
if (mpcom_1.mpmxr > 30) {
xermsg_("SLATEC", "MPBLAS", "Array space not sufficient for Quad Pre"
"cision 2x Double Precision, Proceeding.", &c__1, &c__1, (
ftnlen)6, (ftnlen)6, (ftnlen)78);
mpcom_1.mpt = 26;
mpcom_1.mpmxr = 30;
}
/* EXPONENT RANGE */
/* Computing MIN */
i__1 = 32767, i__2 = i1mach_(&c__9) / 4 - 1;
mpcom_1.mpm = min(i__1,i__2);
return 0;
} /* mpblas_ */
/* DECK XERPRN */
/* Subroutine */ int xerprn_(char *prefix, integer *npref, char *messg,
integer *nwrap, ftnlen prefix_len, ftnlen messg_len)
{
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer i_len(char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_wsfe(cilist *), do_fio(integer *, char *, ftnlen), e_wsfe(void),
i_indx(char *, char *, ftnlen, ftnlen), s_cmp(char *, char *,
ftnlen, ftnlen);
/* Local variables */
static integer i__, n, iu[5];
static char cbuff[148];
static integer lpref, nextc, lwrap, nunit;
extern integer i1mach_(integer *);
static integer lpiece, idelta, lenmsg;
extern /* Subroutine */ int xgetua_(integer *, integer *);
/* Fortran I/O blocks */
static cilist io___9 = { 0, 0, 0, "(A)", 0 };
static cilist io___13 = { 0, 0, 0, "(A)", 0 };
/* ***BEGIN PROLOGUE XERPRN */
/* ***SUBSIDIARY */
/* ***PURPOSE Print error messages processed by XERMSG. */
/* ***LIBRARY SLATEC (XERROR) */
/* ***CATEGORY R3C */
/* ***TYPE ALL (XERPRN-A) */
/* ***KEYWORDS ERROR MESSAGES, PRINTING, XERROR */
/* ***AUTHOR Fong, Kirby, (NMFECC at LLNL) */
/* ***DESCRIPTION */
/* This routine sends one or more lines to each of the (up to five) */
/* logical units to which error messages are to be sent. This routine */
/* is called several times by XERMSG, sometimes with a single line to */
/* print and sometimes with a (potentially very long) message that may */
/* wrap around into multiple lines. */
/* PREFIX Input argument of type CHARACTER. This argument contains */
/* characters to be put at the beginning of each line before */
/* the body of the message. No more than 16 characters of */
/* PREFIX will be used. */
/* NPREF Input argument of type INTEGER. This argument is the number */
/* of characters to use from PREFIX. If it is negative, the */
/* intrinsic function LEN is used to determine its length. If */
/* it is zero, PREFIX is not used. If it exceeds 16 or if */
/* LEN(PREFIX) exceeds 16, only the first 16 characters will be */
/* used. If NPREF is positive and the length of PREFIX is less */
/* than NPREF, a copy of PREFIX extended with blanks to length */
/* NPREF will be used. */
/* MESSG Input argument of type CHARACTER. This is the text of a */
/* message to be printed. If it is a long message, it will be */
/* broken into pieces for printing on multiple lines. Each line */
/* will start with the appropriate prefix and be followed by a */
/* piece of the message. NWRAP is the number of characters per */
/* piece; that is, after each NWRAP characters, we break and */
/* start a new line. In addition the characters '$$' embedded */
/* in MESSG are a sentinel for a new line. The counting of */
/* characters up to NWRAP starts over for each new line. The */
/* value of NWRAP typically used by XERMSG is 72 since many */
/* older error messages in the SLATEC Library are laid out to */
/* rely on wrap-around every 72 characters. */
/* NWRAP Input argument of type INTEGER. This gives the maximum size */
/* piece into which to break MESSG for printing on multiple */
/* lines. An embedded '$$' ends a line, and the count restarts */
/* at the following character. If a line break does not occur */
/* on a blank (it would split a word) that word is moved to the */
/* next line. Values of NWRAP less than 16 will be treated as */
/* 16. Values of NWRAP greater than 132 will be treated as 132. */
/* The actual line length will be NPREF + NWRAP after NPREF has */
/* been adjusted to fall between 0 and 16 and NWRAP has been */
/* adjusted to fall between 16 and 132. */
/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */
/* Error-handling Package, SAND82-0800, Sandia */
/* Laboratories, 1982. */
/* ***ROUTINES CALLED I1MACH, XGETUA */
/* ***REVISION HISTORY (YYMMDD) */
/* 880621 DATE WRITTEN */
/* 880708 REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF */
/* JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK */
/* THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE */
/* SLASH CHARACTER IN FORMAT STATEMENTS. */
/* 890706 REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO */
/* STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK */
/* LINES TO BE PRINTED. */
/* 890721 REVISED TO ADD A NEW FEATURE. A NEGATIVE VALUE OF NPREF */
/* CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH. */
/* 891013 REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH. */
/* 891214 Prologue converted to Version 4.0 format. (WRB) */
/* 900510 Added code to break messages between words. (RWC) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE XERPRN */
/* ***FIRST EXECUTABLE STATEMENT XERPRN */
xgetua_(iu, &nunit);
/* A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD */
/* ERROR MESSAGE UNIT INSTEAD. I1MACH(4) RETRIEVES THE STANDARD */
/* ERROR MESSAGE UNIT. */
n = i1mach_(&c__4);
i__1 = nunit;
for (i__ = 1; i__ <= i__1; ++i__) {
if (iu[i__ - 1] == 0) {
iu[i__ - 1] = n;
}
/* L10: */
}
/* LPREF IS THE LENGTH OF THE PREFIX. THE PREFIX IS PLACED AT THE */
/* BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING */
/* THE REST OF THIS ROUTINE. */
if (*npref < 0) {
lpref = i_len(prefix, prefix_len);
} else {
lpref = *npref;
}
lpref = min(16,lpref);
if (lpref != 0) {
s_copy(cbuff, prefix, lpref, prefix_len);
}
/* LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE */
/* TIME FROM MESSG TO PRINT ON ONE LINE. */
/* Computing MAX */
i__1 = 16, i__2 = min(132,*nwrap);
lwrap = max(i__1,i__2);
/* SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS. */
lenmsg = i_len(messg, messg_len);
n = lenmsg;
i__1 = n;
for (i__ = 1; i__ <= i__1; ++i__) {
if (*(unsigned char *)&messg[lenmsg - 1] != ' ') {
goto L30;
}
--lenmsg;
/* L20: */
}
L30:
/* IF THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE. */
if (lenmsg == 0) {
i__1 = lpref;
s_copy(cbuff + i__1, " ", lpref + 1 - i__1, (ftnlen)1);
i__1 = nunit;
for (i__ = 1; i__ <= i__1; ++i__) {
io___9.ciunit = iu[i__ - 1];
s_wsfe(&io___9);
do_fio(&c__1, cbuff, lpref + 1);
e_wsfe();
/* L40: */
}
return 0;
}
/* SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING */
/* STARTS. FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL. */
/* WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT. */
/* WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED. */
/* WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL. THE */
/* INDEX INTRINSIC FUNCTION RETURNS ZERO IF THERE IS NO OCCURRENCE */
/* OR IF THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH */
/* OF THE SECOND ARGUMENT. */
/* THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE */
/* FOLLOWING ORDER. WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER */
/* OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT */
/* POSITION NEXTC. */
/* LPIECE .EQ. 0 THE NEW LINE SENTINEL DOES NOT OCCUR IN THE */
/* REMAINDER OF THE CHARACTER STRING. LPIECE */
/* SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC, */
/* WHICHEVER IS LESS. */
/* LPIECE .EQ. 1 THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC: */
/* NEXTC). LPIECE IS EFFECTIVELY ZERO, AND WE */
/* PRINT NOTHING TO AVOID PRODUCING UNNECESSARY */
/* BLANK LINES. THIS TAKES CARE OF THE SITUATION */
/* WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF */
/* EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE */
/* SENTINEL FOLLOWED BY MORE CHARACTERS. NEXTC */
/* SHOULD BE INCREMENTED BY 2. */
/* LPIECE .GT. LWRAP+1 REDUCE LPIECE TO LWRAP. */
/* ELSE THIS LAST CASE MEANS 2 .LE. LPIECE .LE. LWRAP+1 */
/* RESET LPIECE = LPIECE-1. NOTE THAT THIS */
/* PROPERLY HANDLES THE END CASE WHERE LPIECE .EQ. */
/* LWRAP+1. THAT IS, THE SENTINEL FALLS EXACTLY */
/* AT THE END OF A LINE. */
nextc = 1;
L50:
lpiece = i_indx(messg + (nextc - 1), "$$", lenmsg - (nextc - 1), (ftnlen)
2);
if (lpiece == 0) {
/* THERE WAS NO NEW LINE SENTINEL FOUND. */
idelta = 0;
/* Computing MIN */
i__1 = lwrap, i__2 = lenmsg + 1 - nextc;
lpiece = min(i__1,i__2);
if (lpiece < lenmsg + 1 - nextc) {
for (i__ = lpiece + 1; i__ >= 2; --i__) {
i__1 = nextc + i__ - 2;
if (s_cmp(messg + i__1, " ", nextc + i__ - 1 - i__1, (ftnlen)
1) == 0) {
lpiece = i__ - 1;
idelta = 1;
goto L54;
}
/* L52: */
}
}
L54:
i__1 = lpref;
s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1,
nextc + lpiece - 1 - (nextc - 1));
nextc = nextc + lpiece + idelta;
} else if (lpiece == 1) {
/* WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1). */
/* DON'T PRINT A BLANK LINE. */
nextc += 2;
goto L50;
} else if (lpiece > lwrap + 1) {
/* LPIECE SHOULD BE SET DOWN TO LWRAP. */
idelta = 0;
lpiece = lwrap;
for (i__ = lpiece + 1; i__ >= 2; --i__) {
i__1 = nextc + i__ - 2;
if (s_cmp(messg + i__1, " ", nextc + i__ - 1 - i__1, (ftnlen)1) ==
0) {
lpiece = i__ - 1;
idelta = 1;
goto L58;
}
/* L56: */
}
L58:
i__1 = lpref;
s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1,
nextc + lpiece - 1 - (nextc - 1));
nextc = nextc + lpiece + idelta;
} else {
/* IF WE ARRIVE HERE, IT MEANS 2 .LE. LPIECE .LE. LWRAP+1. */
/* WE SHOULD DECREMENT LPIECE BY ONE. */
--lpiece;
i__1 = lpref;
s_copy(cbuff + i__1, messg + (nextc - 1), lpref + lpiece - i__1,
nextc + lpiece - 1 - (nextc - 1));
nextc = nextc + lpiece + 2;
}
/* PRINT */
i__1 = nunit;
for (i__ = 1; i__ <= i__1; ++i__) {
io___13.ciunit = iu[i__ - 1];
s_wsfe(&io___13);
do_fio(&c__1, cbuff, lpref + lpiece);
e_wsfe();
/* L60: */
}
if (nextc <= lenmsg) {
goto L50;
}
return 0;
} /* xerprn_ */
/* DECK XERSVE */
/* Subroutine */ int xersve_(char *librar, char *subrou, char *messg, integer
*kflag, integer *nerr, integer *level, integer *icount, ftnlen
librar_len, ftnlen subrou_len, ftnlen messg_len)
{
/* Initialized data */
static integer kountx = 0;
static integer nmsg = 0;
/* Format strings */
static char fmt_9000[] = "(\0020 ERROR MESSAGE SUMMARY\002/\002"
" LIBRARY SUBROUTINE MESSAGE START NERR\002,\002 "
" LEVEL COUNT\002)";
static char fmt_9010[] = "(1x,a,3x,a,3x,a,3i10)";
static char fmt_9020[] = "(\0020OTHER ERRORS NOT INDIVIDUALLY TABULATED "
"= \002,i10)";
static char fmt_9030[] = "(1x)";
/* System generated locals */
integer i__1, i__2;
/* Builtin functions */
integer s_wsfe(cilist *), e_wsfe(void), do_fio(integer *, char *, ftnlen);
/* Subroutine */ int s_copy(char *, char *, ftnlen, ftnlen);
integer s_cmp(char *, char *, ftnlen, ftnlen);
/* Local variables */
integer i__;
char lib[8], mes[20], sub[8];
integer lun[5], iunit, kunit, nunit;
static integer kount[10];
extern integer i1mach_(integer *);
static char libtab[8*10], mestab[20*10];
static integer nertab[10], levtab[10];
static char subtab[8*10];
extern /* Subroutine */ int xgetua_(integer *, integer *);
/* Fortran I/O blocks */
static cilist io___7 = { 0, 0, 0, fmt_9000, 0 };
static cilist io___9 = { 0, 0, 0, fmt_9010, 0 };
static cilist io___16 = { 0, 0, 0, fmt_9020, 0 };
static cilist io___17 = { 0, 0, 0, fmt_9030, 0 };
/* ***BEGIN PROLOGUE XERSVE */
/* ***SUBSIDIARY */
/* ***PURPOSE Record that an error has occurred. */
/* ***LIBRARY SLATEC (XERROR) */
/* ***CATEGORY R3 */
/* ***TYPE ALL (XERSVE-A) */
/* ***KEYWORDS ERROR, XERROR */
/* ***AUTHOR Jones, R. E., (SNLA) */
/* ***DESCRIPTION */
/* *Usage: */
/* INTEGER KFLAG, NERR, LEVEL, ICOUNT */
/* CHARACTER * (len) LIBRAR, SUBROU, MESSG */
/* CALL XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT) */
/* *Arguments: */
/* LIBRAR :IN is the library that the message is from. */
/* SUBROU :IN is the subroutine that the message is from. */
/* MESSG :IN is the message to be saved. */
/* KFLAG :IN indicates the action to be performed. */
/* when KFLAG > 0, the message in MESSG is saved. */
/* when KFLAG=0 the tables will be dumped and */
/* cleared. */
/* when KFLAG < 0, the tables will be dumped and */
/* not cleared. */
/* NERR :IN is the error number. */
/* LEVEL :IN is the error severity. */
/* ICOUNT :OUT the number of times this message has been seen, */
/* or zero if the table has overflowed and does not */
/* contain this message specifically. When KFLAG=0, */
/* ICOUNT will not be altered. */
/* *Description: */
/* Record that this error occurred and possibly dump and clear the */
/* tables. */
/* ***REFERENCES R. E. Jones and D. K. Kahaner, XERROR, the SLATEC */
/* Error-handling Package, SAND82-0800, Sandia */
/* Laboratories, 1982. */
/* ***ROUTINES CALLED I1MACH, XGETUA */
/* ***REVISION HISTORY (YYMMDD) */
/* 800319 DATE WRITTEN */
/* 861211 REVISION DATE from Version 3.2 */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900413 Routine modified to remove reference to KFLAG. (WRB) */
/* 900510 Changed to add LIBRARY NAME and SUBROUTINE to calling */
/* sequence, use IF-THEN-ELSE, make number of saved entries */
/* easily changeable, changed routine name from XERSAV to */
/* XERSVE. (RWC) */
/* 910626 Added LIBTAB and SUBTAB to SAVE statement. (BKS) */
/* 920501 Reformatted the REFERENCES section. (WRB) */
/* ***END PROLOGUE XERSVE */
/* ***FIRST EXECUTABLE STATEMENT XERSVE */
if (*kflag <= 0) {
/* Dump the table. */
if (nmsg == 0) {
return 0;
}
/* Print to each unit. */
xgetua_(lun, &nunit);
i__1 = nunit;
for (kunit = 1; kunit <= i__1; ++kunit) {
iunit = lun[kunit - 1];
if (iunit == 0) {
iunit = i1mach_(&c__4);
}
/* Print the table header. */
io___7.ciunit = iunit;
s_wsfe(&io___7);
e_wsfe();
/* Print body of table. */
i__2 = nmsg;
for (i__ = 1; i__ <= i__2; ++i__) {
io___9.ciunit = iunit;
s_wsfe(&io___9);
do_fio(&c__1, libtab + ((i__ - 1) << 3), (ftnlen)8);
do_fio(&c__1, subtab + ((i__ - 1) << 3), (ftnlen)8);
do_fio(&c__1, mestab + (i__ - 1) * 20, (ftnlen)20);
do_fio(&c__1, (char *)&nertab[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&levtab[i__ - 1], (ftnlen)sizeof(
integer));
do_fio(&c__1, (char *)&kount[i__ - 1], (ftnlen)sizeof(integer)
);
e_wsfe();
/* L10: */
}
/* Print number of other errors. */
if (kountx != 0) {
io___16.ciunit = iunit;
s_wsfe(&io___16);
do_fio(&c__1, (char *)&kountx, (ftnlen)sizeof(integer));
e_wsfe();
}
io___17.ciunit = iunit;
s_wsfe(&io___17);
e_wsfe();
/* L20: */
}
/* Clear the error tables. */
if (*kflag == 0) {
nmsg = 0;
kountx = 0;
}
} else {
/* PROCESS A MESSAGE... */
/* SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG, */
/* OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL. */
s_copy(lib, librar, (ftnlen)8, librar_len);
s_copy(sub, subrou, (ftnlen)8, subrou_len);
s_copy(mes, messg, (ftnlen)20, messg_len);
i__1 = nmsg;
for (i__ = 1; i__ <= i__1; ++i__) {
if (s_cmp(lib, libtab + ((i__ - 1) << 3), (ftnlen)8, (ftnlen)8) ==
0 && s_cmp(sub, subtab + ((i__ - 1) << 3), (ftnlen)8, (
ftnlen)8) == 0 && s_cmp(mes, mestab + (i__ - 1) * 20, (
ftnlen)20, (ftnlen)20) == 0 && *nerr == nertab[i__ - 1] &&
*level == levtab[i__ - 1]) {
++kount[i__ - 1];
*icount = kount[i__ - 1];
return 0;
}
/* L30: */
}
if (nmsg < 10) {
/* Empty slot found for new message. */
++nmsg;
s_copy(libtab + ((i__ - 1) << 3), lib, (ftnlen)8, (ftnlen)8);
s_copy(subtab + ((i__ - 1) << 3), sub, (ftnlen)8, (ftnlen)8);
s_copy(mestab + (i__ - 1) * 20, mes, (ftnlen)20, (ftnlen)20);
nertab[i__ - 1] = *nerr;
levtab[i__ - 1] = *level;
kount[i__ - 1] = 1;
*icount = 1;
} else {
/* Table is full. */
++kountx;
*icount = 0;
}
}
return 0;
/* Formats. */
} /* xersve_ */
/* DECK DMOUT */
/* Subroutine */ int dmout_(integer *m, integer *n, integer *lda, doublereal *
a, char *ifmt, integer *idigit, ftnlen ifmt_len)
{
/* Initialized data */
static char icol[3] = "COL";
/* Format strings */
static char fmt_1010[] = "(10x,10(4x,a,i4,1x))";
static char fmt_1009[] = "(1x,\002ROW\002,i4,2x,1p,10d12.3)";
static char fmt_1000[] = "(10x,8(5x,a,i4,2x))";
static char fmt_1004[] = "(1x,\002ROW\002,i4,2x,1p,8d14.5)";
static char fmt_1001[] = "(10x,5(9x,a,i4,6x))";
static char fmt_1005[] = "(1x,\002ROW\002,i4,2x,1p,5d22.13)";
static char fmt_1002[] = "(10x,4(12x,a,i4,9x))";
static char fmt_1006[] = "(1x,\002ROW\002,i4,2x,1p,4d28.19)";
static char fmt_1003[] = "(10x,3(16x,a,i4,13x))";
static char fmt_1007[] = "(1x,\002ROW\002,i4,2x,1p,3d36.27)";
/* System generated locals */
integer a_dim1, a_offset, i__1, i__2, i__3;
cilist ci__1;
/* Local variables */
static integer i__, j, k1, k2, lout;
extern integer i1mach_(integer *);
static integer ndigit;
/* Fortran I/O blocks */
static cilist io___6 = { 0, 0, 0, fmt_1010, 0 };
static cilist io___8 = { 0, 0, 0, fmt_1009, 0 };
static cilist io___10 = { 0, 0, 0, fmt_1000, 0 };
static cilist io___11 = { 0, 0, 0, fmt_1004, 0 };
static cilist io___12 = { 0, 0, 0, fmt_1001, 0 };
static cilist io___13 = { 0, 0, 0, fmt_1005, 0 };
static cilist io___14 = { 0, 0, 0, fmt_1002, 0 };
static cilist io___15 = { 0, 0, 0, fmt_1006, 0 };
static cilist io___16 = { 0, 0, 0, fmt_1003, 0 };
static cilist io___17 = { 0, 0, 0, fmt_1007, 0 };
static cilist io___18 = { 0, 0, 0, fmt_1000, 0 };
static cilist io___19 = { 0, 0, 0, fmt_1009, 0 };
static cilist io___20 = { 0, 0, 0, fmt_1000, 0 };
static cilist io___21 = { 0, 0, 0, fmt_1004, 0 };
static cilist io___22 = { 0, 0, 0, fmt_1001, 0 };
static cilist io___23 = { 0, 0, 0, fmt_1005, 0 };
static cilist io___24 = { 0, 0, 0, fmt_1002, 0 };
static cilist io___25 = { 0, 0, 0, fmt_1006, 0 };
static cilist io___26 = { 0, 0, 0, fmt_1003, 0 };
static cilist io___27 = { 0, 0, 0, fmt_1007, 0 };
/* ***BEGIN PROLOGUE DMOUT */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DBOCLS and DFC */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (SMOUT-S, DMOUT-D) */
/* ***AUTHOR Hanson, R. J., (SNLA) */
/* Wisniewski, J. A., (SNLA) */
/* ***DESCRIPTION */
/* DOUBLE PRECISION MATRIX OUTPUT ROUTINE. */
/* INPUT.. */
/* M,N,LDA,A(*,*) PRINT THE DOUBLE PRECISION ARRAY A(I,J),I = 1,...,M, */
/* J=1,...,N, ON OUTPUT UNIT LOUT=6. LDA IS THE DECLARED */
/* FIRST DIMENSION OF A(*,*) AS SPECIFIED IN THE CALLING */
/* PROGRAM. THE HEADING IN THE FORTRAN FORMAT STATEMENT */
/* IFMT(*), DESCRIBED BELOW, IS PRINTED AS A FIRST STEP. */
/* THE COMPONENTS A(I,J) ARE INDEXED, ON OUTPUT, IN A */
/* PLEASANT FORMAT. */
/* IFMT(*) A FORTRAN FORMAT STATEMENT. THIS IS PRINTED ON */
/* OUTPUT UNIT LOUT=6 WITH THE VARIABLE FORMAT FORTRAN */
/* STATEMENT */
/* WRITE(LOUT,IFMT). */
/* IDIGIT PRINT AT LEAST ABS(IDIGIT) DECIMAL DIGITS PER NUMBER. */
/* THE SUBPROGRAM WILL CHOOSE THAT INTEGER 4,6,14,20 OR */
/* 28 WHICH WILL PRINT AT LEAST ABS(IDIGIT) NUMBER OF */
/* PLACES. IF IDIGIT.LT.0, 72 PRINTING COLUMNS ARE */
/* UTILIZED TO WRITE EACH LINE OF OUTPUT OF THE ARRAY */
/* A(*,*). (THIS CAN BE USED ON MOST TIME-SHARING */
/* TERMINALS). IF IDIGIT.GE.0, 133 PRINTING COLUMNS ARE */
/* UTILIZED. (THIS CAN BE USED ON MOST LINE PRINTERS). */
/* EXAMPLE.. */
/* PRINT AN ARRAY CALLED (SIMPLEX TABLEAU ) OF SIZE 10 BY 20 SHOWING */
/* 6 DECIMAL DIGITS PER NUMBER. THE USER IS RUNNING ON A TIME-SHARING */
/* SYSTEM WITH A 72 COLUMN OUTPUT DEVICE. */
/* DOUBLE PRECISION TABLEU(20,20) */
/* M = 10 */
/* N = 20 */
/* LDTABL = 20 */
/* IDIGIT = -6 */
/* CALL DMOUT(M,N,LDTABL,TABLEU,21H(16H1SIMPLEX TABLEAU),IDIGIT) */
/* ***SEE ALSO DBOCLS, DFC */
/* ***ROUTINES CALLED I1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 821220 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 891107 Added comma after 1P edit descriptor in FORMAT */
/* statements. (WRB) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900328 Added TYPE section. (WRB) */
/* 910403 Updated AUTHOR section. (WRB) */
/* ***END PROLOGUE DMOUT */
/* Parameter adjustments */
a_dim1 = *lda;
a_offset = 1 + a_dim1;
a -= a_offset;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT DMOUT */
lout = i1mach_(&c__2);
ci__1.cierr = 0;
ci__1.ciunit = lout;
ci__1.cifmt = ifmt;
s_wsfe(&ci__1);
e_wsfe();
if (*m <= 0 || *n <= 0 || *lda <= 0) {
return 0;
}
ndigit = *idigit;
if (*idigit == 0) {
ndigit = 4;
}
if (*idigit >= 0) {
goto L80;
}
ndigit = -(*idigit);
if (ndigit > 4) {
goto L9;
}
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 5) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 4;
k2 = min(i__2,i__3);
io___6.ciunit = lout;
s_wsfe(&io___6);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, icol, (ftnlen)3);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
io___8.ciunit = lout;
s_wsfe(&io___8);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
/* L5: */
}
}
return 0;
L9:
if (ndigit > 6) {
goto L20;
}
i__2 = *n;
for (k1 = 1; k1 <= i__2; k1 += 4) {
/* Computing MIN */
i__1 = *n, i__3 = k1 + 3;
k2 = min(i__1,i__3);
io___10.ciunit = lout;
s_wsfe(&io___10);
i__1 = k2;
for (i__ = k1; i__ <= i__1; ++i__) {
do_fio(&c__1, icol, (ftnlen)3);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
io___11.ciunit = lout;
s_wsfe(&io___11);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
/* L10: */
}
}
return 0;
L20:
if (ndigit > 14) {
goto L40;
}
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 2) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 1;
k2 = min(i__2,i__3);
io___12.ciunit = lout;
s_wsfe(&io___12);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, icol, (ftnlen)3);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
io___13.ciunit = lout;
s_wsfe(&io___13);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
/* L30: */
}
}
return 0;
L40:
if (ndigit > 20) {
goto L60;
}
i__2 = *n;
for (k1 = 1; k1 <= i__2; k1 += 2) {
/* Computing MIN */
i__1 = *n, i__3 = k1 + 1;
k2 = min(i__1,i__3);
io___14.ciunit = lout;
s_wsfe(&io___14);
i__1 = k2;
for (i__ = k1; i__ <= i__1; ++i__) {
do_fio(&c__1, icol, (ftnlen)3);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
io___15.ciunit = lout;
s_wsfe(&io___15);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
/* L50: */
}
}
return 0;
L60:
i__1 = *n;
for (k1 = 1; k1 <= i__1; ++k1) {
k2 = k1;
io___16.ciunit = lout;
s_wsfe(&io___16);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, icol, (ftnlen)3);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
io___17.ciunit = lout;
s_wsfe(&io___17);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
/* L70: */
}
}
return 0;
L80:
if (ndigit > 4) {
goto L86;
}
i__2 = *n;
for (k1 = 1; k1 <= i__2; k1 += 10) {
/* Computing MIN */
i__1 = *n, i__3 = k1 + 9;
k2 = min(i__1,i__3);
io___18.ciunit = lout;
s_wsfe(&io___18);
i__1 = k2;
for (i__ = k1; i__ <= i__1; ++i__) {
do_fio(&c__1, icol, (ftnlen)3);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
io___19.ciunit = lout;
s_wsfe(&io___19);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
/* L85: */
}
}
L86:
if (ndigit > 6) {
goto L100;
}
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 8) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 7;
k2 = min(i__2,i__3);
io___20.ciunit = lout;
s_wsfe(&io___20);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, icol, (ftnlen)3);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
io___21.ciunit = lout;
s_wsfe(&io___21);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
/* L90: */
}
}
return 0;
L100:
if (ndigit > 14) {
goto L120;
}
i__2 = *n;
for (k1 = 1; k1 <= i__2; k1 += 5) {
/* Computing MIN */
i__1 = *n, i__3 = k1 + 4;
k2 = min(i__1,i__3);
io___22.ciunit = lout;
s_wsfe(&io___22);
i__1 = k2;
for (i__ = k1; i__ <= i__1; ++i__) {
do_fio(&c__1, icol, (ftnlen)3);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
io___23.ciunit = lout;
s_wsfe(&io___23);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
/* L110: */
}
}
return 0;
L120:
if (ndigit > 20) {
goto L140;
}
i__1 = *n;
for (k1 = 1; k1 <= i__1; k1 += 4) {
/* Computing MIN */
i__2 = *n, i__3 = k1 + 3;
k2 = min(i__2,i__3);
io___24.ciunit = lout;
s_wsfe(&io___24);
i__2 = k2;
for (i__ = k1; i__ <= i__2; ++i__) {
do_fio(&c__1, icol, (ftnlen)3);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__2 = *m;
for (i__ = 1; i__ <= i__2; ++i__) {
io___25.ciunit = lout;
s_wsfe(&io___25);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
/* L130: */
}
}
return 0;
L140:
i__2 = *n;
for (k1 = 1; k1 <= i__2; k1 += 3) {
/* Computing MIN */
i__1 = *n, i__3 = k1 + 2;
k2 = min(i__1,i__3);
io___26.ciunit = lout;
s_wsfe(&io___26);
i__1 = k2;
for (i__ = k1; i__ <= i__1; ++i__) {
do_fio(&c__1, icol, (ftnlen)3);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
}
e_wsfe();
i__1 = *m;
for (i__ = 1; i__ <= i__1; ++i__) {
io___27.ciunit = lout;
s_wsfe(&io___27);
do_fio(&c__1, (char *)&i__, (ftnlen)sizeof(integer));
i__3 = k2;
for (j = k1; j <= i__3; ++j) {
do_fio(&c__1, (char *)&a[i__ + j * a_dim1], (ftnlen)sizeof(
doublereal));
}
e_wsfe();
/* L150: */
}
}
return 0;
} /* dmout_ */
/* DECK DGAMRN */
doublereal dgamrn_(doublereal *x)
{
/* Initialized data */
static doublereal gr[12] = { 1.,-.015625,.0025634765625,
-.0012798309326171875,.00134351104497909546,
-.00243289663922041655,.00675423753364157164,
-.0266369606131178216,.141527455519564332,-.974384543032201613,
8.43686251229783675,-89.7258321640552515 };
/* System generated locals */
integer i__1;
doublereal ret_val, d__1;
/* Local variables */
static integer i__, k;
static doublereal s;
static integer mx, nx;
static doublereal xm, xp, fln, rln, tol, trm, xsq;
static integer i1m11;
static doublereal xinc, xmin, xdmy;
extern doublereal d1mach_(integer *);
extern integer i1mach_(integer *);
/* ***BEGIN PROLOGUE DGAMRN */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DBSKIN */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (GAMRN-S, DGAMRN-D) */
/* ***AUTHOR Amos, D. E., (SNLA) */
/* ***DESCRIPTION */
/* Abstract * A Double Precision Routine * */
/* DGAMRN computes the GAMMA function ratio GAMMA(X)/GAMMA(X+0.5) */
/* for real X.gt.0. If X.ge.XMIN, an asymptotic expansion is */
/* evaluated. If X.lt.XMIN, an integer is added to X to form a */
/* new value of X.ge.XMIN and the asymptotic expansion is eval- */
/* uated for this new value of X. Successive application of the */
/* recurrence relation */
/* W(X)=W(X+1)*(1+0.5/X) */
/* reduces the argument to its original value. XMIN and comp- */
/* utational tolerances are computed as a function of the number */
/* of digits carried in a word by calls to I1MACH and D1MACH. */
/* However, the computational accuracy is limited to the max- */
/* imum of unit roundoff (=D1MACH(4)) and 1.0D-18 since critical */
/* constants are given to only 18 digits. */
/* Input X is Double Precision */
/* X - Argument, X.gt.0.0D0 */
/* Output DGAMRN is DOUBLE PRECISION */
/* DGAMRN - Ratio GAMMA(X)/GAMMA(X+0.5) */
/* ***SEE ALSO DBSKIN */
/* ***REFERENCES Y. L. Luke, The Special Functions and Their */
/* Approximations, Vol. 1, Math In Sci. And */
/* Eng. Series 53, Academic Press, New York, 1969, */
/* pp. 34-35. */
/* ***ROUTINES CALLED D1MACH, I1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 820601 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890911 Removed unnecessary intrinsics. (WRB) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900328 Added TYPE section. (WRB) */
/* 910722 Updated AUTHOR section. (ALS) */
/* 920520 Added REFERENCES section. (WRB) */
/* ***END PROLOGUE DGAMRN */
/* ***FIRST EXECUTABLE STATEMENT DGAMRN */
nx = (integer) (*x);
/* Computing MAX */
d__1 = d1mach_(&c__4);
tol = max(d__1,1e-18);
i1m11 = i1mach_(&c__14);
rln = d1mach_(&c__5) * i1m11;
fln = min(rln,20.);
fln = max(fln,3.);
fln += -3.;
xm = fln * (fln * .01723 + .2366) + 2.;
mx = (integer) xm + 1;
xmin = (doublereal) mx;
xdmy = *x - .25;
xinc = 0.;
if (*x >= xmin) {
goto L10;
}
xinc = xmin - nx;
xdmy += xinc;
L10:
s = 1.;
if (xdmy * tol > 1.) {
goto L30;
}
xsq = 1. / (xdmy * xdmy);
xp = xsq;
for (k = 2; k <= 12; ++k) {
trm = gr[k - 1] * xp;
if (abs(trm) < tol) {
goto L30;
}
s += trm;
xp *= xsq;
/* L20: */
}
L30:
s /= sqrt(xdmy);
if (xinc != 0.) {
goto L40;
}
ret_val = s;
return ret_val;
L40:
nx = (integer) xinc;
xp = 0.;
i__1 = nx;
for (i__ = 1; i__ <= i__1; ++i__) {
s *= .5 / (*x + xp) + 1.;
xp += 1.;
/* L50: */
}
ret_val = s;
return ret_val;
} /* dgamrn_ */
/* DECK ZBESK */
/* Subroutine */ int zbesk_(doublereal *zr, doublereal *zi, doublereal *fnu,
integer *kode, integer *n, doublereal *cyr, doublereal *cyi, integer *
nz, integer *ierr)
{
/* System generated locals */
integer i__1, i__2;
doublereal d__1;
/* Local variables */
static integer k, k1, k2;
static doublereal aa, bb, fn, az;
static integer nn;
static doublereal rl;
static integer mr, nw;
static doublereal dig, arg, aln, r1m5, ufl;
static integer nuf;
static doublereal tol, alim, elim;
extern doublereal zabs_(doublereal *, doublereal *);
static doublereal fnul;
extern /* Subroutine */ int zacon_(doublereal *, doublereal *, doublereal
*, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *, doublereal *,
doublereal *), zbknu_(doublereal *, doublereal *, doublereal *,
integer *, integer *, doublereal *, doublereal *, integer *,
doublereal *, doublereal *, doublereal *), zbunk_(doublereal *,
doublereal *, doublereal *, integer *, integer *, integer *,
doublereal *, doublereal *, integer *, doublereal *, doublereal *,
doublereal *);
extern doublereal d1mach_(integer *);
extern /* Subroutine */ int zuoik_(doublereal *, doublereal *, doublereal
*, integer *, integer *, integer *, doublereal *, doublereal *,
integer *, doublereal *, doublereal *, doublereal *);
extern integer i1mach_(integer *);
/* ***BEGIN PROLOGUE ZBESK */
/* ***PURPOSE Compute a sequence of the Bessel functions K(a,z) for */
/* complex argument z and real nonnegative orders a=b,b+1, */
/* b+2,... where b>0. A scaling option is available to */
/* help avoid overflow. */
/* ***LIBRARY SLATEC */
/* ***CATEGORY C10B4 */
/* ***TYPE COMPLEX (CBESK-C, ZBESK-C) */
/* ***KEYWORDS BESSEL FUNCTIONS OF COMPLEX ARGUMENT, K BESSEL FUNCTIONS, */
/* MODIFIED BESSEL FUNCTIONS */
/* ***AUTHOR Amos, D. E., (SNL) */
/* ***DESCRIPTION */
/* ***A DOUBLE PRECISION ROUTINE*** */
/* On KODE=1, ZBESK computes an N member sequence of complex */
/* Bessel functions CY(L)=K(FNU+L-1,Z) for real nonnegative */
/* orders FNU+L-1, L=1,...,N and complex Z.NE.0 in the cut */
/* plane -pi<arg(Z)<=pi where Z=ZR+i*ZI. On KODE=2, CBESJ */
/* returns the scaled functions */
/* CY(L) = exp(Z)*K(FNU+L-1,Z), L=1,...,N */
/* which remove the exponential growth in both the left and */
/* right half planes as Z goes to infinity. Definitions and */
/* notation are found in the NBS Handbook of Mathematical */
/* Functions (Ref. 1). */
/* Input */
/* ZR - DOUBLE PRECISION real part of nonzero argument Z */
/* ZI - DOUBLE PRECISION imag part of nonzero argument Z */
/* FNU - DOUBLE PRECISION initial order, FNU>=0 */
/* KODE - A parameter to indicate the scaling option */
/* KODE=1 returns */
/* CY(L)=K(FNU+L-1,Z), L=1,...,N */
/* =2 returns */
/* CY(L)=K(FNU+L-1,Z)*EXP(Z), L=1,...,N */
/* N - Number of terms in the sequence, N>=1 */
/* Output */
/* CYR - DOUBLE PRECISION real part of result vector */
/* CYI - DOUBLE PRECISION imag part of result vector */
/* NZ - Number of underflows set to zero */
/* NZ=0 Normal return */
/* NZ>0 CY(L)=0 for NZ values of L (if Re(Z)>0 */
/* then CY(L)=0 for L=1,...,NZ; in the */
/* complementary half plane the underflows */
/* may not be in an uninterrupted sequence) */
/* IERR - Error flag */
/* IERR=0 Normal return - COMPUTATION COMPLETED */
/* IERR=1 Input error - NO COMPUTATION */
/* IERR=2 Overflow - NO COMPUTATION */
/* (abs(Z) too small and/or FNU+N-1 */
/* too large) */
/* IERR=3 Precision warning - COMPUTATION COMPLETED */
/* (Result has half precision or less */
/* because abs(Z) or FNU+N-1 is large) */
/* IERR=4 Precision error - NO COMPUTATION */
/* (Result has no precision because */
/* abs(Z) or FNU+N-1 is too large) */
/* IERR=5 Algorithmic error - NO COMPUTATION */
/* (Termination condition not met) */
/* *Long Description: */
/* Equations of the reference are implemented to compute K(a,z) */
/* for small orders a and a+1 in the right half plane Re(z)>=0. */
/* Forward recurrence generates higher orders. The formula */
/* K(a,z*exp((t)) = exp(-t)*K(a,z) - t*I(a,z), Re(z)>0 */
/* t = i*pi or -i*pi */
/* continues K to the left half plane. */
/* For large orders, K(a,z) is computed by means of its uniform */
/* asymptotic expansion. */
/* For negative orders, the formula */
/* K(-a,z) = K(a,z) */
/* can be used. */
/* CBESK assumes that a significant digit sinh function is */
/* available. */
/* In most complex variable computation, one must evaluate ele- */
/* mentary functions. When the magnitude of Z or FNU+N-1 is */
/* large, losses of significance by argument reduction occur. */
/* Consequently, if either one exceeds U1=SQRT(0.5/UR), then */
/* losses exceeding half precision are likely and an error flag */
/* IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double */
/* precision unit roundoff limited to 18 digits precision. Also, */
/* if either is larger than U2=0.5/UR, then all significance is */
/* lost and IERR=4. In order to use the INT function, arguments */
/* must be further restricted not to exceed the largest machine */
/* integer, U3=I1MACH(9). Thus, the magnitude of Z and FNU+N-1 */
/* is restricted by MIN(U2,U3). In IEEE arithmetic, U1,U2, and */
/* U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision */
/* and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision. This */
/* makes U2 limiting in single precision and U3 limiting in */
/* double precision. This means that one can expect to retain, */
/* in the worst cases on IEEE machines, no digits in single pre- */
/* cision and only 6 digits in double precision. Similar con- */
/* siderations hold for other machines. */
/* The approximate relative error in the magnitude of a complex */
/* Bessel function can be expressed as P*10**S where P=MAX(UNIT */
/* ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre- */
/* sents the increase in error due to argument reduction in the */
/* elementary functions. Here, S=MAX(1,ABS(LOG10(ABS(Z))), */
/* ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF */
/* ABS(Z),ABS(EXPONENT OF FNU)) ). However, the phase angle may */
/* have only absolute accuracy. This is most likely to occur */
/* when one component (in magnitude) is larger than the other by */
/* several orders of magnitude. If one component is 10**K larger */
/* than the other, then one can expect only MAX(ABS(LOG10(P))-K, */
/* 0) significant digits; or, stated another way, when K exceeds */
/* the exponent of P, no significant digits remain in the smaller */
/* component. However, the phase angle retains absolute accuracy */
/* because, in complex arithmetic with precision P, the smaller */
/* component will not (as a rule) decrease below P times the */
/* magnitude of the larger component. In these extreme cases, */
/* the principal phase angle is on the order of +P, -P, PI/2-P, */
/* or -PI/2+P. */
/* ***REFERENCES 1. M. Abramowitz and I. A. Stegun, Handbook of Mathe- */
/* matical Functions, National Bureau of Standards */
/* Applied Mathematics Series 55, U. S. Department */
/* of Commerce, Tenth Printing (1972) or later. */
/* 2. D. E. Amos, Computation of Bessel Functions of */
/* Complex Argument, Report SAND83-0086, Sandia National */
/* Laboratories, Albuquerque, NM, May 1983. */
/* 3. D. E. Amos, Computation of Bessel Functions of */
/* Complex Argument and Large Order, Report SAND83-0643, */
/* Sandia National Laboratories, Albuquerque, NM, May */
/* 1983. */
/* 4. D. E. Amos, A Subroutine Package for Bessel Functions */
/* of a Complex Argument and Nonnegative Order, Report */
/* SAND85-1018, Sandia National Laboratory, Albuquerque, */
/* NM, May 1985. */
/* 5. D. E. Amos, A portable package for Bessel functions */
/* of a complex argument and nonnegative order, ACM */
/* Transactions on Mathematical Software, 12 (September */
/* 1986), pp. 265-273. */
/* ***ROUTINES CALLED D1MACH, I1MACH, ZABS, ZACON, ZBKNU, ZBUNK, ZUOIK */
/* ***REVISION HISTORY (YYMMDD) */
/* 830501 DATE WRITTEN */
/* 890801 REVISION DATE from Version 3.2 */
/* 910415 Prologue converted to Version 4.0 format. (BAB) */
/* 920128 Category corrected. (WRB) */
/* 920811 Prologue revised. (DWL) */
/* ***END PROLOGUE ZBESK */
/* COMPLEX CY,Z */
/* ***FIRST EXECUTABLE STATEMENT ZBESK */
/* Parameter adjustments */
--cyi;
--cyr;
/* Function Body */
*ierr = 0;
*nz = 0;
if (*zi == 0.f && *zr == 0.f) {
*ierr = 1;
}
if (*fnu < 0.) {
*ierr = 1;
}
if (*kode < 1 || *kode > 2) {
*ierr = 1;
}
if (*n < 1) {
*ierr = 1;
}
if (*ierr != 0) {
return 0;
}
nn = *n;
/* ----------------------------------------------------------------------- */
/* SET PARAMETERS RELATED TO MACHINE CONSTANTS. */
/* TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. */
/* ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. */
/* EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND */
/* EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR */
/* UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. */
/* RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. */
/* DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). */
/* FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU */
/* ----------------------------------------------------------------------- */
/* Computing MAX */
d__1 = d1mach_(&c__4);
tol = max(d__1,1e-18);
k1 = i1mach_(&c__15);
k2 = i1mach_(&c__16);
r1m5 = d1mach_(&c__5);
/* Computing MIN */
i__1 = abs(k1), i__2 = abs(k2);
k = min(i__1,i__2);
elim = (k * r1m5 - 3.) * 2.303;
k1 = i1mach_(&c__14) - 1;
aa = r1m5 * k1;
dig = min(aa,18.);
aa *= 2.303;
/* Computing MAX */
d__1 = -aa;
alim = elim + max(d__1,-41.45);
fnul = (dig - 3.) * 6. + 10.;
rl = dig * 1.2 + 3.;
/* ----------------------------------------------------------------------- */
/* TEST FOR PROPER RANGE */
/* ----------------------------------------------------------------------- */
az = zabs_(zr, zi);
fn = *fnu + (nn - 1);
aa = .5 / tol;
bb = i1mach_(&c__9) * .5;
aa = min(aa,bb);
if (az > aa) {
goto L260;
}
if (fn > aa) {
goto L260;
}
aa = sqrt(aa);
if (az > aa) {
*ierr = 3;
}
if (fn > aa) {
*ierr = 3;
}
/* ----------------------------------------------------------------------- */
/* OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE */
/* ----------------------------------------------------------------------- */
/* UFL = EXP(-ELIM) */
ufl = d1mach_(&c__1) * 1e3;
if (az < ufl) {
goto L180;
}
if (*fnu > fnul) {
goto L80;
}
if (fn <= 1.) {
goto L60;
}
if (fn > 2.) {
goto L50;
}
if (az > tol) {
goto L60;
}
arg = az * .5;
aln = -fn * log(arg);
if (aln > elim) {
goto L180;
}
goto L60;
L50:
zuoik_(zr, zi, fnu, kode, &c__2, &nn, &cyr[1], &cyi[1], &nuf, &tol, &elim,
&alim);
if (nuf < 0) {
goto L180;
}
*nz += nuf;
nn -= nuf;
/* ----------------------------------------------------------------------- */
/* HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK */
/* IF NUF=NN, THEN CY(I)=CZERO FOR ALL I */
/* ----------------------------------------------------------------------- */
if (nn == 0) {
goto L100;
}
L60:
if (*zr < 0.) {
goto L70;
}
/* ----------------------------------------------------------------------- */
/* RIGHT HALF PLANE COMPUTATION, REAL(Z).GE.0. */
/* ----------------------------------------------------------------------- */
zbknu_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, &tol, &elim, &alim);
if (nw < 0) {
goto L200;
}
*nz = nw;
return 0;
/* ----------------------------------------------------------------------- */
/* LEFT HALF PLANE COMPUTATION */
/* PI/2.LT.ARG(Z).LE.PI AND -PI.LT.ARG(Z).LT.-PI/2. */
/* ----------------------------------------------------------------------- */
L70:
if (*nz != 0) {
goto L180;
}
mr = 1;
if (*zi < 0.) {
mr = -1;
}
zacon_(zr, zi, fnu, kode, &mr, &nn, &cyr[1], &cyi[1], &nw, &rl, &fnul, &
tol, &elim, &alim);
if (nw < 0) {
goto L200;
}
*nz = nw;
return 0;
/* ----------------------------------------------------------------------- */
/* UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL */
/* ----------------------------------------------------------------------- */
L80:
mr = 0;
if (*zr >= 0.) {
goto L90;
}
mr = 1;
if (*zi < 0.) {
mr = -1;
}
L90:
zbunk_(zr, zi, fnu, kode, &mr, &nn, &cyr[1], &cyi[1], &nw, &tol, &elim, &
alim);
if (nw < 0) {
goto L200;
}
*nz += nw;
return 0;
L100:
if (*zr < 0.) {
goto L180;
}
return 0;
L180:
*nz = 0;
*ierr = 2;
return 0;
L200:
if (nw == -1) {
goto L180;
}
*nz = 0;
*ierr = 5;
return 0;
L260:
*nz = 0;
*ierr = 4;
return 0;
} /* zbesk_ */
/* DECK DBSKNU */
/* Subroutine */ int dbsknu_(doublereal *x, doublereal *fnu, integer *kode,
integer *n, doublereal *y, integer *nz)
{
/* Initialized data */
static doublereal x1 = 2.;
static doublereal x2 = 17.;
static doublereal pi = 3.14159265358979;
static doublereal rthpi = 1.2533141373155;
static doublereal cc[8] = { .577215664901533,-.0420026350340952,
-.0421977345555443,.007218943246663,-2.152416741149e-4,
-2.01348547807e-5,1.133027232e-6,6.116095e-9 };
/* System generated locals */
integer i__1;
/* Local variables */
static doublereal a[160], b[160], f;
static integer i__, j, k;
static doublereal p, q, s, a1, a2, g1, g2, p1, p2, s1, s2, t1, t2, fc, ak,
bk, ck, dk, fk;
static integer kk;
static doublereal cx;
static integer nn;
static doublereal ex, tm, pt, st, rx, fhs, fks, dnu, fmu;
static integer inu;
static doublereal sqk, tol, smu, dnu2, coef, elim, flrx;
static integer iflag, koded;
static doublereal etest;
extern doublereal d1mach_(integer *);
extern integer i1mach_(integer *);
extern doublereal dgamma_(doublereal *);
extern /* Subroutine */ int xermsg_(char *, char *, char *, integer *,
integer *, ftnlen, ftnlen, ftnlen);
/* ***BEGIN PROLOGUE DBSKNU */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DBESK */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (BESKNU-S, DBSKNU-D) */
/* ***AUTHOR Amos, D. E., (SNLA) */
/* ***DESCRIPTION */
/* Abstract **** A DOUBLE PRECISION routine **** */
/* DBSKNU computes N member sequences of K Bessel functions */
/* K/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 K/SUB(DNU)/(X) and K/SUB(DNU+1)/(X). */
/* Forward recursion with the three term recursion relation */
/* generates higher orders FNU+I-1, I=1,...,N. The parameter */
/* KODE permits K/SUB(FNU+I-1)/(X) values or scaled values */
/* EXP(X)*K/SUB(FNU+I-1)/(X), I=1,N to be returned. */
/* 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,X) is implemented on X1.LT.X.LE.X2. */
/* 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. */
/* The maximum number of significant digits obtainable */
/* is the smaller of 14 and the number of digits carried in */
/* DOUBLE PRECISION arithmetic. */
/* DBSKNU assumes that a significant digit SINH function is */
/* available. */
/* Description of Arguments */
/* INPUT X,FNU are DOUBLE PRECISION */
/* X - X.GT.0.0D0 */
/* FNU - Order of initial K function, FNU.GE.0.0D0 */
/* N - Number of members of the sequence, N.GE.1 */
/* KODE - A parameter to indicate the scaling option */
/* KODE= 1 returns */
/* Y(I)= K/SUB(FNU+I-1)/(X) */
/* I=1,...,N */
/* = 2 returns */
/* Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X) */
/* I=1,...,N */
/* OUTPUT Y is DOUBLE PRECISION */
/* Y - A vector whose first N components contain values */
/* for the sequence */
/* Y(I)= K/SUB(FNU+I-1)/(X), I=1,...,N or */
/* Y(I)=EXP(X)*K/SUB(FNU+I-1)/(X), I=1,...,N */
/* depending on KODE */
/* NZ - Number of components set to zero due to */
/* underflow, */
/* NZ= 0 , normal return */
/* NZ.NE.0 , first NZ components of Y set to zero */
/* due to underflow, Y(I)=0.0D0,I=1,...,NZ */
/* Error Conditions */
/* Improper input arguments - a fatal error */
/* Overflow - a fatal error */
/* Underflow with KODE=1 - a non-fatal error (NZ.NE.0) */
/* ***SEE ALSO DBESK */
/* ***REFERENCES 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 D1MACH, DGAMMA, I1MACH, XERMSG */
/* ***REVISION HISTORY (YYMMDD) */
/* 790201 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 890911 Removed unnecessary intrinsics. (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 DBSKNU */
/* Parameter adjustments */
--y;
/* Function Body */
/* ***FIRST EXECUTABLE STATEMENT DBSKNU */
kk = -i1mach_(&c__15);
elim = (kk * d1mach_(&c__5) - 3.) * 2.303;
ak = d1mach_(&c__3);
tol = max(ak,1e-15);
if (*x <= 0.) {
goto L350;
}
if (*fnu < 0.) {
goto L360;
}
if (*kode < 1 || *kode > 2) {
goto L370;
}
if (*n < 1) {
goto L380;
}
*nz = 0;
iflag = 0;
koded = *kode;
rx = 2. / *x;
inu = (integer) (*fnu + .5);
dnu = *fnu - inu;
if (abs(dnu) == .5) {
goto L120;
}
dnu2 = 0.;
if (abs(dnu) < tol) {
goto L10;
}
dnu2 = dnu * dnu;
L10:
if (*x > x1) {
goto L120;
}
/* SERIES FOR X.LE.X1 */
a1 = 1. - dnu;
a2 = dnu + 1.;
t1 = 1. / dgamma_(&a1);
t2 = 1. / dgamma_(&a2);
if (abs(dnu) > .1) {
goto L40;
}
/* SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) */
s = cc[0];
ak = 1.;
for (k = 2; k <= 8; ++k) {
ak *= dnu2;
tm = cc[k - 1] * ak;
s += tm;
if (abs(tm) < tol) {
goto L30;
}
/* L20: */
}
L30:
g1 = -s;
goto L50;
L40:
g1 = (t1 - t2) / (dnu + dnu);
L50:
g2 = (t1 + t2) * .5;
smu = 1.;
fc = 1.;
flrx = log(rx);
fmu = dnu * flrx;
if (dnu == 0.) {
goto L60;
}
fc = dnu * pi;
fc /= sin(fc);
if (fmu != 0.) {
smu = sinh(fmu) / fmu;
}
L60:
f = fc * (g1 * cosh(fmu) + g2 * flrx * smu);
fc = exp(fmu);
p = fc * .5 / t2;
q = .5 / (fc * t1);
ak = 1.;
ck = 1.;
bk = 1.;
s1 = f;
s2 = p;
if (inu > 0 || *n > 1) {
goto L90;
}
if (*x < tol) {
goto L80;
}
cx = *x * *x * .25;
L70:
f = (ak * f + p + q) / (bk - dnu2);
p /= ak - dnu;
q /= ak + dnu;
ck = ck * cx / ak;
t1 = ck * f;
s1 += t1;
bk = bk + ak + ak + 1.;
ak += 1.;
s = abs(t1) / (abs(s1) + 1.);
if (s > tol) {
goto L70;
}
L80:
y[1] = s1;
if (koded == 1) {
return 0;
}
y[1] = s1 * exp(*x);
return 0;
L90:
if (*x < tol) {
goto L110;
}
cx = *x * *x * .25;
L100:
f = (ak * f + p + q) / (bk - dnu2);
p /= ak - dnu;
q /= ak + dnu;
ck = ck * cx / ak;
t1 = ck * f;
s1 += t1;
t2 = ck * (p - ak * f);
s2 += t2;
bk = bk + ak + ak + 1.;
ak += 1.;
s = abs(t1) / (abs(s1) + 1.) + abs(t2) / (abs(s2) + 1.);
if (s > tol) {
goto L100;
}
L110:
s2 *= rx;
if (koded == 1) {
goto L170;
}
f = exp(*x);
s1 *= f;
s2 *= f;
goto L170;
L120:
coef = rthpi / sqrt(*x);
if (koded == 2) {
goto L130;
}
if (*x > elim) {
goto L330;
}
coef *= exp(-(*x));
L130:
if (abs(dnu) == .5) {
goto L340;
}
if (*x > x2) {
goto L280;
}
/* MILLER ALGORITHM FOR X1.LT.X.LE.X2 */
etest = cos(pi * dnu) / (pi * *x * tol);
fks = 1.;
fhs = .25;
fk = 0.;
ck = *x + *x + 2.;
p1 = 0.;
p2 = 1.;
k = 0;
L140:
++k;
fk += 1.;
ak = (fhs - dnu2) / (fks + fk);
bk = ck / (fk + 1.);
pt = p2;
p2 = bk * p2 - ak * p1;
p1 = pt;
a[k - 1] = ak;
b[k - 1] = bk;
ck += 2.;
fks = fks + fk + fk + 1.;
fhs = fhs + fk + fk;
if (etest > fk * p1) {
goto L140;
}
kk = k;
s = 1.;
p1 = 0.;
p2 = 1.;
i__1 = k;
for (i__ = 1; i__ <= i__1; ++i__) {
pt = p2;
p2 = (b[kk - 1] * p2 - p1) / a[kk - 1];
p1 = pt;
s += p2;
--kk;
/* L150: */
}
s1 = coef * (p2 / s);
if (inu > 0 || *n > 1) {
goto L160;
}
goto L200;
L160:
s2 = s1 * (*x + dnu + .5 - p1 / p2) / *x;
/* FORWARD RECURSION ON THE THREE TERM RECURSION RELATION */
L170:
ck = (dnu + dnu + 2.) / *x;
if (*n == 1) {
--inu;
}
if (inu > 0) {
goto L180;
}
if (*n > 1) {
goto L200;
}
s1 = s2;
goto L200;
L180:
i__1 = inu;
for (i__ = 1; i__ <= i__1; ++i__) {
st = s2;
s2 = ck * s2 + s1;
s1 = st;
ck += rx;
/* L190: */
}
if (*n == 1) {
s1 = s2;
}
L200:
if (iflag == 1) {
goto L220;
}
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;
/* L210: */
}
return 0;
/* IFLAG=1 CASES */
L220:
s = -(*x) + log(s1);
y[1] = 0.;
*nz = 1;
if (s < -elim) {
goto L230;
}
y[1] = exp(s);
*nz = 0;
L230:
if (*n == 1) {
return 0;
}
s = -(*x) + log(s2);
y[2] = 0.;
++(*nz);
if (s < -elim) {
goto L240;
}
--(*nz);
y[2] = exp(s);
L240:
if (*n == 2) {
return 0;
}
kk = 2;
if (*nz < 2) {
goto L260;
}
i__1 = *n;
for (i__ = 3; i__ <= i__1; ++i__) {
kk = i__;
st = s2;
s2 = ck * s2 + s1;
s1 = st;
ck += rx;
s = -(*x) + log(s2);
++(*nz);
y[i__] = 0.;
if (s < -elim) {
goto L250;
}
y[i__] = exp(s);
--(*nz);
goto L260;
L250:
;
}
return 0;
L260:
if (kk == *n) {
return 0;
}
s2 = s2 * ck + s1;
ck += rx;
++kk;
y[kk] = exp(-(*x) + log(s2));
if (kk == *n) {
return 0;
}
++kk;
i__1 = *n;
for (i__ = kk; i__ <= i__1; ++i__) {
y[i__] = ck * y[i__ - 1] + y[i__ - 2];
ck += rx;
/* L270: */
}
return 0;
/* ASYMPTOTIC EXPANSION FOR LARGE X, X.GT.X2 */
/* IFLAG=0 MEANS NO UNDERFLOW OCCURRED */
/* IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH */
/* KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD */
/* RECURSION */
L280:
nn = 2;
if (inu == 0 && *n == 1) {
nn = 1;
}
dnu2 = dnu + dnu;
fmu = 0.;
if (abs(dnu2) < tol) {
goto L290;
}
fmu = dnu2 * dnu2;
L290:
ex = *x * 8.;
s2 = 0.;
i__1 = nn;
for (k = 1; k <= i__1; ++k) {
s1 = s2;
s = 1.;
ak = 0.;
ck = 1.;
sqk = 1.;
dk = ex;
for (j = 1; j <= 30; ++j) {
ck = ck * (fmu - sqk) / dk;
s += ck;
dk += ex;
ak += 8.;
sqk += ak;
if (abs(ck) < tol) {
goto L310;
}
/* L300: */
}
L310:
s2 = s * coef;
fmu = fmu + dnu * 8. + 4.;
/* L320: */
}
if (nn > 1) {
goto L170;
}
s1 = s2;
goto L200;
L330:
koded = 2;
iflag = 1;
goto L120;
/* FNU=HALF ODD INTEGER CASE */
L340:
s1 = coef;
s2 = coef;
goto L170;
L350:
xermsg_("SLATEC", "DBSKNU", "X NOT GREATER THAN ZERO", &c__2, &c__1, (
ftnlen)6, (ftnlen)6, (ftnlen)23);
return 0;
L360:
xermsg_("SLATEC", "DBSKNU", "FNU NOT ZERO OR POSITIVE", &c__2, &c__1, (
ftnlen)6, (ftnlen)6, (ftnlen)24);
return 0;
L370:
xermsg_("SLATEC", "DBSKNU", "KODE NOT 1 OR 2", &c__2, &c__1, (ftnlen)6, (
ftnlen)6, (ftnlen)15);
return 0;
L380:
xermsg_("SLATEC", "DBSKNU", "N NOT GREATER THAN 0", &c__2, &c__1, (ftnlen)
6, (ftnlen)6, (ftnlen)20);
return 0;
} /* dbsknu_ */
/* DECK DSOSEQ */
/* Subroutine */ int dsoseq_(D_fp fnc, integer *n, doublereal *s, doublereal *
rtolx, doublereal *atolx, doublereal *tolf, integer *iflag, integer *
mxit, integer *ncjs, integer *nsrrc, integer *nsri, integer *iprint,
doublereal *fmax, doublereal *c__, integer *nc, doublereal *b,
doublereal *p, doublereal *temp, doublereal *x, doublereal *y,
doublereal *fac, integer *is)
{
/* Format strings */
static char fmt_210[] = "(\0020RESIDUAL NORM =\002,d9.2,/1x,\002SOLUTION"
" ITERATE (\002,i3,\002)\002,/(1x,5d26.14))";
/* System generated locals */
integer i__1, i__2, i__3, i__4;
doublereal d__1, d__2, d__3;
/* Local variables */
static doublereal f, h__;
static integer j, k, l, m, ic, kd, jk, kj, kk;
static doublereal fp;
static integer kn, mm;
static doublereal re;
static integer it, js, ls;
static doublereal hx, yj, fn1, fn2;
static integer km1, np1;
static doublereal yn1, yn2, yn3;
static integer icr, isj, mit;
static doublereal csv;
static integer isv, ksv;
static doublereal uro, yns, fdif, fact, fmin;
static integer item;
static doublereal pmax;
static integer loun;
static doublereal fmxs, test, zero;
static integer itry;
extern doublereal d1mach_(integer *);
extern integer i1mach_(integer *);
static doublereal xnorm, ynorm, sruro;
extern /* Subroutine */ int dsossl_(integer *, integer *, integer *,
doublereal *, doublereal *, doublereal *, integer *);
/* Fortran I/O blocks */
static cilist io___48 = { 0, 0, 0, fmt_210, 0 };
/* ***BEGIN PROLOGUE DSOSEQ */
/* ***SUBSIDIARY */
/* ***PURPOSE Subsidiary to DSOS */
/* ***LIBRARY SLATEC */
/* ***TYPE DOUBLE PRECISION (SOSEQS-S, DSOSEQ-D) */
/* ***AUTHOR (UNKNOWN) */
/* ***DESCRIPTION */
/* DSOSEQ solves a system of N simultaneous nonlinear equations. */
/* See the comments in the interfacing routine DSOS for a more */
/* detailed description of some of the items in the calling list. */
/* ********************************************************************** */
/* -Input- */
/* FNC- Function subprogram which evaluates the equations */
/* N -number of equations */
/* S -Solution vector of initial guesses */
/* RTOLX-Relative error tolerance on solution components */
/* ATOLX-Absolute error tolerance on solution components */
/* TOLF-Residual error tolerance */
/* MXIT-Maximum number of allowable iterations. */
/* NCJS-Maximum number of consecutive iterative steps to perform */
/* using the same triangular Jacobian matrix approximation. */
/* NSRRC-Number of consecutive iterative steps for which the */
/* limiting precision accuracy test must be satisfied */
/* before the routine exits with IFLAG=4. */
/* NSRI-Number of consecutive iterative steps for which the */
/* diverging condition test must be satisfied before */
/* the routine exits with IFLAG=7. */
/* IPRINT-Internal printing parameter. You must set IPRINT=-1 if you */
/* want the intermediate solution iterates and a residual norm */
/* to be printed. */
/* C -Internal work array, dimensioned at least N*(N+1)/2. */
/* NC -Dimension of C array. NC .GE. N*(N+1)/2. */
/* B -Internal work array, dimensioned N. */
/* P -Internal work array, dimensioned N. */
/* TEMP-Internal work array, dimensioned N. */
/* X -Internal work array, dimensioned N. */
/* Y -Internal work array, dimensioned N. */
/* FAC -Internal work array, dimensioned N. */
/* IS -Internal work array, dimensioned N. */
/* -Output- */
/* S -Solution vector */
/* IFLAG-Status indicator flag */
/* MXIT-The actual number of iterations performed */
/* FMAX-Residual norm */
/* C -Upper unit triangular matrix which approximates the */
/* forward triangularization of the full Jacobian matrix. */
/* Stored in a vector with dimension at least N*(N+1)/2. */
/* B -Contains the residuals (function values) divided */
/* by the corresponding components of the P vector */
/* P -Array used to store the partial derivatives. After */
/* each iteration P(K) contains the maximal derivative */
/* occurring in the K-th reduced equation. */
/* TEMP-Array used to store the previous solution iterate. */
/* X -Solution vector. Contains the values achieved on the */
/* last iteration loop upon exit from DSOS. */
/* Y -Array containing the solution increments. */
/* FAC -Array containing factors used in computing numerical */
/* derivatives. */
/* IS -Records the pivotal information (column interchanges) */
/* ********************************************************************** */
/* *** Three machine dependent parameters appear in this subroutine. */
/* *** The smallest positive magnitude, zero, is defined by the function */
/* *** routine D1MACH(1). */
/* *** URO, the computer unit roundoff value, is defined by D1MACH(3) for */
/* *** machines that round or D1MACH(4) for machines that truncate. */
/* *** URO is the smallest positive number such that 1.+URO .GT. 1. */
/* *** The output tape unit number, LOUN, is defined by the function */
/* *** I1MACH(2). */
/* ********************************************************************** */
/* ***SEE ALSO DSOS */
/* ***ROUTINES CALLED D1MACH, DSOSSL, I1MACH */
/* ***REVISION HISTORY (YYMMDD) */
/* 801001 DATE WRITTEN */
/* 890531 Changed all specific intrinsics to generic. (WRB) */
/* 891214 Prologue converted to Version 4.0 format. (BAB) */
/* 900328 Added TYPE section. (WRB) */
/* ***END PROLOGUE DSOSEQ */
/* BEGIN BLOCK PERMITTING ...EXITS TO 430 */
/* BEGIN BLOCK PERMITTING ...EXITS TO 410 */
/* BEGIN BLOCK PERMITTING ...EXITS TO 390 */
/* ***FIRST EXECUTABLE STATEMENT DSOSEQ */
/* Parameter adjustments */
--is;
--fac;
--y;
--x;
--temp;
--p;
--b;
--c__;
--s;
/* Function Body */
uro = d1mach_(&c__4);
loun = i1mach_(&c__2);
zero = d1mach_(&c__1);
re = max(*rtolx,uro);
sruro = sqrt(uro);
*iflag = 0;
np1 = *n + 1;
icr = 0;
ic = 0;
itry = *ncjs;
yn1 = 0.;
yn2 = 0.;
yn3 = 0.;
yns = 0.;
mit = 0;
fn1 = 0.;
fn2 = 0.;
fmxs = 0.;
/* INITIALIZE THE INTERCHANGE (PIVOTING) VECTOR AND */
/* SAVE THE CURRENT SOLUTION APPROXIMATION FOR FUTURE USE. */
i__1 = *n;
for (k = 1; k <= i__1; ++k) {
is[k] = k;
x[k] = s[k];
temp[k] = x[k];
/* L10: */
}
/* ********************************************************* */
/* **** BEGIN PRINCIPAL ITERATION LOOP **** */
/* ********************************************************* */
i__1 = *mxit;
for (m = 1; m <= i__1; ++m) {
/* BEGIN BLOCK PERMITTING ...EXITS TO 350 */
/* BEGIN BLOCK PERMITTING ...EXITS TO 240 */
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
fac[k] = sruro;
/* L20: */
}
L30:
/* BEGIN BLOCK PERMITTING ...EXITS TO 180 */
kn = 1;
*fmax = 0.;
/* ******** BEGIN SUBITERATION LOOP DEFINING */
/* THE LINEARIZATION OF EACH ******** */
/* EQUATION WHICH RESULTS IN THE CONSTRUCTION */
/* OF AN UPPER ******** TRIANGULAR MATRIX */
/* APPROXIMATING THE FORWARD ******** */
/* TRIANGULARIZATION OF THE FULL JACOBIAN */
/* MATRIX */
i__2 = *n;
for (k = 1; k <= i__2; ++k) {
/* BEGIN BLOCK PERMITTING ...EXITS TO 160 */
km1 = k - 1;
/* BACK-SOLVE A TRIANGULAR LINEAR */
/* SYSTEM OBTAINING IMPROVED SOLUTION */
/* VALUES FOR K-1 OF THE VARIABLES FROM */
/* THE FIRST K-1 EQUATIONS. THESE */
/* VARIABLES ARE THEN ELIMINATED FROM */
/* THE K-TH EQUATION. */
if (km1 == 0) {
goto L50;
}
dsossl_(&k, n, &km1, &y[1], &c__[1], &b[1], &kn);
i__3 = km1;
for (j = 1; j <= i__3; ++j) {
js = is[j];
x[js] = temp[js] + y[j];
/* L40: */
}
L50:
/* EVALUATE THE K-TH EQUATION AND THE */
/* INTERMEDIATE COMPUTATION FOR THE MAX */
/* NORM OF THE RESIDUAL VECTOR. */
f = (*fnc)(&x[1], &k);
/* Computing MAX */
d__1 = *fmax, d__2 = abs(f);
*fmax = max(d__1,d__2);
/* IF WE WISH TO PERFORM SEVERAL */
/* ITERATIONS USING A FIXED */
/* FACTORIZATION OF AN APPROXIMATE */
/* JACOBIAN,WE NEED ONLY UPDATE THE */
/* CONSTANT VECTOR. */
/* ...EXIT */
if (itry < *ncjs) {
goto L160;
}
it = 0;
/* COMPUTE PARTIAL DERIVATIVES THAT ARE */
/* REQUIRED IN THE LINEARIZATION OF THE */
/* K-TH REDUCED EQUATION */
i__3 = *n;
for (j = k; j <= i__3; ++j) {
item = is[j];
hx = x[item];
h__ = fac[item] * hx;
if (abs(h__) <= zero) {
h__ = fac[item];
}
x[item] = hx + h__;
if (km1 == 0) {
goto L70;
}
y[j] = h__;
dsossl_(&k, n, &j, &y[1], &c__[1], &b[1], &kn);
i__4 = km1;
for (l = 1; l <= i__4; ++l) {
ls = is[l];
x[ls] = temp[ls] + y[l];
/* L60: */
}
L70:
fp = (*fnc)(&x[1], &k);
x[item] = hx;
fdif = fp - f;
if (abs(fdif) > uro * abs(f)) {
goto L80;
}
fdif = 0.;
++it;
L80:
p[j] = fdif / h__;
/* L90: */
}
if (it <= *n - k) {
goto L110;
}
/* ALL COMPUTED PARTIAL DERIVATIVES */
/* OF THE K-TH EQUATION ARE */
/* EFFECTIVELY ZERO.TRY LARGER */
/* PERTURBATIONS OF THE INDEPENDENT */
/* VARIABLES. */
i__3 = *n;
for (j = k; j <= i__3; ++j) {
isj = is[j];
fact = fac[isj] * 100.;
/* ..............................EXIT */
if (fact > 1e10) {
goto L390;
}
fac[isj] = fact;
/* L100: */
}
/* ............EXIT */
goto L180;
L110:
/* ...EXIT */
if (k == *n) {
goto L160;
}
/* ACHIEVE A PIVOTING EFFECT BY */
/* CHOOSING THE MAXIMAL DERIVATIVE */
/* ELEMENT */
pmax = 0.;
i__3 = *n;
for (j = k; j <= i__3; ++j) {
test = (d__1 = p[j], abs(d__1));
if (test <= pmax) {
goto L120;
}
pmax = test;
isv = j;
L120:
/* L130: */
;
}
/* ........................EXIT */
if (pmax == 0.) {
goto L390;
}
/* SET UP THE COEFFICIENTS FOR THE K-TH */
/* ROW OF THE TRIANGULAR LINEAR SYSTEM */
/* AND SAVE THE PARTIAL DERIVATIVE OF */
/* LARGEST MAGNITUDE */
pmax = p[isv];
kk = kn;
i__3 = *n;
for (j = k; j <= i__3; ++j) {
if (j != isv) {
c__[kk] = -p[j] / pmax;
}
++kk;
/* L140: */
}
p[k] = pmax;
/* ...EXIT */
if (isv == k) {
goto L160;
}
/* INTERCHANGE THE TWO COLUMNS OF C */
/* DETERMINED BY THE PIVOTAL STRATEGY */
ksv = is[k];
is[k] = is[isv];
is[isv] = ksv;
kd = isv - k;
kj = k;
i__3 = k;
for (j = 1; j <= i__3; ++j) {
csv = c__[kj];
jk = kj + kd;
c__[kj] = c__[jk];
c__[jk] = csv;
kj = kj + *n - j;
/* L150: */
}
L160:
kn = kn + np1 - k;
/* STORE THE COMPONENTS FOR THE CONSTANT */
/* VECTOR */
b[k] = -f / p[k];
/* L170: */
}
/* ......EXIT */
goto L190;
L180:
goto L30;
L190:
/* ******** */
/* ******** END OF LOOP CREATING THE TRIANGULAR */
/* LINEARIZATION MATRIX */
/* ******** */
/* SOLVE THE RESULTING TRIANGULAR SYSTEM FOR A NEW */
/* SOLUTION APPROXIMATION AND OBTAIN THE SOLUTION */
/* INCREMENT NORM. */
--kn;
y[*n] = b[*n];
if (*n > 1) {
dsossl_(n, n, n, &y[1], &c__[1], &b[1], &kn);
}
xnorm = 0.;
ynorm = 0.;
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
yj = y[j];
/* Computing MAX */
d__1 = ynorm, d__2 = abs(yj);
ynorm = max(d__1,d__2);
js = is[j];
x[js] = temp[js] + yj;
/* Computing MAX */
d__2 = xnorm, d__3 = (d__1 = x[js], abs(d__1));
xnorm = max(d__2,d__3);
/* L200: */
}
/* PRINT INTERMEDIATE SOLUTION ITERATES AND */
/* RESIDUAL NORM IF DESIRED */
if (*iprint != -1) {
goto L220;
}
mm = m - 1;
io___48.ciunit = loun;
s_wsfe(&io___48);
do_fio(&c__1, (char *)&(*fmax), (ftnlen)sizeof(doublereal));
do_fio(&c__1, (char *)&mm, (ftnlen)sizeof(integer));
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
do_fio(&c__1, (char *)&x[j], (ftnlen)sizeof(doublereal));
}
e_wsfe();
L220:
/* TEST FOR CONVERGENCE TO A SOLUTION (RELATIVE */
/* AND/OR ABSOLUTE ERROR COMPARISON ON SUCCESSIVE */
/* APPROXIMATIONS OF EACH SOLUTION VARIABLE) */
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
js = is[j];
/* ......EXIT */
if ((d__2 = y[j], abs(d__2)) > re * (d__1 = x[js], abs(d__1)) + *
atolx) {
goto L240;
}
/* L230: */
}
if (*fmax <= fmxs) {
*iflag = 1;
}
L240:
/* TEST FOR CONVERGENCE TO A SOLUTION BASED ON */
/* RESIDUALS */
if (*fmax <= *tolf) {
*iflag += 2;
}
/* ............EXIT */
if (*iflag > 0) {
goto L410;
}
if (m > 1) {
goto L250;
}
fmin = *fmax;
goto L330;
L250:
/* BEGIN BLOCK PERMITTING ...EXITS TO 320 */
/* SAVE SOLUTION HAVING MINIMUM RESIDUAL NORM. */
if (*fmax >= fmin) {
goto L270;
}
mit = m + 1;
yn1 = ynorm;
yn2 = yns;
fn1 = fmxs;
fmin = *fmax;
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
s[j] = x[j];
/* L260: */
}
ic = 0;
L270:
/* TEST FOR LIMITING PRECISION CONVERGENCE. VERY */
/* SLOWLY CONVERGENT PROBLEMS MAY ALSO BE */
/* DETECTED. */
if (ynorm > sruro * xnorm) {
goto L290;
}
if (*fmax < fmxs * .2 || *fmax > fmxs * 5.) {
goto L290;
}
if (ynorm < yns * .2 || ynorm > yns * 5.) {
goto L290;
}
++icr;
if (icr >= *nsrrc) {
goto L280;
}
ic = 0;
/* .........EXIT */
goto L320;
L280:
*iflag = 4;
*fmax = fmin;
/* ........................EXIT */
goto L430;
L290:
icr = 0;
/* TEST FOR DIVERGENCE OF THE ITERATIVE SCHEME. */
if (ynorm > yns * 2. || *fmax > fmxs * 2.) {
goto L300;
}
ic = 0;
goto L310;
L300:
++ic;
/* ......EXIT */
if (ic < *nsri) {
goto L320;
}
*iflag = 7;
/* .....................EXIT */
goto L410;
L310:
L320:
L330:
/* CHECK TO SEE IF NEXT ITERATION CAN USE THE OLD */
/* JACOBIAN FACTORIZATION */
--itry;
if (itry == 0) {
goto L340;
}
if (ynorm * 20. > xnorm) {
goto L340;
}
if (ynorm > yns * 2.) {
goto L340;
}
/* ......EXIT */
if (*fmax < fmxs * 2.) {
goto L350;
}
L340:
itry = *ncjs;
L350:
/* SAVE THE CURRENT SOLUTION APPROXIMATION AND THE */
/* RESIDUAL AND SOLUTION INCREMENT NORMS FOR USE IN THE */
/* NEXT ITERATION. */
i__2 = *n;
for (j = 1; j <= i__2; ++j) {
temp[j] = x[j];
/* L360: */
}
if (m != mit) {
goto L370;
}
fn2 = *fmax;
yn3 = ynorm;
L370:
fmxs = *fmax;
yns = ynorm;
/* L380: */
}
/* ********************************************************* */
/* **** END OF PRINCIPAL ITERATION LOOP **** */
/* ********************************************************* */
/* TOO MANY ITERATIONS, CONVERGENCE WAS NOT ACHIEVED. */
m = *mxit;
*iflag = 5;
if (yn1 > yn2 * 10. || yn3 > yn1 * 10.) {
*iflag = 6;
}
if (fn1 > fmin * 5. || fn2 > fmin * 5.) {
*iflag = 6;
}
if (*fmax > fmin * 5.) {
*iflag = 6;
}
/* ......EXIT */
goto L410;
L390:
/* A JACOBIAN-RELATED MATRIX IS EFFECTIVELY SINGULAR. */
*iflag = 8;
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
s[j] = temp[j];
/* L400: */
}
/* ......EXIT */
goto L430;
L410:
i__1 = *n;
for (j = 1; j <= i__1; ++j) {
s[j] = x[j];
/* L420: */
}
L430:
*mxit = m;
return 0;
} /* dsoseq_ */
