/* 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_ */