/Users/huttone/Devel/sedflux-new/sedflux/trunk/ew/utils/zbsubs.c

Go to the documentation of this file.
00001 /* zbsubs.f -- translated by f2c (version 20031025).
00002    You must link the resulting object file with libf2c:
00003         on Microsoft Windows system, link with libf2c.lib;
00004         on Linux or Unix systems, link with .../path/to/libf2c.a -lm
00005         or, if you install libf2c.a in a standard place, with -lf2c -lm
00006         -- in that order, at the end of the command line, as in
00007                 cc *.o -lf2c -lm
00008         Source for libf2c is in /netlib/f2c/libf2c.zip, e.g.,
00009 
00010                 http://www.netlib.org/f2c/libf2c.zip
00011 */
00012 
00013 #include <eh_utils.h>
00014 #include <math.h>
00015 #include "f2c.h"
00016 
00017 #define DSIGN(a,b) ( (b>0)?((a)>0?a:-(a)):((a)<=0?a:-(a)))
00018 
00019 /* Table of constant values */
00020 
00021 static integer c__4 = 4;
00022 static integer c__15 = 15;
00023 static integer c__16 = 16;
00024 static integer c__5 = 5;
00025 static integer c__14 = 14;
00026 static integer c__9 = 9;
00027 static integer c__1 = 1;
00028 static integer c__2 = 2;
00029 static doublereal c_b168 = .5;
00030 static doublereal c_b169 = 0.;
00031 static integer c__0 = 0;
00032 
00033 /* *** zbsubs.f */
00034 /* ----------------------------------------------------------------- */
00035 /* >>>  ZBSUBS.FOR:  Double precision subroutines */
00036 /* ----------------------------------------------------------------- */
00037 /* Subroutine */ int zbesh_(doublereal *zr, doublereal *zi, doublereal *fnu, 
00038         integer *kode, integer *m, integer *n, doublereal *cyr, doublereal *
00039         cyi, integer *nz, integer *ierr)
00040 {
00041     /* Initialized data */
00042 
00043     static doublereal hpi = 1.57079632679489662;
00044 
00045     /* System generated locals */
00046     integer i__1, i__2;
00047     doublereal d__1, d__2;
00048 
00049     /* Builtin functions */
00050     double sqrt(doublereal), log(doublereal), d_sign(doublereal *, doublereal 
00051             *), cos(doublereal), sin(doublereal);
00052 
00053     /* Local variables */
00054     static integer i__, k, k1, k2;
00055     static doublereal aa, bb, fn;
00056     static integer mm;
00057     static doublereal az;
00058     static integer ir, nn;
00059     static doublereal rl;
00060     static integer mr, nw;
00061     static doublereal dig, arg, aln, fmm, r1m5, ufl, sgn;
00062     static integer nuf, inu;
00063     static doublereal tol, sti, zni, zti, str, znr, alim, elim;
00064     extern doublereal zabs_(doublereal *, doublereal *);
00065     static doublereal atol, rhpi;
00066     static integer inuh;
00067     static doublereal fnul, rtol, ascle, csgni;
00068     extern /* Subroutine */ int zacon_(doublereal *, doublereal *, doublereal 
00069             *, integer *, integer *, integer *, doublereal *, doublereal *, 
00070             integer *, doublereal *, doublereal *, doublereal *, doublereal *,
00071              doublereal *);
00072     static doublereal csgnr;
00073     extern /* Subroutine */ int zbknu_(doublereal *, doublereal *, doublereal 
00074             *, integer *, integer *, doublereal *, doublereal *, integer *, 
00075             doublereal *, doublereal *, doublereal *), zbunk_(doublereal *, 
00076             doublereal *, doublereal *, integer *, integer *, integer *, 
00077             doublereal *, doublereal *, integer *, doublereal *, doublereal *,
00078              doublereal *);
00079     extern doublereal d1mach_(integer *);
00080     extern /* Subroutine */ int zuoik_(doublereal *, doublereal *, doublereal 
00081             *, integer *, integer *, integer *, doublereal *, doublereal *, 
00082             integer *, doublereal *, doublereal *, doublereal *);
00083     extern integer i1mach_(integer *);
00084 
00085 /* ***BEGIN PROLOGUE  ZBESH */
00086 /* ***DATE WRITTEN   830501   (YYMMDD) */
00087 /* ***REVISION DATE  890801, 930101   (YYMMDD) */
00088 /* ***CATEGORY NO.  B5K */
00089 /* ***KEYWORDS  H-BESSEL FUNCTIONS,BESSEL FUNCTIONS OF COMPLEX ARGUMENT, */
00090 /*             BESSEL FUNCTIONS OF THIRD KIND,HANKEL FUNCTIONS */
00091 /* ***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES */
00092 /* ***PURPOSE  TO COMPUTE THE H-BESSEL FUNCTIONS OF A COMPLEX ARGUMENT */
00093 /* ***DESCRIPTION */
00094 
00095 /*                      ***A DOUBLE PRECISION ROUTINE*** */
00096 /*         ON KODE=1, ZBESH COMPUTES AN N MEMBER SEQUENCE OF COMPLEX */
00097 /*         HANKEL (BESSEL) FUNCTIONS CY(J)=H(M,FNU+J-1,Z) FOR KINDS M=1 */
00098 /*         OR 2, REAL, NONNEGATIVE ORDERS FNU+J-1, J=1,...,N, AND COMPLEX */
00099 /*         Z.NE.CMPLX(0.0,0.0) IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI. */
00100 /*         ON KODE=2, ZBESH RETURNS THE SCALED HANKEL FUNCTIONS */
00101 
00102 /*         CY(I)=EXP(-MM*Z*I)*H(M,FNU+J-1,Z)       MM=3-2*M,   I**2=-1. */
00103 
00104 /*         WHICH REMOVES THE EXPONENTIAL BEHAVIOR IN BOTH THE UPPER AND */
00105 /*         LOWER HALF PLANES. DEFINITIONS AND NOTATION ARE FOUND IN THE */
00106 /*         NBS HANDBOOK OF MATHEMATICAL FUNCTIONS (REF. 1). */
00107 
00108 /*         INPUT      ZR,ZI,FNU ARE DOUBLE PRECISION */
00109 /*           ZR,ZI  - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0), */
00110 /*                    -PT.LT.ARG(Z).LE.PI */
00111 /*           FNU    - ORDER OF INITIAL H FUNCTION, FNU.GE.0.0D0 */
00112 /*           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION */
00113 /*                    KODE= 1  RETURNS */
00114 /*                             CY(J)=H(M,FNU+J-1,Z),   J=1,...,N */
00115 /*                        = 2  RETURNS */
00116 /*                             CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) */
00117 /*                                  J=1,...,N  ,  I**2=-1 */
00118 /*           M      - KIND OF HANKEL FUNCTION, M=1 OR 2 */
00119 /*           N      - NUMBER OF MEMBERS IN THE SEQUENCE, N.GE.1 */
00120 
00121 /*         OUTPUT     CYR,CYI ARE DOUBLE PRECISION */
00122 /*           CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS */
00123 /*                    CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE */
00124 /*                    CY(J)=H(M,FNU+J-1,Z)  OR */
00125 /*                    CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M))  J=1,...,N */
00126 /*                    DEPENDING ON KODE, I**2=-1. */
00127 /*           NZ     - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW, */
00128 /*                    NZ= 0   , NORMAL RETURN */
00129 /*                    NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO DUE */
00130 /*                              TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0) */
00131 /*                              J=1,...,NZ WHEN Y.GT.0.0 AND M=1 OR */
00132 /*                              Y.LT.0.0 AND M=2. FOR THE COMPLMENTARY */
00133 /*                              HALF PLANES, NZ STATES ONLY THE NUMBER */
00134 /*                              OF UNDERFLOWS. */
00135 /*           IERR   - ERROR FLAG */
00136 /*                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED */
00137 /*                    IERR=1, INPUT ERROR   - NO COMPUTATION */
00138 /*                    IERR=2, OVERFLOW      - NO COMPUTATION, FNU TOO */
00139 /*                            LARGE OR CABS(Z) TOO SMALL OR BOTH */
00140 /*                    IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE */
00141 /*                            BUT LOSSES OF SIGNIFCANCE BY ARGUMENT */
00142 /*                            REDUCTION PRODUCE LESS THAN HALF OF MACHINE */
00143 /*                            ACCURACY */
00144 /*                    IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- */
00145 /*                            TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- */
00146 /*                            CANCE BY ARGUMENT REDUCTION */
00147 /*                    IERR=5, ERROR              - NO COMPUTATION, */
00148 /*                            ALGORITHM TERMINATION CONDITION NOT MET */
00149 
00150 /* ***LONG DESCRIPTION */
00151 
00152 /*         THE COMPUTATION IS CARRIED OUT BY THE RELATION */
00153 
00154 /*         H(M,FNU,Z)=(1/MP)*EXP(-MP*FNU)*K(FNU,Z*EXP(-MP)) */
00155 /*             MP=MM*HPI*I,  MM=3-2*M,  HPI=PI/2,  I**2=-1 */
00156 
00157 /*         FOR M=1 OR 2 WHERE THE K BESSEL FUNCTION IS COMPUTED FOR THE */
00158 /*         RIGHT HALF PLANE RE(Z).GE.0.0. THE K FUNCTION IS CONTINUED */
00159 /*         TO THE LEFT HALF PLANE BY THE RELATION */
00160 
00161 /*         K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z) */
00162 /*         MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1 */
00163 
00164 /*         WHERE I(FNU,Z) IS THE I BESSEL FUNCTION. */
00165 
00166 /*         EXPONENTIAL DECAY OF H(M,FNU,Z) OCCURS IN THE UPPER HALF Z */
00167 /*         PLANE FOR M=1 AND THE LOWER HALF Z PLANE FOR M=2.  EXPONENTIAL */
00168 /*         GROWTH OCCURS IN THE COMPLEMENTARY HALF PLANES.  SCALING */
00169 /*         BY EXP(-MM*Z*I) REMOVES THE EXPONENTIAL BEHAVIOR IN THE */
00170 /*         WHOLE Z PLANE FOR Z TO INFINITY. */
00171 
00172 /*         FOR NEGATIVE ORDERS,THE FORMULAE */
00173 
00174 /*               H(1,-FNU,Z) = H(1,FNU,Z)*CEXP( PI*FNU*I) */
00175 /*               H(2,-FNU,Z) = H(2,FNU,Z)*CEXP(-PI*FNU*I) */
00176 /*                         I**2=-1 */
00177 
00178 /*         CAN BE USED. */
00179 
00180 /*         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- */
00181 /*         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS */
00182 /*         LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. */
00183 /*         CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN */
00184 /*         LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG */
00185 /*         IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS */
00186 /*         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. */
00187 /*         IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS */
00188 /*         LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS */
00189 /*         MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE */
00190 /*         INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS */
00191 /*         RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 */
00192 /*         ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION */
00193 /*         ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION */
00194 /*         ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN */
00195 /*         THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT */
00196 /*         TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS */
00197 /*         IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. */
00198 /*         SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. */
00199 
00200 /*         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX */
00201 /*         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT */
00202 /*         ROUNDOFF,1.0D-18) IS THE NOMINAL PRECISION AND 10**S REPRE- */
00203 /*         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE */
00204 /*         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), */
00205 /*         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF */
00206 /*         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY */
00207 /*         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN */
00208 /*         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY */
00209 /*         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER */
00210 /*         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, */
00211 /*         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS */
00212 /*         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER */
00213 /*         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY */
00214 /*         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER */
00215 /*         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE */
00216 /*         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, */
00217 /*         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, */
00218 /*         OR -PI/2+P. */
00219 
00220 /* ***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ */
00221 /*                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF */
00222 /*                 COMMERCE, 1955. */
00223 
00224 /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
00225 /*                 BY D. E. AMOS, SAND83-0083, MAY, 1983. */
00226 
00227 /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
00228 /*                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 */
00229 
00230 /*               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
00231 /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- */
00232 /*                 1018, MAY, 1985 */
00233 
00234 /*               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
00235 /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM */
00236 /*                 TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, */
00237 /*                 PP 265-273. */
00238 
00239 /* ***ROUTINES CALLED  ZACON,ZBKNU,ZBUNK,ZUOIK,ZABS,I1MACH,D1MACH */
00240 /* ***END PROLOGUE  ZBESH */
00241 
00242 /*     COMPLEX CY,Z,ZN,ZT,CSGN */
00243 
00244     /* Parameter adjustments */
00245     --cyi;
00246     --cyr;
00247 
00248     /* Function Body */
00249 
00250 /* ***FIRST EXECUTABLE STATEMENT  ZBESH */
00251     *ierr = 0;
00252     *nz = 0;
00253     if (*zr == 0. && *zi == 0.) {
00254         *ierr = 1;
00255     }
00256     if (*fnu < 0.) {
00257         *ierr = 1;
00258     }
00259     if (*m < 1 || *m > 2) {
00260         *ierr = 1;
00261     }
00262     if (*kode < 1 || *kode > 2) {
00263         *ierr = 1;
00264     }
00265     if (*n < 1) {
00266         *ierr = 1;
00267     }
00268     if (*ierr != 0) {
00269         return 0;
00270     }
00271     nn = *n;
00272 /* ----------------------------------------------------------------------- */
00273 /*     SET PARAMETERS RELATED TO MACHINE CONSTANTS. */
00274 /*     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. */
00275 /*     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. */
00276 /*     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND */
00277 /*     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR */
00278 /*     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. */
00279 /*     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. */
00280 /*     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). */
00281 /*     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU */
00282 /* ----------------------------------------------------------------------- */
00283 /* Computing MAX */
00284     d__1 = d1mach_(&c__4);
00285     tol = max(d__1,1e-18);
00286     k1 = i1mach_(&c__15);
00287     k2 = i1mach_(&c__16);
00288     r1m5 = d1mach_(&c__5);
00289 /* Computing MIN */
00290     i__1 = abs(k1), i__2 = abs(k2);
00291     k = min(i__1,i__2);
00292     elim = ((doublereal) ((real) k) * r1m5 - 3.) * 2.303;
00293     k1 = i1mach_(&c__14) - 1;
00294     aa = r1m5 * (doublereal) ((real) k1);
00295     dig = min(aa,18.);
00296     aa *= 2.303;
00297 /* Computing MAX */
00298     d__1 = -aa;
00299     alim = elim + max(d__1,-41.45);
00300     fnul = (dig - 3.) * 6. + 10.;
00301     rl = dig * 1.2 + 3.;
00302     fn = *fnu + (doublereal) ((real) (nn - 1));
00303     mm = 3 - *m - *m;
00304     fmm = (doublereal) ((real) mm);
00305     znr = fmm * *zi;
00306     zni = -fmm * *zr;
00307 /* ----------------------------------------------------------------------- */
00308 /*     TEST FOR PROPER RANGE */
00309 /* ----------------------------------------------------------------------- */
00310     az = zabs_(zr, zi);
00311     aa = .5 / tol;
00312     bb = (doublereal) ((real) i1mach_(&c__9)) * .5;
00313     aa = min(aa,bb);
00314     if (az > aa) {
00315         goto L260;
00316     }
00317     if (fn > aa) {
00318         goto L260;
00319     }
00320     aa = sqrt(aa);
00321     if (az > aa) {
00322         *ierr = 3;
00323     }
00324     if (fn > aa) {
00325         *ierr = 3;
00326     }
00327 /* ----------------------------------------------------------------------- */
00328 /*     OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE */
00329 /* ----------------------------------------------------------------------- */
00330     ufl = d1mach_(&c__1) * 1e3;
00331     if (az < ufl) {
00332         goto L230;
00333     }
00334     if (*fnu > fnul) {
00335         goto L90;
00336     }
00337     if (fn <= 1.) {
00338         goto L70;
00339     }
00340     if (fn > 2.) {
00341         goto L60;
00342     }
00343     if (az > tol) {
00344         goto L70;
00345     }
00346     arg = az * .5;
00347     aln = -fn * log(arg);
00348     if (aln > elim) {
00349         goto L230;
00350     }
00351     goto L70;
00352 L60:
00353     zuoik_(&znr, &zni, fnu, kode, &c__2, &nn, &cyr[1], &cyi[1], &nuf, &tol, &
00354             elim, &alim);
00355     if (nuf < 0) {
00356         goto L230;
00357     }
00358     *nz += nuf;
00359     nn -= nuf;
00360 /* ----------------------------------------------------------------------- */
00361 /*     HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK */
00362 /*     IF NUF=NN, THEN CY(I)=CZERO FOR ALL I */
00363 /* ----------------------------------------------------------------------- */
00364     if (nn == 0) {
00365         goto L140;
00366     }
00367 L70:
00368     if ( (znr < 0.) || (znr == 0. && zni < 0. && *m == 2) ) {
00369         goto L80;
00370     }
00371 /* ----------------------------------------------------------------------- */
00372 /*     RIGHT HALF PLANE COMPUTATION, XN.GE.0. .AND. (XN.NE.0. .OR. */
00373 /*     YN.GE.0. .OR. M=1) */
00374 /* ----------------------------------------------------------------------- */
00375     zbknu_(&znr, &zni, fnu, kode, &nn, &cyr[1], &cyi[1], nz, &tol, &elim, &
00376             alim);
00377     goto L110;
00378 /* ----------------------------------------------------------------------- */
00379 /*     LEFT HALF PLANE COMPUTATION */
00380 /* ----------------------------------------------------------------------- */
00381 L80:
00382     mr = -mm;
00383     zacon_(&znr, &zni, fnu, kode, &mr, &nn, &cyr[1], &cyi[1], &nw, &rl, &fnul,
00384              &tol, &elim, &alim);
00385     if (nw < 0) {
00386         goto L240;
00387     }
00388     *nz = nw;
00389     goto L110;
00390 L90:
00391 /* ----------------------------------------------------------------------- */
00392 /*     UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL */
00393 /* ----------------------------------------------------------------------- */
00394     mr = 0;
00395     if (znr >= 0. && (znr != 0. || zni >= 0. || *m != 2)) {
00396         goto L100;
00397     }
00398     mr = -mm;
00399     if (znr != 0. || zni >= 0.) {
00400         goto L100;
00401     }
00402     znr = -znr;
00403     zni = -zni;
00404 L100:
00405     zbunk_(&znr, &zni, fnu, kode, &mr, &nn, &cyr[1], &cyi[1], &nw, &tol, &
00406             elim, &alim);
00407     if (nw < 0) {
00408         goto L240;
00409     }
00410     *nz += nw;
00411 L110:
00412 /* ----------------------------------------------------------------------- */
00413 /*     H(M,FNU,Z) = -FMM*(I/HPI)*(ZT**FNU)*K(FNU,-Z*ZT) */
00414 
00415 /*     ZT=EXP(-FMM*HPI*I) = CMPLX(0.0,-FMM), FMM=3-2*M, M=1,2 */
00416 /* ----------------------------------------------------------------------- */
00417     d__1 = -fmm;
00418     sgn = DSIGN(hpi, d__1);
00419 /* ----------------------------------------------------------------------- */
00420 /*     CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE */
00421 /*     WHEN FNU IS LARGE */
00422 /* ----------------------------------------------------------------------- */
00423     inu = (integer) ((real) (*fnu));
00424     inuh = inu / 2;
00425     ir = inu - (inuh << 1);
00426     arg = (*fnu - (doublereal) ((real) (inu - ir))) * sgn;
00427     rhpi = 1. / sgn;
00428 /*     ZNI = RHPI*DCOS(ARG) */
00429 /*     ZNR = -RHPI*DSIN(ARG) */
00430     csgni = rhpi * cos(arg);
00431     csgnr = -rhpi * sin(arg);
00432     if (inuh % 2 == 0) {
00433         goto L120;
00434     }
00435 /*     ZNR = -ZNR */
00436 /*     ZNI = -ZNI */
00437     csgnr = -csgnr;
00438     csgni = -csgni;
00439 L120:
00440     zti = -fmm;
00441     rtol = 1. / tol;
00442     ascle = ufl * rtol;
00443     i__1 = nn;
00444     for (i__ = 1; i__ <= i__1; ++i__) {
00445 /*       STR = CYR(I)*ZNR - CYI(I)*ZNI */
00446 /*       CYI(I) = CYR(I)*ZNI + CYI(I)*ZNR */
00447 /*       CYR(I) = STR */
00448 /*       STR = -ZNI*ZTI */
00449 /*       ZNI = ZNR*ZTI */
00450 /*       ZNR = STR */
00451         aa = cyr[i__];
00452         bb = cyi[i__];
00453         atol = 1.;
00454 /* Computing MAX */
00455         d__1 = abs(aa), d__2 = abs(bb);
00456         if (max(d__1,d__2) > ascle) {
00457             goto L135;
00458         }
00459         aa *= rtol;
00460         bb *= rtol;
00461         atol = tol;
00462 L135:
00463         str = aa * csgnr - bb * csgni;
00464         sti = aa * csgni + bb * csgnr;
00465         cyr[i__] = str * atol;
00466         cyi[i__] = sti * atol;
00467         str = -csgni * zti;
00468         csgni = csgnr * zti;
00469         csgnr = str;
00470 /* L130: */
00471     }
00472     return 0;
00473 L140:
00474     if (znr < 0.) {
00475         goto L230;
00476     }
00477     return 0;
00478 L230:
00479     *nz = 0;
00480     *ierr = 2;
00481     return 0;
00482 L240:
00483     if (nw == -1) {
00484         goto L230;
00485     }
00486     *nz = 0;
00487     *ierr = 5;
00488     return 0;
00489 L260:
00490     *nz = 0;
00491     *ierr = 4;
00492     return 0;
00493 } /* zbesh_ */
00494 
00495 /* Subroutine */ int zbesi_(doublereal *zr, doublereal *zi, doublereal *fnu, 
00496         integer *kode, integer *n, doublereal *cyr, doublereal *cyi, integer *
00497         nz, integer *ierr)
00498 {
00499     /* Initialized data */
00500 
00501     static doublereal pi = 3.14159265358979324;
00502     static doublereal coner = 1.;
00503     static doublereal conei = 0.;
00504 
00505     /* System generated locals */
00506     integer i__1, i__2;
00507     doublereal d__1, d__2;
00508 
00509     /* Builtin functions */
00510     double sqrt(doublereal), cos(doublereal), sin(doublereal);
00511 
00512     /* Local variables */
00513     static integer i__, k, k1, k2;
00514     static doublereal aa, bb, fn, az;
00515     static integer nn;
00516     static doublereal rl, dig, arg, r1m5;
00517     static integer inu;
00518     static doublereal tol, sti, zni, str, znr, alim, elim;
00519     extern doublereal zabs_(doublereal *, doublereal *);
00520     static doublereal atol, fnul, rtol, ascle, csgni, csgnr;
00521     extern /* Subroutine */ int zbinu_(doublereal *, doublereal *, doublereal 
00522             *, integer *, integer *, doublereal *, doublereal *, integer *, 
00523             doublereal *, doublereal *, doublereal *, doublereal *, 
00524             doublereal *);
00525     extern doublereal d1mach_(integer *);
00526     extern integer i1mach_(integer *);
00527 
00528 /* ***BEGIN PROLOGUE  ZBESI */
00529 /* ***DATE WRITTEN   830501   (YYMMDD) */
00530 /* ***REVISION DATE  890801, 930101   (YYMMDD) */
00531 /* ***CATEGORY NO.  B5K */
00532 /* ***KEYWORDS  I-BESSEL FUNCTION,COMPLEX BESSEL FUNCTION, */
00533 /*             MODIFIED BESSEL FUNCTION OF THE FIRST KIND */
00534 /* ***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES */
00535 /* ***PURPOSE  TO COMPUTE I-BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
00536 /* ***DESCRIPTION */
00537 
00538 /*                    ***A DOUBLE PRECISION ROUTINE*** */
00539 /*         ON KODE=1, ZBESI COMPUTES AN N MEMBER SEQUENCE OF COMPLEX */
00540 /*         BESSEL FUNCTIONS CY(J)=I(FNU+J-1,Z) FOR REAL, NONNEGATIVE */
00541 /*         ORDERS FNU+J-1, J=1,...,N AND COMPLEX Z IN THE CUT PLANE */
00542 /*         -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESI RETURNS THE SCALED */
00543 /*         FUNCTIONS */
00544 
00545 /*         CY(J)=EXP(-ABS(X))*I(FNU+J-1,Z)   J = 1,...,N , X=REAL(Z) */
00546 
00547 /*         WITH THE EXPONENTIAL GROWTH REMOVED IN BOTH THE LEFT AND */
00548 /*         RIGHT HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION */
00549 /*         ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS */
00550 /*         (REF. 1). */
00551 
00552 /*         INPUT      ZR,ZI,FNU ARE DOUBLE PRECISION */
00553 /*           ZR,ZI  - Z=CMPLX(ZR,ZI),  -PI.LT.ARG(Z).LE.PI */
00554 /*           FNU    - ORDER OF INITIAL I FUNCTION, FNU.GE.0.0D0 */
00555 /*           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION */
00556 /*                    KODE= 1  RETURNS */
00557 /*                             CY(J)=I(FNU+J-1,Z), J=1,...,N */
00558 /*                        = 2  RETURNS */
00559 /*                             CY(J)=I(FNU+J-1,Z)*EXP(-ABS(X)), J=1,...,N */
00560 /*           N      - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 */
00561 
00562 /*         OUTPUT     CYR,CYI ARE DOUBLE PRECISION */
00563 /*           CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS */
00564 /*                    CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE */
00565 /*                    CY(J)=I(FNU+J-1,Z)  OR */
00566 /*                    CY(J)=I(FNU+J-1,Z)*EXP(-ABS(X))  J=1,...,N */
00567 /*                    DEPENDING ON KODE, X=REAL(Z) */
00568 /*           NZ     - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW, */
00569 /*                    NZ= 0   , NORMAL RETURN */
00570 /*                    NZ.GT.0 , LAST NZ COMPONENTS OF CY SET TO ZERO */
00571 /*                              TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0) */
00572 /*                              J = N-NZ+1,...,N */
00573 /*           IERR   - ERROR FLAG */
00574 /*                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED */
00575 /*                    IERR=1, INPUT ERROR   - NO COMPUTATION */
00576 /*                    IERR=2, OVERFLOW      - NO COMPUTATION, REAL(Z) TOO */
00577 /*                            LARGE ON KODE=1 */
00578 /*                    IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE */
00579 /*                            BUT LOSSES OF SIGNIFCANCE BY ARGUMENT */
00580 /*                            REDUCTION PRODUCE LESS THAN HALF OF MACHINE */
00581 /*                            ACCURACY */
00582 /*                    IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- */
00583 /*                            TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- */
00584 /*                            CANCE BY ARGUMENT REDUCTION */
00585 /*                    IERR=5, ERROR              - NO COMPUTATION, */
00586 /*                            ALGORITHM TERMINATION CONDITION NOT MET */
00587 
00588 /* ***LONG DESCRIPTION */
00589 
00590 /*         THE COMPUTATION IS CARRIED OUT BY THE POWER SERIES FOR */
00591 /*         SMALL CABS(Z), THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z), */
00592 /*         THE MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN AND A */
00593 /*         NEUMANN SERIES FOR IMTERMEDIATE MAGNITUDES, AND THE */
00594 /*         UNIFORM ASYMPTOTIC EXPANSIONS FOR I(FNU,Z) AND J(FNU,Z) */
00595 /*         FOR LARGE ORDERS. BACKWARD RECURRENCE IS USED TO GENERATE */
00596 /*         SEQUENCES OR REDUCE ORDERS WHEN NECESSARY. */
00597 
00598 /*         THE CALCULATIONS ABOVE ARE DONE IN THE RIGHT HALF PLANE AND */
00599 /*         CONTINUED INTO THE LEFT HALF PLANE BY THE FORMULA */
00600 
00601 /*         I(FNU,Z*EXP(M*PI)) = EXP(M*PI*FNU)*I(FNU,Z)  REAL(Z).GT.0.0 */
00602 /*                       M = +I OR -I,  I**2=-1 */
00603 
00604 /*         FOR NEGATIVE ORDERS,THE FORMULA */
00605 
00606 /*              I(-FNU,Z) = I(FNU,Z) + (2/PI)*SIN(PI*FNU)*K(FNU,Z) */
00607 
00608 /*         CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO INTEGERS, THE */
00609 /*         THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE POSITIVE */
00610 /*         INTEGER,THE MAGNITUDE OF I(-FNU,Z)=I(FNU,Z) IS A LARGE */
00611 /*         NEGATIVE POWER OF TEN. BUT WHEN FNU IS NOT AN INTEGER, */
00612 /*         K(FNU,Z) DOMINATES IN MAGNITUDE WITH A LARGE POSITIVE POWER OF */
00613 /*         TEN AND THE MOST THAT THE SECOND TERM CAN BE REDUCED IS BY */
00614 /*         UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, WIDE CHANGES CAN */
00615 /*         OCCUR WITHIN UNIT ROUNDOFF OF A LARGE INTEGER FOR FNU. HERE, */
00616 /*         LARGE MEANS FNU.GT.CABS(Z). */
00617 
00618 /*         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- */
00619 /*         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS */
00620 /*         LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. */
00621 /*         CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN */
00622 /*         LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG */
00623 /*         IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS */
00624 /*         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. */
00625 /*         IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS */
00626 /*         LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS */
00627 /*         MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE */
00628 /*         INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS */
00629 /*         RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 */
00630 /*         ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION */
00631 /*         ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION */
00632 /*         ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN */
00633 /*         THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT */
00634 /*         TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS */
00635 /*         IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. */
00636 /*         SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. */
00637 
00638 /*         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX */
00639 /*         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT */
00640 /*         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- */
00641 /*         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE */
00642 /*         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), */
00643 /*         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF */
00644 /*         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY */
00645 /*         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN */
00646 /*         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY */
00647 /*         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER */
00648 /*         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, */
00649 /*         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS */
00650 /*         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER */
00651 /*         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY */
00652 /*         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER */
00653 /*         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE */
00654 /*         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, */
00655 /*         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, */
00656 /*         OR -PI/2+P. */
00657 
00658 /* ***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ */
00659 /*                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF */
00660 /*                 COMMERCE, 1955. */
00661 
00662 /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
00663 /*                 BY D. E. AMOS, SAND83-0083, MAY, 1983. */
00664 
00665 /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
00666 /*                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 */
00667 
00668 /*               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
00669 /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- */
00670 /*                 1018, MAY, 1985 */
00671 
00672 /*               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
00673 /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM */
00674 /*                 TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, */
00675 /*                 PP 265-273. */
00676 
00677 /* ***ROUTINES CALLED  ZBINU,ZABS,I1MACH,D1MACH */
00678 /* ***END PROLOGUE  ZBESI */
00679 /*     COMPLEX CONE,CSGN,CW,CY,CZERO,Z,ZN */
00680     /* Parameter adjustments */
00681     --cyi;
00682     --cyr;
00683 
00684     /* Function Body */
00685 
00686 /* ***FIRST EXECUTABLE STATEMENT  ZBESI */
00687     *ierr = 0;
00688     *nz = 0;
00689     if (*fnu < 0.) {
00690         *ierr = 1;
00691     }
00692     if (*kode < 1 || *kode > 2) {
00693         *ierr = 1;
00694     }
00695     if (*n < 1) {
00696         *ierr = 1;
00697     }
00698     if (*ierr != 0) {
00699         return 0;
00700     }
00701 /* ----------------------------------------------------------------------- */
00702 /*     SET PARAMETERS RELATED TO MACHINE CONSTANTS. */
00703 /*     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. */
00704 /*     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. */
00705 /*     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND */
00706 /*     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR */
00707 /*     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. */
00708 /*     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. */
00709 /*     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). */
00710 /*     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. */
00711 /* ----------------------------------------------------------------------- */
00712 /* Computing MAX */
00713     d__1 = d1mach_(&c__4);
00714     tol = max(d__1,1e-18);
00715     k1 = i1mach_(&c__15);
00716     k2 = i1mach_(&c__16);
00717     r1m5 = d1mach_(&c__5);
00718 /* Computing MIN */
00719     i__1 = abs(k1), i__2 = abs(k2);
00720     k = min(i__1,i__2);
00721     elim = ((doublereal) ((real) k) * r1m5 - 3.) * 2.303;
00722     k1 = i1mach_(&c__14) - 1;
00723     aa = r1m5 * (doublereal) ((real) k1);
00724     dig = min(aa,18.);
00725     aa *= 2.303;
00726 /* Computing MAX */
00727     d__1 = -aa;
00728     alim = elim + max(d__1,-41.45);
00729     rl = dig * 1.2 + 3.;
00730     fnul = (dig - 3.) * 6. + 10.;
00731 /* ----------------------------------------------------------------------------- */
00732 /*     TEST FOR PROPER RANGE */
00733 /* ----------------------------------------------------------------------- */
00734     az = zabs_(zr, zi);
00735     fn = *fnu + (doublereal) ((real) (*n - 1));
00736     aa = .5 / tol;
00737     bb = (doublereal) ((real) i1mach_(&c__9)) * .5;
00738     aa = min(aa,bb);
00739     if (az > aa) {
00740         goto L260;
00741     }
00742     if (fn > aa) {
00743         goto L260;
00744     }
00745     aa = sqrt(aa);
00746     if (az > aa) {
00747         *ierr = 3;
00748     }
00749     if (fn > aa) {
00750         *ierr = 3;
00751     }
00752     znr = *zr;
00753     zni = *zi;
00754     csgnr = coner;
00755     csgni = conei;
00756     if (*zr >= 0.) {
00757         goto L40;
00758     }
00759     znr = -(*zr);
00760     zni = -(*zi);
00761 /* ----------------------------------------------------------------------- */
00762 /*     CALCULATE CSGN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE */
00763 /*     WHEN FNU IS LARGE */
00764 /* ----------------------------------------------------------------------- */
00765     inu = (integer) ((real) (*fnu));
00766     arg = (*fnu - (doublereal) ((real) inu)) * pi;
00767     if (*zi < 0.) {
00768         arg = -arg;
00769     }
00770     csgnr = cos(arg);
00771     csgni = sin(arg);
00772     if (inu % 2 == 0) {
00773         goto L40;
00774     }
00775     csgnr = -csgnr;
00776     csgni = -csgni;
00777 L40:
00778     zbinu_(&znr, &zni, fnu, kode, n, &cyr[1], &cyi[1], nz, &rl, &fnul, &tol, &
00779             elim, &alim);
00780     if (*nz < 0) {
00781         goto L120;
00782     }
00783     if (*zr >= 0.) {
00784         return 0;
00785     }
00786 /* ----------------------------------------------------------------------- */
00787 /*     ANALYTIC CONTINUATION TO THE LEFT HALF PLANE */
00788 /* ----------------------------------------------------------------------- */
00789     nn = *n - *nz;
00790     if (nn == 0) {
00791         return 0;
00792     }
00793     rtol = 1. / tol;
00794     ascle = d1mach_(&c__1) * rtol * 1e3;
00795     i__1 = nn;
00796     for (i__ = 1; i__ <= i__1; ++i__) {
00797 /*       STR = CYR(I)*CSGNR - CYI(I)*CSGNI */
00798 /*       CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR */
00799 /*       CYR(I) = STR */
00800         aa = cyr[i__];
00801         bb = cyi[i__];
00802         atol = 1.;
00803 /* Computing MAX */
00804         d__1 = abs(aa), d__2 = abs(bb);
00805         if (max(d__1,d__2) > ascle) {
00806             goto L55;
00807         }
00808         aa *= rtol;
00809         bb *= rtol;
00810         atol = tol;
00811 L55:
00812         str = aa * csgnr - bb * csgni;
00813         sti = aa * csgni + bb * csgnr;
00814         cyr[i__] = str * atol;
00815         cyi[i__] = sti * atol;
00816         csgnr = -csgnr;
00817         csgni = -csgni;
00818 /* L50: */
00819     }
00820     return 0;
00821 L120:
00822     if (*nz == -2) {
00823         goto L130;
00824     }
00825     *nz = 0;
00826     *ierr = 2;
00827     return 0;
00828 L130:
00829     *nz = 0;
00830     *ierr = 5;
00831     return 0;
00832 L260:
00833     *nz = 0;
00834     *ierr = 4;
00835     return 0;
00836 } /* zbesi_ */
00837 
00838 /* Subroutine */ int zbesj_(doublereal *zr, doublereal *zi, doublereal *fnu, 
00839         integer *kode, integer *n, doublereal *cyr, doublereal *cyi, integer *
00840         nz, integer *ierr)
00841 {
00842     /* Initialized data */
00843 
00844     static doublereal hpi = 1.57079632679489662;
00845 
00846     /* System generated locals */
00847     integer i__1, i__2;
00848     doublereal d__1, d__2;
00849 
00850     /* Builtin functions */
00851     double sqrt(doublereal), cos(doublereal), sin(doublereal);
00852 
00853     /* Local variables */
00854     static integer i__, k, k1, k2;
00855     static doublereal aa, bb, fn;
00856     static integer nl;
00857     static doublereal az;
00858     static integer ir;
00859     static doublereal rl, dig, cii, arg, r1m5;
00860     static integer inu;
00861     static doublereal tol, sti, zni, str, znr, alim, elim;
00862     extern doublereal zabs_(doublereal *, doublereal *);
00863     static doublereal atol;
00864     static integer inuh;
00865     static doublereal fnul, rtol, ascle, csgni, csgnr;
00866     extern /* Subroutine */ int zbinu_(doublereal *, doublereal *, doublereal 
00867             *, integer *, integer *, doublereal *, doublereal *, integer *, 
00868             doublereal *, doublereal *, doublereal *, doublereal *, 
00869             doublereal *);
00870     extern doublereal d1mach_(integer *);
00871     extern integer i1mach_(integer *);
00872 
00873 /* ***BEGIN PROLOGUE  ZBESJ */
00874 /* ***DATE WRITTEN   830501   (YYMMDD) */
00875 /* ***REVISION DATE  890801, 930101   (YYMMDD) */
00876 /* ***CATEGORY NO.  B5K */
00877 /* ***KEYWORDS  J-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT, */
00878 /*             BESSEL FUNCTION OF FIRST KIND */
00879 /* ***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES */
00880 /* ***PURPOSE  TO COMPUTE THE J-BESSEL FUNCTION OF A COMPLEX ARGUMENT */
00881 /* ***DESCRIPTION */
00882 
00883 /*                      ***A DOUBLE PRECISION ROUTINE*** */
00884 /*         ON KODE=1, ZBESJ COMPUTES AN N MEMBER  SEQUENCE OF COMPLEX */
00885 /*         BESSEL FUNCTIONS CY(I)=J(FNU+I-1,Z) FOR REAL, NONNEGATIVE */
00886 /*         ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE */
00887 /*         -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESJ RETURNS THE SCALED */
00888 /*         FUNCTIONS */
00889 
00890 /*         CY(I)=EXP(-ABS(Y))*J(FNU+I-1,Z)   I = 1,...,N , Y=AIMAG(Z) */
00891 
00892 /*         WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND */
00893 /*         LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION */
00894 /*         ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS */
00895 /*         (REF. 1). */
00896 
00897 /*         INPUT      ZR,ZI,FNU ARE DOUBLE PRECISION */
00898 /*           ZR,ZI  - Z=CMPLX(ZR,ZI),  -PI.LT.ARG(Z).LE.PI */
00899 /*           FNU    - ORDER OF INITIAL J FUNCTION, FNU.GE.0.0D0 */
00900 /*           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION */
00901 /*                    KODE= 1  RETURNS */
00902 /*                             CY(I)=J(FNU+I-1,Z), I=1,...,N */
00903 /*                        = 2  RETURNS */
00904 /*                             CY(I)=J(FNU+I-1,Z)EXP(-ABS(Y)), I=1,...,N */
00905 /*           N      - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 */
00906 
00907 /*         OUTPUT     CYR,CYI ARE DOUBLE PRECISION */
00908 /*           CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS */
00909 /*                    CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE */
00910 /*                    CY(I)=J(FNU+I-1,Z)  OR */
00911 /*                    CY(I)=J(FNU+I-1,Z)EXP(-ABS(Y))  I=1,...,N */
00912 /*                    DEPENDING ON KODE, Y=AIMAG(Z). */
00913 /*           NZ     - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW, */
00914 /*                    NZ= 0   , NORMAL RETURN */
00915 /*                    NZ.GT.0 , LAST NZ COMPONENTS OF CY SET  ZERO DUE */
00916 /*                              TO UNDERFLOW, CY(I)=CMPLX(0.0D0,0.0D0), */
00917 /*                              I = N-NZ+1,...,N */
00918 /*           IERR   - ERROR FLAG */
00919 /*                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED */
00920 /*                    IERR=1, INPUT ERROR   - NO COMPUTATION */
00921 /*                    IERR=2, OVERFLOW      - NO COMPUTATION, AIMAG(Z) */
00922 /*                            TOO LARGE ON KODE=1 */
00923 /*                    IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE */
00924 /*                            BUT LOSSES OF SIGNIFCANCE BY ARGUMENT */
00925 /*                            REDUCTION PRODUCE LESS THAN HALF OF MACHINE */
00926 /*                            ACCURACY */
00927 /*                    IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- */
00928 /*                            TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- */
00929 /*                            CANCE BY ARGUMENT REDUCTION */
00930 /*                    IERR=5, ERROR              - NO COMPUTATION, */
00931 /*                            ALGORITHM TERMINATION CONDITION NOT MET */
00932 
00933 /* ***LONG DESCRIPTION */
00934 
00935 /*         THE COMPUTATION IS CARRIED OUT BY THE FORMULA */
00936 
00937 /*         J(FNU,Z)=EXP( FNU*PI*I/2)*I(FNU,-I*Z)    AIMAG(Z).GE.0.0 */
00938 
00939 /*         J(FNU,Z)=EXP(-FNU*PI*I/2)*I(FNU, I*Z)    AIMAG(Z).LT.0.0 */
00940 
00941 /*         WHERE I**2 = -1 AND I(FNU,Z) IS THE I BESSEL FUNCTION. */
00942 
00943 /*         FOR NEGATIVE ORDERS,THE FORMULA */
00944 
00945 /*              J(-FNU,Z) = J(FNU,Z)*COS(PI*FNU) - Y(FNU,Z)*SIN(PI*FNU) */
00946 
00947 /*         CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO INTEGERS, THE */
00948 /*         THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE POSITIVE */
00949 /*         INTEGER,THE MAGNITUDE OF J(-FNU,Z)=J(FNU,Z)*COS(PI*FNU) IS A */
00950 /*         LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS NOT AN INTEGER, */
00951 /*         Y(FNU,Z) DOMINATES IN MAGNITUDE WITH A LARGE POSITIVE POWER OF */
00952 /*         TEN AND THE MOST THAT THE SECOND TERM CAN BE REDUCED IS BY */
00953 /*         UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, WIDE CHANGES CAN */
00954 /*         OCCUR WITHIN UNIT ROUNDOFF OF A LARGE INTEGER FOR FNU. HERE, */
00955 /*         LARGE MEANS FNU.GT.CABS(Z). */
00956 
00957 /*         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- */
00958 /*         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS */
00959 /*         LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. */
00960 /*         CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN */
00961 /*         LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG */
00962 /*         IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS */
00963 /*         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. */
00964 /*         IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS */
00965 /*         LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS */
00966 /*         MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE */
00967 /*         INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS */
00968 /*         RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 */
00969 /*         ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION */
00970 /*         ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION */
00971 /*         ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN */
00972 /*         THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT */
00973 /*         TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS */
00974 /*         IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. */
00975 /*         SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. */
00976 
00977 /*         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX */
00978 /*         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT */
00979 /*         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- */
00980 /*         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE */
00981 /*         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), */
00982 /*         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF */
00983 /*         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY */
00984 /*         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN */
00985 /*         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY */
00986 /*         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER */
00987 /*         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, */
00988 /*         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS */
00989 /*         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER */
00990 /*         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY */
00991 /*         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER */
00992 /*         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE */
00993 /*         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, */
00994 /*         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, */
00995 /*         OR -PI/2+P. */
00996 
00997 /* ***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ */
00998 /*                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF */
00999 /*                 COMMERCE, 1955. */
01000 
01001 /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
01002 /*                 BY D. E. AMOS, SAND83-0083, MAY, 1983. */
01003 
01004 /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
01005 /*                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 */
01006 
01007 /*               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
01008 /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- */
01009 /*                 1018, MAY, 1985 */
01010 
01011 /*               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
01012 /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM */
01013 /*                 TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, */
01014 /*                 PP 265-273. */
01015 
01016 /* ***ROUTINES CALLED  ZBINU,ZABS,I1MACH,D1MACH */
01017 /* ***END PROLOGUE  ZBESJ */
01018 
01019 /*     COMPLEX CI,CSGN,CY,Z,ZN */
01020     /* Parameter adjustments */
01021     --cyi;
01022     --cyr;
01023 
01024     /* Function Body */
01025 
01026 /* ***FIRST EXECUTABLE STATEMENT  ZBESJ */
01027     *ierr = 0;
01028     *nz = 0;
01029     if (*fnu < 0.) {
01030         *ierr = 1;
01031     }
01032     if (*kode < 1 || *kode > 2) {
01033         *ierr = 1;
01034     }
01035     if (*n < 1) {
01036         *ierr = 1;
01037     }
01038     if (*ierr != 0) {
01039         return 0;
01040     }
01041 /* ----------------------------------------------------------------------- */
01042 /*     SET PARAMETERS RELATED TO MACHINE CONSTANTS. */
01043 /*     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. */
01044 /*     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. */
01045 /*     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND */
01046 /*     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR */
01047 /*     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. */
01048 /*     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. */
01049 /*     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). */
01050 /*     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. */
01051 /* ----------------------------------------------------------------------- */
01052 /* Computing MAX */
01053     d__1 = d1mach_(&c__4);
01054     tol = max(d__1,1e-18);
01055     k1 = i1mach_(&c__15);
01056     k2 = i1mach_(&c__16);
01057     r1m5 = d1mach_(&c__5);
01058 /* Computing MIN */
01059     i__1 = abs(k1), i__2 = abs(k2);
01060     k = min(i__1,i__2);
01061     elim = ((doublereal) ((real) k) * r1m5 - 3.) * 2.303;
01062     k1 = i1mach_(&c__14) - 1;
01063     aa = r1m5 * (doublereal) ((real) k1);
01064     dig = min(aa,18.);
01065     aa *= 2.303;
01066 /* Computing MAX */
01067     d__1 = -aa;
01068     alim = elim + max(d__1,-41.45);
01069     rl = dig * 1.2 + 3.;
01070     fnul = (dig - 3.) * 6. + 10.;
01071 /* ----------------------------------------------------------------------- */
01072 /*     TEST FOR PROPER RANGE */
01073 /* ----------------------------------------------------------------------- */
01074     az = zabs_(zr, zi);
01075     fn = *fnu + (doublereal) ((real) (*n - 1));
01076     aa = .5 / tol;
01077     bb = (doublereal) ((real) i1mach_(&c__9)) * .5;
01078     aa = min(aa,bb);
01079     if (az > aa) {
01080         goto L260;
01081     }
01082     if (fn > aa) {
01083         goto L260;
01084     }
01085     aa = sqrt(aa);
01086     if (az > aa) {
01087         *ierr = 3;
01088     }
01089     if (fn > aa) {
01090         *ierr = 3;
01091     }
01092 /* ----------------------------------------------------------------------- */
01093 /*     CALCULATE CSGN=EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE */
01094 /*     WHEN FNU IS LARGE */
01095 /* ----------------------------------------------------------------------- */
01096     cii = 1.;
01097     inu = (integer) ((real) (*fnu));
01098     inuh = inu / 2;
01099     ir = inu - (inuh << 1);
01100     arg = (*fnu - (doublereal) ((real) (inu - ir))) * hpi;
01101     csgnr = cos(arg);
01102     csgni = sin(arg);
01103     if (inuh % 2 == 0) {
01104         goto L40;
01105     }
01106     csgnr = -csgnr;
01107     csgni = -csgni;
01108 L40:
01109 /* ----------------------------------------------------------------------- */
01110 /*     ZN IS IN THE RIGHT HALF PLANE */
01111 /* ----------------------------------------------------------------------- */
01112     znr = *zi;
01113     zni = -(*zr);
01114     if (*zi >= 0.) {
01115         goto L50;
01116     }
01117     znr = -znr;
01118     zni = -zni;
01119     csgni = -csgni;
01120     cii = -cii;
01121 L50:
01122     zbinu_(&znr, &zni, fnu, kode, n, &cyr[1], &cyi[1], nz, &rl, &fnul, &tol, &
01123             elim, &alim);
01124     if (*nz < 0) {
01125         goto L130;
01126     }
01127     nl = *n - *nz;
01128     if (nl == 0) {
01129         return 0;
01130     }
01131     rtol = 1. / tol;
01132     ascle = d1mach_(&c__1) * rtol * 1e3;
01133     i__1 = nl;
01134     for (i__ = 1; i__ <= i__1; ++i__) {
01135 /*       STR = CYR(I)*CSGNR - CYI(I)*CSGNI */
01136 /*       CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR */
01137 /*       CYR(I) = STR */
01138         aa = cyr[i__];
01139         bb = cyi[i__];
01140         atol = 1.;
01141 /* Computing MAX */
01142         d__1 = abs(aa), d__2 = abs(bb);
01143         if (max(d__1,d__2) > ascle) {
01144             goto L55;
01145         }
01146         aa *= rtol;
01147         bb *= rtol;
01148         atol = tol;
01149 L55:
01150         str = aa * csgnr - bb * csgni;
01151         sti = aa * csgni + bb * csgnr;
01152         cyr[i__] = str * atol;
01153         cyi[i__] = sti * atol;
01154         str = -csgni * cii;
01155         csgni = csgnr * cii;
01156         csgnr = str;
01157 /* L60: */
01158     }
01159     return 0;
01160 L130:
01161     if (*nz == -2) {
01162         goto L140;
01163     }
01164     *nz = 0;
01165     *ierr = 2;
01166     return 0;
01167 L140:
01168     *nz = 0;
01169     *ierr = 5;
01170     return 0;
01171 L260:
01172     *nz = 0;
01173     *ierr = 4;
01174     return 0;
01175 } /* zbesj_ */
01176 
01177 /* Subroutine */ int zbesk_(doublereal *zr, doublereal *zi, doublereal *fnu, 
01178         integer *kode, integer *n, doublereal *cyr, doublereal *cyi, integer *
01179         nz, integer *ierr)
01180 {
01181     /* System generated locals */
01182     integer i__1, i__2;
01183     doublereal d__1;
01184 
01185     /* Builtin functions */
01186     double sqrt(doublereal), log(doublereal);
01187 
01188     /* Local variables */
01189     static integer k, k1, k2;
01190     static doublereal aa, bb, fn, az;
01191     static integer nn;
01192     static doublereal rl;
01193     static integer mr, nw;
01194     static doublereal dig, arg, aln, r1m5, ufl;
01195     static integer nuf;
01196     static doublereal tol, alim, elim;
01197     extern doublereal zabs_(doublereal *, doublereal *);
01198     static doublereal fnul;
01199     extern /* Subroutine */ int zacon_(doublereal *, doublereal *, doublereal 
01200             *, integer *, integer *, integer *, doublereal *, doublereal *, 
01201             integer *, doublereal *, doublereal *, doublereal *, doublereal *,
01202              doublereal *), zbknu_(doublereal *, doublereal *, doublereal *, 
01203             integer *, integer *, doublereal *, doublereal *, integer *, 
01204             doublereal *, doublereal *, doublereal *), zbunk_(doublereal *, 
01205             doublereal *, doublereal *, integer *, integer *, integer *, 
01206             doublereal *, doublereal *, integer *, doublereal *, doublereal *,
01207              doublereal *);
01208     extern doublereal d1mach_(integer *);
01209     extern /* Subroutine */ int zuoik_(doublereal *, doublereal *, doublereal 
01210             *, integer *, integer *, integer *, doublereal *, doublereal *, 
01211             integer *, doublereal *, doublereal *, doublereal *);
01212     extern integer i1mach_(integer *);
01213 
01214 /* ***BEGIN PROLOGUE  ZBESK */
01215 /* ***DATE WRITTEN   830501   (YYMMDD) */
01216 /* ***REVISION DATE  890801, 930101   (YYMMDD) */
01217 /* ***CATEGORY NO.  B5K */
01218 /* ***KEYWORDS  K-BESSEL FUNCTION,COMPLEX BESSEL FUNCTION, */
01219 /*             MODIFIED BESSEL FUNCTION OF THE SECOND KIND, */
01220 /*             BESSEL FUNCTION OF THE THIRD KIND */
01221 /* ***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES */
01222 /* ***PURPOSE  TO COMPUTE K-BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
01223 /* ***DESCRIPTION */
01224 
01225 /*                      ***A DOUBLE PRECISION ROUTINE*** */
01226 
01227 /*         ON KODE=1, ZBESK COMPUTES AN N MEMBER SEQUENCE OF COMPLEX */
01228 /*         BESSEL FUNCTIONS CY(J)=K(FNU+J-1,Z) FOR REAL, NONNEGATIVE */
01229 /*         ORDERS FNU+J-1, J=1,...,N AND COMPLEX Z.NE.CMPLX(0.0,0.0) */
01230 /*         IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESK */
01231 /*         RETURNS THE SCALED K FUNCTIONS, */
01232 
01233 /*         CY(J)=EXP(Z)*K(FNU+J-1,Z) , J=1,...,N, */
01234 
01235 /*         WHICH REMOVE THE EXPONENTIAL BEHAVIOR IN BOTH THE LEFT AND */
01236 /*         RIGHT HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND */
01237 /*         NOTATION ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL */
01238 /*         FUNCTIONS (REF. 1). */
01239 
01240 /*         INPUT      ZR,ZI,FNU ARE DOUBLE PRECISION */
01241 /*           ZR,ZI  - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0), */
01242 /*                    -PI.LT.ARG(Z).LE.PI */
01243 /*           FNU    - ORDER OF INITIAL K FUNCTION, FNU.GE.0.0D0 */
01244 /*           N      - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 */
01245 /*           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION */
01246 /*                    KODE= 1  RETURNS */
01247 /*                             CY(I)=K(FNU+I-1,Z), I=1,...,N */
01248 /*                        = 2  RETURNS */
01249 /*                             CY(I)=K(FNU+I-1,Z)*EXP(Z), I=1,...,N */
01250 
01251 /*         OUTPUT     CYR,CYI ARE DOUBLE PRECISION */
01252 /*           CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS */
01253 /*                    CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE */
01254 /*                    CY(I)=K(FNU+I-1,Z), I=1,...,N OR */
01255 /*                    CY(I)=K(FNU+I-1,Z)*EXP(Z), I=1,...,N */
01256 /*                    DEPENDING ON KODE */
01257 /*           NZ     - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW. */
01258 /*                    NZ= 0   , NORMAL RETURN */
01259 /*                    NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO DUE */
01260 /*                              TO UNDERFLOW, CY(I)=CMPLX(0.0D0,0.0D0), */
01261 /*                              I=1,...,N WHEN X.GE.0.0. WHEN X.LT.0.0 */
01262 /*                              NZ STATES ONLY THE NUMBER OF UNDERFLOWS */
01263 /*                              IN THE SEQUENCE. */
01264 
01265 /*           IERR   - ERROR FLAG */
01266 /*                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED */
01267 /*                    IERR=1, INPUT ERROR   - NO COMPUTATION */
01268 /*                    IERR=2, OVERFLOW      - NO COMPUTATION, FNU IS */
01269 /*                            TOO LARGE OR CABS(Z) IS TOO SMALL OR BOTH */
01270 /*                    IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE */
01271 /*                            BUT LOSSES OF SIGNIFCANCE BY ARGUMENT */
01272 /*                            REDUCTION PRODUCE LESS THAN HALF OF MACHINE */
01273 /*                            ACCURACY */
01274 /*                    IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- */
01275 /*                            TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- */
01276 /*                            CANCE BY ARGUMENT REDUCTION */
01277 /*                    IERR=5, ERROR              - NO COMPUTATION, */
01278 /*                            ALGORITHM TERMINATION CONDITION NOT MET */
01279 
01280 /* ***LONG DESCRIPTION */
01281 
01282 /*         EQUATIONS OF THE REFERENCE ARE IMPLEMENTED FOR SMALL ORDERS */
01283 /*         DNU AND DNU+1.0 IN THE RIGHT HALF PLANE X.GE.0.0. FORWARD */
01284 /*         RECURRENCE GENERATES HIGHER ORDERS. K IS CONTINUED TO THE LEFT */
01285 /*         HALF PLANE BY THE RELATION */
01286 
01287 /*         K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z) */
01288 /*         MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1 */
01289 
01290 /*         WHERE I(FNU,Z) IS THE I BESSEL FUNCTION. */
01291 
01292 /*         FOR LARGE ORDERS, FNU.GT.FNUL, THE K FUNCTION IS COMPUTED */
01293 /*         BY MEANS OF ITS UNIFORM ASYMPTOTIC EXPANSIONS. */
01294 
01295 /*         FOR NEGATIVE ORDERS, THE FORMULA */
01296 
01297 /*                       K(-FNU,Z) = K(FNU,Z) */
01298 
01299 /*         CAN BE USED. */
01300 
01301 /*         ZBESK ASSUMES THAT A SIGNIFICANT DIGIT SINH(X) FUNCTION IS */
01302 /*         AVAILABLE. */
01303 
01304 /*         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- */
01305 /*         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS */
01306 /*         LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. */
01307 /*         CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN */
01308 /*         LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG */
01309 /*         IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS */
01310 /*         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. */
01311 /*         IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS */
01312 /*         LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS */
01313 /*         MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE */
01314 /*         INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS */
01315 /*         RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 */
01316 /*         ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION */
01317 /*         ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION */
01318 /*         ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN */
01319 /*         THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT */
01320 /*         TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS */
01321 /*         IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. */
01322 /*         SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. */
01323 
01324 /*         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX */
01325 /*         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT */
01326 /*         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- */
01327 /*         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE */
01328 /*         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), */
01329 /*         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF */
01330 /*         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY */
01331 /*         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN */
01332 /*         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY */
01333 /*         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER */
01334 /*         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, */
01335 /*         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS */
01336 /*         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER */
01337 /*         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY */
01338 /*         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER */
01339 /*         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE */
01340 /*         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, */
01341 /*         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, */
01342 /*         OR -PI/2+P. */
01343 
01344 /* ***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ */
01345 /*                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF */
01346 /*                 COMMERCE, 1955. */
01347 
01348 /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
01349 /*                 BY D. E. AMOS, SAND83-0083, MAY, 1983. */
01350 
01351 /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
01352 /*                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983. */
01353 
01354 /*               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
01355 /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- */
01356 /*                 1018, MAY, 1985 */
01357 
01358 /*               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
01359 /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM */
01360 /*                 TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, */
01361 /*                 PP 265-273. */
01362 
01363 /* ***ROUTINES CALLED  ZACON,ZBKNU,ZBUNK,ZUOIK,ZABS,I1MACH,D1MACH */
01364 /* ***END PROLOGUE  ZBESK */
01365 
01366 /*     COMPLEX CY,Z */
01367 /* ***FIRST EXECUTABLE STATEMENT  ZBESK */
01368     /* Parameter adjustments */
01369     --cyi;
01370     --cyr;
01371 
01372     /* Function Body */
01373     *ierr = 0;
01374     *nz = 0;
01375     if (*zi == 0.f && *zr == 0.f) {
01376         *ierr = 1;
01377     }
01378     if (*fnu < 0.) {
01379         *ierr = 1;
01380     }
01381     if (*kode < 1 || *kode > 2) {
01382         *ierr = 1;
01383     }
01384     if (*n < 1) {
01385         *ierr = 1;
01386     }
01387     if (*ierr != 0) {
01388         return 0;
01389     }
01390     nn = *n;
01391 /* ----------------------------------------------------------------------- */
01392 /*     SET PARAMETERS RELATED TO MACHINE CONSTANTS. */
01393 /*     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. */
01394 /*     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. */
01395 /*     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND */
01396 /*     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR */
01397 /*     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. */
01398 /*     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. */
01399 /*     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). */
01400 /*     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU */
01401 /* ----------------------------------------------------------------------- */
01402 /* Computing MAX */
01403     d__1 = d1mach_(&c__4);
01404     tol = max(d__1,1e-18);
01405     k1 = i1mach_(&c__15);
01406     k2 = i1mach_(&c__16);
01407     r1m5 = d1mach_(&c__5);
01408 /* Computing MIN */
01409     i__1 = abs(k1), i__2 = abs(k2);
01410     k = min(i__1,i__2);
01411     elim = ((doublereal) ((real) k) * r1m5 - 3.) * 2.303;
01412     k1 = i1mach_(&c__14) - 1;
01413     aa = r1m5 * (doublereal) ((real) k1);
01414     dig = min(aa,18.);
01415     aa *= 2.303;
01416 /* Computing MAX */
01417     d__1 = -aa;
01418     alim = elim + max(d__1,-41.45);
01419     fnul = (dig - 3.) * 6. + 10.;
01420     rl = dig * 1.2 + 3.;
01421 /* ----------------------------------------------------------------------------- */
01422 /*     TEST FOR PROPER RANGE */
01423 /* ----------------------------------------------------------------------- */
01424     az = zabs_(zr, zi);
01425     fn = *fnu + (doublereal) ((real) (nn - 1));
01426     aa = .5 / tol;
01427     bb = (doublereal) ((real) i1mach_(&c__9)) * .5;
01428     aa = min(aa,bb);
01429     if (az > aa) {
01430         goto L260;
01431     }
01432     if (fn > aa) {
01433         goto L260;
01434     }
01435     aa = sqrt(aa);
01436     if (az > aa) {
01437         *ierr = 3;
01438     }
01439     if (fn > aa) {
01440         *ierr = 3;
01441     }
01442 /* ----------------------------------------------------------------------- */
01443 /*     OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE */
01444 /* ----------------------------------------------------------------------- */
01445 /*     UFL = DEXP(-ELIM) */
01446     ufl = d1mach_(&c__1) * 1e3;
01447     if (az < ufl) {
01448         goto L180;
01449     }
01450     if (*fnu > fnul) {
01451         goto L80;
01452     }
01453     if (fn <= 1.) {
01454         goto L60;
01455     }
01456     if (fn > 2.) {
01457         goto L50;
01458     }
01459     if (az > tol) {
01460         goto L60;
01461     }
01462     arg = az * .5;
01463     aln = -fn * log(arg);
01464     if (aln > elim) {
01465         goto L180;
01466     }
01467     goto L60;
01468 L50:
01469     zuoik_(zr, zi, fnu, kode, &c__2, &nn, &cyr[1], &cyi[1], &nuf, &tol, &elim,
01470              &alim);
01471     if (nuf < 0) {
01472         goto L180;
01473     }
01474     *nz += nuf;
01475     nn -= nuf;
01476 /* ----------------------------------------------------------------------- */
01477 /*     HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK */
01478 /*     IF NUF=NN, THEN CY(I)=CZERO FOR ALL I */
01479 /* ----------------------------------------------------------------------- */
01480     if (nn == 0) {
01481         goto L100;
01482     }
01483 L60:
01484     if (*zr < 0.) {
01485         goto L70;
01486     }
01487 /* ----------------------------------------------------------------------- */
01488 /*     RIGHT HALF PLANE COMPUTATION, REAL(Z).GE.0. */
01489 /* ----------------------------------------------------------------------- */
01490     zbknu_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, &tol, &elim, &alim);
01491     if (nw < 0) {
01492         goto L200;
01493     }
01494     *nz = nw;
01495     return 0;
01496 /* ----------------------------------------------------------------------- */
01497 /*     LEFT HALF PLANE COMPUTATION */
01498 /*     PI/2.LT.ARG(Z).LE.PI AND -PI.LT.ARG(Z).LT.-PI/2. */
01499 /* ----------------------------------------------------------------------- */
01500 L70:
01501     if (*nz != 0) {
01502         goto L180;
01503     }
01504     mr = 1;
01505     if (*zi < 0.) {
01506         mr = -1;
01507     }
01508     zacon_(zr, zi, fnu, kode, &mr, &nn, &cyr[1], &cyi[1], &nw, &rl, &fnul, &
01509             tol, &elim, &alim);
01510     if (nw < 0) {
01511         goto L200;
01512     }
01513     *nz = nw;
01514     return 0;
01515 /* ----------------------------------------------------------------------- */
01516 /*     UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL */
01517 /* ----------------------------------------------------------------------- */
01518 L80:
01519     mr = 0;
01520     if (*zr >= 0.) {
01521         goto L90;
01522     }
01523     mr = 1;
01524     if (*zi < 0.) {
01525         mr = -1;
01526     }
01527 L90:
01528     zbunk_(zr, zi, fnu, kode, &mr, &nn, &cyr[1], &cyi[1], &nw, &tol, &elim, &
01529             alim);
01530     if (nw < 0) {
01531         goto L200;
01532     }
01533     *nz += nw;
01534     return 0;
01535 L100:
01536     if (*zr < 0.) {
01537         goto L180;
01538     }
01539     return 0;
01540 L180:
01541     *nz = 0;
01542     *ierr = 2;
01543     return 0;
01544 L200:
01545     if (nw == -1) {
01546         goto L180;
01547     }
01548     *nz = 0;
01549     *ierr = 5;
01550     return 0;
01551 L260:
01552     *nz = 0;
01553     *ierr = 4;
01554     return 0;
01555 } /* zbesk_ */
01556 
01557 /* Subroutine */ int zbesy_(doublereal *zr, doublereal *zi, doublereal *fnu, 
01558         integer *kode, integer *n, doublereal *cyr, doublereal *cyi, integer *
01559         nz, doublereal *cwrkr, doublereal *cwrki, integer *ierr)
01560 {
01561     /* Initialized data */
01562 
01563     static doublereal cipr[4] = { 1.,0.,-1.,0. };
01564     static doublereal cipi[4] = { 0.,1.,0.,-1. };
01565     static doublereal hpi = 1.57079632679489662;
01566 
01567     /* System generated locals */
01568     integer i__1, i__2;
01569     doublereal d__1, d__2;
01570 
01571     /* Builtin functions */
01572     double cos(doublereal), sin(doublereal), exp(doublereal);
01573 
01574     /* Local variables */
01575     static integer i__, k, k1, i4, k2;
01576     static doublereal ey;
01577     static integer nz1, nz2;
01578     static doublereal d1m5, arg, exi, exr, sti, tay, tol, zni, zui, str, znr, 
01579             zvi, zzi, zur, zvr, zzr, elim, ffnu, atol, rhpi;
01580     static integer ifnu;
01581     static doublereal rtol, ascle, csgni, csgnr, cspni;
01582     extern /* Subroutine */ int zbesi_(doublereal *, doublereal *, doublereal 
01583             *, integer *, integer *, doublereal *, doublereal *, integer *, 
01584             integer *), zbesk_(doublereal *, doublereal *, doublereal *, 
01585             integer *, integer *, doublereal *, doublereal *, integer *, 
01586             integer *);
01587     static doublereal cspnr;
01588     extern doublereal d1mach_(integer *);
01589     extern integer i1mach_(integer *);
01590 
01591 /* ***BEGIN PROLOGUE  ZBESY */
01592 /* ***DATE WRITTEN   830501   (YYMMDD) */
01593 /* ***REVISION DATE  890801, 930101   (YYMMDD) */
01594 /* ***CATEGORY NO.  B5K */
01595 /* ***KEYWORDS  Y-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT, */
01596 /*             BESSEL FUNCTION OF SECOND KIND */
01597 /* ***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES */
01598 /* ***PURPOSE  TO COMPUTE THE Y-BESSEL FUNCTION OF A COMPLEX ARGUMENT */
01599 /* ***DESCRIPTION */
01600 
01601 /*                      ***A DOUBLE PRECISION ROUTINE*** */
01602 
01603 /*         ON KODE=1, ZBESY COMPUTES AN N MEMBER SEQUENCE OF COMPLEX */
01604 /*         BESSEL FUNCTIONS CY(I)=Y(FNU+I-1,Z) FOR REAL, NONNEGATIVE */
01605 /*         ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE */
01606 /*         -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESY RETURNS THE SCALED */
01607 /*         FUNCTIONS */
01608 
01609 /*         CY(I)=EXP(-ABS(Y))*Y(FNU+I-1,Z)   I = 1,...,N , Y=AIMAG(Z) */
01610 
01611 /*         WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND */
01612 /*         LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION */
01613 /*         ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS */
01614 /*         (REF. 1). */
01615 
01616 /*         INPUT      ZR,ZI,FNU ARE DOUBLE PRECISION */
01617 /*           ZR,ZI  - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0), */
01618 /*                    -PI.LT.ARG(Z).LE.PI */
01619 /*           FNU    - ORDER OF INITIAL Y FUNCTION, FNU.GE.0.0D0 */
01620 /*           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION */
01621 /*                    KODE= 1  RETURNS */
01622 /*                             CY(I)=Y(FNU+I-1,Z), I=1,...,N */
01623 /*                        = 2  RETURNS */
01624 /*                             CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y)), I=1,...,N */
01625 /*                             WHERE Y=AIMAG(Z) */
01626 /*           N      - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 */
01627 /*           CWRKR, - DOUBLE PRECISION WORK VECTORS OF DIMENSION AT */
01628 /*           CWRKI    AT LEAST N */
01629 
01630 /*         OUTPUT     CYR,CYI ARE DOUBLE PRECISION */
01631 /*           CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS */
01632 /*                    CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE */
01633 /*                    CY(I)=Y(FNU+I-1,Z)  OR */
01634 /*                    CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y))  I=1,...,N */
01635 /*                    DEPENDING ON KODE. */
01636 /*           NZ     - NZ=0 , A NORMAL RETURN */
01637 /*                    NZ.GT.0 , NZ COMPONENTS OF CY SET TO ZERO DUE TO */
01638 /*                    UNDERFLOW (GENERALLY ON KODE=2) */
01639 /*           IERR   - ERROR FLAG */
01640 /*                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED */
01641 /*                    IERR=1, INPUT ERROR   - NO COMPUTATION */
01642 /*                    IERR=2, OVERFLOW      - NO COMPUTATION, FNU IS */
01643 /*                            TOO LARGE OR CABS(Z) IS TOO SMALL OR BOTH */
01644 /*                    IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE */
01645 /*                            BUT LOSSES OF SIGNIFCANCE BY ARGUMENT */
01646 /*                            REDUCTION PRODUCE LESS THAN HALF OF MACHINE */
01647 /*                            ACCURACY */
01648 /*                    IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- */
01649 /*                            TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- */
01650 /*                            CANCE BY ARGUMENT REDUCTION */
01651 /*                    IERR=5, ERROR              - NO COMPUTATION, */
01652 /*                            ALGORITHM TERMINATION CONDITION NOT MET */
01653 
01654 /* ***LONG DESCRIPTION */
01655 
01656 /*         THE COMPUTATION IS CARRIED OUT IN TERMS OF THE I(FNU,Z) AND */
01657 /*         K(FNU,Z) BESSEL FUNCTIONS IN THE RIGHT HALF PLANE BY */
01658 
01659 /*             Y(FNU,Z) = I*CC*I(FNU,ARG) - (2/PI)*CONJG(CC)*K(FNU,ARG) */
01660 
01661 /*             Y(FNU,Z) = CONJG(Y(FNU,CONJG(Z))) */
01662 
01663 /*         FOR AIMAG(Z).GE.0 AND AIMAG(Z).LT.0 RESPECTIVELY, WHERE */
01664 /*         CC=EXP(I*PI*FNU/2), ARG=Z*EXP(-I*PI/2) AND I**2=-1. */
01665 
01666 /*         FOR NEGATIVE ORDERS,THE FORMULA */
01667 
01668 /*              Y(-FNU,Z) = Y(FNU,Z)*COS(PI*FNU) + J(FNU,Z)*SIN(PI*FNU) */
01669 
01670 /*         CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO HALF ODD */
01671 /*         INTEGERS THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE */
01672 /*         POSITIVE HALF ODD INTEGER,THE MAGNITUDE OF Y(-FNU,Z)=J(FNU,Z)* */
01673 /*         SIN(PI*FNU) IS A LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS */
01674 /*         NOT A HALF ODD INTEGER, Y(FNU,Z) DOMINATES IN MAGNITUDE WITH A */
01675 /*         LARGE POSITIVE POWER OF TEN AND THE MOST THAT THE SECOND TERM */
01676 /*         CAN BE REDUCED IS BY UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, */
01677 /*         WIDE CHANGES CAN OCCUR WITHIN UNIT ROUNDOFF OF A LARGE HALF */
01678 /*         ODD INTEGER. HERE, LARGE MEANS FNU.GT.CABS(Z). */
01679 
01680 /*         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- */
01681 /*         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS */
01682 /*         LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. */
01683 /*         CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN */
01684 /*         LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG */
01685 /*         IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS */
01686 /*         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. */
01687 /*         IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS */
01688 /*         LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS */
01689 /*         MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE */
01690 /*         INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS */
01691 /*         RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 */
01692 /*         ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION */
01693 /*         ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION */
01694 /*         ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN */
01695 /*         THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT */
01696 /*         TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS */
01697 /*         IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. */
01698 /*         SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. */
01699 
01700 /*         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX */
01701 /*         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT */
01702 /*         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- */
01703 /*         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE */
01704 /*         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), */
01705 /*         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF */
01706 /*         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY */
01707 /*         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN */
01708 /*         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY */
01709 /*         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER */
01710 /*         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, */
01711 /*         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS */
01712 /*         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER */
01713 /*         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY */
01714 /*         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER */
01715 /*         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE */
01716 /*         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, */
01717 /*         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, */
01718 /*         OR -PI/2+P. */
01719 
01720 /* ***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ */
01721 /*                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF */
01722 /*                 COMMERCE, 1955. */
01723 
01724 /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
01725 /*                 BY D. E. AMOS, SAND83-0083, MAY, 1983. */
01726 
01727 /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
01728 /*                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 */
01729 
01730 /*               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
01731 /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- */
01732 /*                 1018, MAY, 1985 */
01733 
01734 /*               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
01735 /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM */
01736 /*                 TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, */
01737 /*                 PP 265-273. */
01738 
01739 /* ***ROUTINES CALLED  ZBESI,ZBESK,I1MACH,D1MACH */
01740 /* ***END PROLOGUE  ZBESY */
01741 
01742 /*     COMPLEX CWRK,CY,C1,C2,EX,HCI,Z,ZU,ZV */
01743     /* Parameter adjustments */
01744     --cwrki;
01745     --cwrkr;
01746     --cyi;
01747     --cyr;
01748 
01749     /* Function Body */
01750 /* ***FIRST EXECUTABLE STATEMENT  ZBESY */
01751     *ierr = 0;
01752     *nz = 0;
01753     if (*zr == 0. && *zi == 0.) {
01754         *ierr = 1;
01755     }
01756     if (*fnu < 0.) {
01757         *ierr = 1;
01758     }
01759     if (*kode < 1 || *kode > 2) {
01760         *ierr = 1;
01761     }
01762     if (*n < 1) {
01763         *ierr = 1;
01764     }
01765     if (*ierr != 0) {
01766         return 0;
01767     }
01768     zzr = *zr;
01769     zzi = *zi;
01770     if (*zi < 0.) {
01771         zzi = -zzi;
01772     }
01773     znr = zzi;
01774     zni = -zzr;
01775     zbesi_(&znr, &zni, fnu, kode, n, &cyr[1], &cyi[1], &nz1, ierr);
01776     if (*ierr != 0 && *ierr != 3) {
01777         goto L90;
01778     }
01779     zbesk_(&znr, &zni, fnu, kode, n, &cwrkr[1], &cwrki[1], &nz2, ierr);
01780     if (*ierr != 0 && *ierr != 3) {
01781         goto L90;
01782     }
01783     *nz = min(nz1,nz2);
01784     ifnu = (integer) ((real) (*fnu));
01785     ffnu = *fnu - (doublereal) ((real) ifnu);
01786     arg = hpi * ffnu;
01787     csgnr = cos(arg);
01788     csgni = sin(arg);
01789     i4 = ifnu % 4 + 1;
01790     str = csgnr * cipr[i4 - 1] - csgni * cipi[i4 - 1];
01791     csgni = csgnr * cipi[i4 - 1] + csgni * cipr[i4 - 1];
01792     csgnr = str;
01793     rhpi = 1. / hpi;
01794     cspnr = csgnr * rhpi;
01795     cspni = -csgni * rhpi;
01796     str = -csgni;
01797     csgni = csgnr;
01798     csgnr = str;
01799     if (*kode == 2) {
01800         goto L60;
01801     }
01802     i__1 = *n;
01803     for (i__ = 1; i__ <= i__1; ++i__) {
01804 /*       CY(I) = CSGN*CY(I)-CSPN*CWRK(I) */
01805         str = csgnr * cyr[i__] - csgni * cyi[i__];
01806         str -= cspnr * cwrkr[i__] - cspni * cwrki[i__];
01807         sti = csgnr * cyi[i__] + csgni * cyr[i__];
01808         sti -= cspnr * cwrki[i__] + cspni * cwrkr[i__];
01809         cyr[i__] = str;
01810         cyi[i__] = sti;
01811         str = -csgni;
01812         csgni = csgnr;
01813         csgnr = str;
01814         str = cspni;
01815         cspni = -cspnr;
01816         cspnr = str;
01817 /* L50: */
01818     }
01819     if (*zi < 0.) {
01820         i__1 = *n;
01821         for (i__ = 1; i__ <= i__1; ++i__) {
01822             cyi[i__] = -cyi[i__];
01823 /* L55: */
01824         }
01825     }
01826     return 0;
01827 L60:
01828     exr = cos(*zr);
01829     exi = sin(*zr);
01830 /* Computing MAX */
01831     d__1 = d1mach_(&c__4);
01832     tol = max(d__1,1e-18);
01833     k1 = i1mach_(&c__15);
01834     k2 = i1mach_(&c__16);
01835 /* Computing MIN */
01836     i__1 = abs(k1), i__2 = abs(k2);
01837     k = min(i__1,i__2);
01838     d1m5 = d1mach_(&c__5);
01839 /* ----------------------------------------------------------------------- */
01840 /*     ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT */
01841 /* ----------------------------------------------------------------------- */
01842     elim = ((doublereal) ((real) k) * d1m5 - 3.) * 2.303;
01843     ey = 0.;
01844     tay = (d__1 = *zi + *zi, abs(d__1));
01845     if (tay < elim) {
01846         ey = exp(-tay);
01847     }
01848     str = (exr * cspnr - exi * cspni) * ey;
01849     cspni = (exr * cspni + exi * cspnr) * ey;
01850     cspnr = str;
01851     *nz = 0;
01852     rtol = 1. / tol;
01853     ascle = d1mach_(&c__1) * rtol * 1e3;
01854     i__1 = *n;
01855     for (i__ = 1; i__ <= i__1; ++i__) {
01856 /* ---------------------------------------------------------------------- */
01857 /*       CY(I) = CSGN*CY(I)-CSPN*CWRK(I): PRODUCTS ARE COMPUTED IN */
01858 /*       SCALED MODE IF CY(I) OR CWRK(I) ARE CLOSE TO UNDERFLOW TO */
01859 /*       PREVENT UNDERFLOW IN AN INTERMEDIATE COMPUTATION. */
01860 /* ---------------------------------------------------------------------- */
01861         zvr = cwrkr[i__];
01862         zvi = cwrki[i__];
01863         atol = 1.;
01864 /* Computing MAX */
01865         d__1 = abs(zvr), d__2 = abs(zvi);
01866         if (max(d__1,d__2) > ascle) {
01867             goto L75;
01868         }
01869         zvr *= rtol;
01870         zvi *= rtol;
01871         atol = tol;
01872 L75:
01873         str = (zvr * cspnr - zvi * cspni) * atol;
01874         zvi = (zvr * cspni + zvi * cspnr) * atol;
01875         zvr = str;
01876         zur = cyr[i__];
01877         zui = cyi[i__];
01878         atol = 1.;
01879 /* Computing MAX */
01880         d__1 = abs(zur), d__2 = abs(zui);
01881         if (max(d__1,d__2) > ascle) {
01882             goto L85;
01883         }
01884         zur *= rtol;
01885         zui *= rtol;
01886         atol = tol;
01887 L85:
01888         str = (zur * csgnr - zui * csgni) * atol;
01889         zui = (zur * csgni + zui * csgnr) * atol;
01890         zur = str;
01891         cyr[i__] = zur - zvr;
01892         cyi[i__] = zui - zvi;
01893         if (*zi < 0.) {
01894             cyi[i__] = -cyi[i__];
01895         }
01896         if (cyr[i__] == 0. && cyi[i__] == 0. && ey == 0.) {
01897             ++(*nz);
01898         }
01899         str = -csgni;
01900         csgni = csgnr;
01901         csgnr = str;
01902         str = cspni;
01903         cspni = -cspnr;
01904         cspnr = str;
01905 /* L80: */
01906     }
01907     return 0;
01908 L90:
01909     *nz = 0;
01910     return 0;
01911 } /* zbesy_ */
01912 
01913 /* Subroutine */ int zairy_(doublereal *zr, doublereal *zi, integer *id, 
01914         integer *kode, doublereal *air, doublereal *aii, integer *nz, integer 
01915         *ierr)
01916 {
01917     /* Initialized data */
01918 
01919     static doublereal tth = .666666666666666667;
01920     static doublereal c1 = .35502805388781724;
01921     static doublereal c2 = .258819403792806799;
01922     static doublereal coef = .183776298473930683;
01923     static doublereal zeror = 0.;
01924     static doublereal zeroi = 0.;
01925     static doublereal coner = 1.;
01926     static doublereal conei = 0.;
01927 
01928     /* System generated locals */
01929     integer i__1, i__2;
01930     doublereal d__1;
01931 
01932     /* Builtin functions */
01933     double log(doublereal), pow_dd(doublereal *, doublereal *), sqrt(
01934             doublereal);
01935 
01936     /* Local variables */
01937     extern /* Subroutine */ int zzzsqrt_(doublereal *, doublereal *, 
01938             doublereal *, doublereal *);
01939     static integer k;
01940     static doublereal d1, d2;
01941     static integer k1, k2;
01942     static doublereal aa, bb, ad, cc, ak, bk, ck, dk, az;
01943     static integer nn;
01944     static doublereal rl;
01945     static integer mr;
01946     static doublereal s1i, az3, s2i, s1r, s2r, z3i, z3r, dig, fid, cyi[1], 
01947             r1m5, fnu, cyr[1], tol, sti, ptr, str, sfac, alim, elim, alaz;
01948     extern doublereal zabs_(doublereal *, doublereal *);
01949     static doublereal csqi, atrm, ztai, csqr, ztar, trm1i, trm2i, trm1r, 
01950             trm2r;
01951     static integer iflag;
01952     extern /* Subroutine */ int zacai_(doublereal *, doublereal *, doublereal 
01953             *, integer *, integer *, integer *, doublereal *, doublereal *, 
01954             integer *, doublereal *, doublereal *, doublereal *, doublereal *)
01955             , zbknu_(doublereal *, doublereal *, doublereal *, integer *, 
01956             integer *, doublereal *, doublereal *, integer *, doublereal *, 
01957             doublereal *, doublereal *);
01958     extern doublereal d1mach_(integer *);
01959     extern integer i1mach_(integer *);
01960     extern /* Subroutine */ int zzzexp_(doublereal *, doublereal *, 
01961             doublereal *, doublereal *);
01962 
01963 /* ***BEGIN PROLOGUE  ZAIRY */
01964 /* ***DATE WRITTEN   830501   (YYMMDD) */
01965 /* ***REVISION DATE  890801, 930101   (YYMMDD) */
01966 /* ***CATEGORY NO.  B5K */
01967 /* ***KEYWORDS  AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD */
01968 /* ***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES */
01969 /* ***PURPOSE  TO COMPUTE AIRY FUNCTIONS AI(Z) AND DAI(Z) FOR COMPLEX Z */
01970 /* ***DESCRIPTION */
01971 
01972 /*                      ***A DOUBLE PRECISION ROUTINE*** */
01973 /*         ON KODE=1, ZAIRY COMPUTES THE COMPLEX AIRY FUNCTION AI(Z) OR */
01974 /*         ITS DERIVATIVE DAI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON */
01975 /*         KODE=2, A SCALING OPTION CEXP(ZTA)*AI(Z) OR CEXP(ZTA)* */
01976 /*         DAI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL DECAY IN */
01977 /*         -PI/3.LT.ARG(Z).LT.PI/3 AND THE EXPONENTIAL GROWTH IN */
01978 /*         PI/3.LT.ABS(ARG(Z)).LT.PI WHERE ZTA=(2/3)*Z*CSQRT(Z). */
01979 
01980 /*         WHILE THE AIRY FUNCTIONS AI(Z) AND DAI(Z)/DZ ARE ANALYTIC IN */
01981 /*         THE WHOLE Z PLANE, THE CORRESPONDING SCALED FUNCTIONS DEFINED */
01982 /*         FOR KODE=2 HAVE A CUT ALONG THE NEGATIVE REAL AXIS. */
01983 /*         DEFINTIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF */
01984 /*         MATHEMATICAL FUNCTIONS (REF. 1). */
01985 
01986 /*         INPUT      ZR,ZI ARE DOUBLE PRECISION */
01987 /*           ZR,ZI  - Z=CMPLX(ZR,ZI) */
01988 /*           ID     - ORDER OF DERIVATIVE, ID=0 OR ID=1 */
01989 /*           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION */
01990 /*                    KODE= 1  RETURNS */
01991 /*                             AI=AI(Z)                ON ID=0 OR */
01992 /*                             AI=DAI(Z)/DZ            ON ID=1 */
01993 /*                        = 2  RETURNS */
01994 /*                             AI=CEXP(ZTA)*AI(Z)       ON ID=0 OR */
01995 /*                             AI=CEXP(ZTA)*DAI(Z)/DZ   ON ID=1 WHERE */
01996 /*                             ZTA=(2/3)*Z*CSQRT(Z) */
01997 
01998 /*         OUTPUT     AIR,AII ARE DOUBLE PRECISION */
01999 /*           AIR,AII- COMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND */
02000 /*                    KODE */
02001 /*           NZ     - UNDERFLOW INDICATOR */
02002 /*                    NZ= 0   , NORMAL RETURN */
02003 /*                    NZ= 1   , AI=CMPLX(0.0D0,0.0D0) DUE TO UNDERFLOW IN */
02004 /*                              -PI/3.LT.ARG(Z).LT.PI/3 ON KODE=1 */
02005 /*           IERR   - ERROR FLAG */
02006 /*                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED */
02007 /*                    IERR=1, INPUT ERROR   - NO COMPUTATION */
02008 /*                    IERR=2, OVERFLOW      - NO COMPUTATION, REAL(ZTA) */
02009 /*                            TOO LARGE ON KODE=1 */
02010 /*                    IERR=3, CABS(Z) LARGE      - COMPUTATION COMPLETED */
02011 /*                            LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION */
02012 /*                            PRODUCE LESS THAN HALF OF MACHINE ACCURACY */
02013 /*                    IERR=4, CABS(Z) TOO LARGE  - NO COMPUTATION */
02014 /*                            COMPLETE LOSS OF ACCURACY BY ARGUMENT */
02015 /*                            REDUCTION */
02016 /*                    IERR=5, ERROR              - NO COMPUTATION, */
02017 /*                            ALGORITHM TERMINATION CONDITION NOT MET */
02018 
02019 /* ***LONG DESCRIPTION */
02020 
02021 /*         AI AND DAI ARE COMPUTED FOR CABS(Z).GT.1.0 FROM THE K BESSEL */
02022 /*         FUNCTIONS BY */
02023 
02024 /*            AI(Z)=C*SQRT(Z)*K(1/3,ZTA) , DAI(Z)=-C*Z*K(2/3,ZTA) */
02025 /*                           C=1.0/(PI*SQRT(3.0)) */
02026 /*                            ZTA=(2/3)*Z**(3/2) */
02027 
02028 /*         WITH THE POWER SERIES FOR CABS(Z).LE.1.0. */
02029 
02030 /*         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- */
02031 /*         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES */
02032 /*         OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF */
02033 /*         THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR), */
02034 /*         THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR */
02035 /*         FLAG IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS */
02036 /*         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. */
02037 /*         ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN */
02038 /*         ALL SIGNIFICANCE IS LOST AND IERR=4. IN ORDER TO USE THE INT */
02039 /*         FUNCTION, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE */
02040 /*         LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA */
02041 /*         MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, */
02042 /*         AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE */
02043 /*         PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE */
02044 /*         PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT- */
02045 /*         ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG- */
02046 /*         NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN */
02047 /*         DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN */
02048 /*         EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, */
02049 /*         NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE */
02050 /*         PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER */
02051 /*         MACHINES. */
02052 
02053 /*         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX */
02054 /*         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT */
02055 /*         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- */
02056 /*         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE */
02057 /*         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), */
02058 /*         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF */
02059 /*         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY */
02060 /*         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN */
02061 /*         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY */
02062 /*         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER */
02063 /*         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, */
02064 /*         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS */
02065 /*         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER */
02066 /*         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY */
02067 /*         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER */
02068 /*         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE */
02069 /*         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, */
02070 /*         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, */
02071 /*         OR -PI/2+P. */
02072 
02073 /* ***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ */
02074 /*                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF */
02075 /*                 COMMERCE, 1955. */
02076 
02077 /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
02078 /*                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 */
02079 
02080 /*               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
02081 /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- */
02082 /*                 1018, MAY, 1985 */
02083 
02084 /*               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
02085 /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM */
02086 /*                 TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, */
02087 /*                 PP 265-273. */
02088 
02089 /* ***ROUTINES CALLED  ZACAI,ZBKNU,ZZZEXP,ZZZSQRT,ZABS,I1MACH,D1MACH */
02090 /* ***END PROLOGUE  ZAIRY */
02091 /*     COMPLEX AI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3 */
02092 /* ***FIRST EXECUTABLE STATEMENT  ZAIRY */
02093     *ierr = 0;
02094     *nz = 0;
02095     if (*id < 0 || *id > 1) {
02096         *ierr = 1;
02097     }
02098     if (*kode < 1 || *kode > 2) {
02099         *ierr = 1;
02100     }
02101     if (*ierr != 0) {
02102         return 0;
02103     }
02104     az = zabs_(zr, zi);
02105 /* Computing MAX */
02106     d__1 = d1mach_(&c__4);
02107     tol = max(d__1,1e-18);
02108     fid = (doublereal) ((real) (*id));
02109     if (az > 1.) {
02110         goto L70;
02111     }
02112 /* ----------------------------------------------------------------------- */
02113 /*     POWER SERIES FOR CABS(Z).LE.1. */
02114 /* ----------------------------------------------------------------------- */
02115     s1r = coner;
02116     s1i = conei;
02117     s2r = coner;
02118     s2i = conei;
02119     if (az < tol) {
02120         goto L170;
02121     }
02122     aa = az * az;
02123     if (aa < tol / az) {
02124         goto L40;
02125     }
02126     trm1r = coner;
02127     trm1i = conei;
02128     trm2r = coner;
02129     trm2i = conei;
02130     atrm = 1.;
02131     str = *zr * *zr - *zi * *zi;
02132     sti = *zr * *zi + *zi * *zr;
02133     z3r = str * *zr - sti * *zi;
02134     z3i = str * *zi + sti * *zr;
02135     az3 = az * aa;
02136     ak = fid + 2.;
02137     bk = 3. - fid - fid;
02138     ck = 4. - fid;
02139     dk = fid + 3. + fid;
02140     d1 = ak * dk;
02141     d2 = bk * ck;
02142     ad = min(d1,d2);
02143     ak = fid * 9. + 24.;
02144     bk = 30. - fid * 9.;
02145     for (k = 1; k <= 25; ++k) {
02146         str = (trm1r * z3r - trm1i * z3i) / d1;
02147         trm1i = (trm1r * z3i + trm1i * z3r) / d1;
02148         trm1r = str;
02149         s1r += trm1r;
02150         s1i += trm1i;
02151         str = (trm2r * z3r - trm2i * z3i) / d2;
02152         trm2i = (trm2r * z3i + trm2i * z3r) / d2;
02153         trm2r = str;
02154         s2r += trm2r;
02155         s2i += trm2i;
02156         atrm = atrm * az3 / ad;
02157         d1 += ak;
02158         d2 += bk;
02159         ad = min(d1,d2);
02160         if (atrm < tol * ad) {
02161             goto L40;
02162         }
02163         ak += 18.;
02164         bk += 18.;
02165 /* L30: */
02166     }
02167 L40:
02168     if (*id == 1) {
02169         goto L50;
02170     }
02171     *air = s1r * c1 - c2 * (*zr * s2r - *zi * s2i);
02172     *aii = s1i * c1 - c2 * (*zr * s2i + *zi * s2r);
02173     if (*kode == 1) {
02174         return 0;
02175     }
02176     zzzsqrt_(zr, zi, &str, &sti);
02177     ztar = tth * (*zr * str - *zi * sti);
02178     ztai = tth * (*zr * sti + *zi * str);
02179     zzzexp_(&ztar, &ztai, &str, &sti);
02180     ptr = *air * str - *aii * sti;
02181     *aii = *air * sti + *aii * str;
02182     *air = ptr;
02183     return 0;
02184 L50:
02185     *air = -s2r * c2;
02186     *aii = -s2i * c2;
02187     if (az <= tol) {
02188         goto L60;
02189     }
02190     str = *zr * s1r - *zi * s1i;
02191     sti = *zr * s1i + *zi * s1r;
02192     cc = c1 / (fid + 1.);
02193     *air += cc * (str * *zr - sti * *zi);
02194     *aii += cc * (str * *zi + sti * *zr);
02195 L60:
02196     if (*kode == 1) {
02197         return 0;
02198     }
02199     zzzsqrt_(zr, zi, &str, &sti);
02200     ztar = tth * (*zr * str - *zi * sti);
02201     ztai = tth * (*zr * sti + *zi * str);
02202     zzzexp_(&ztar, &ztai, &str, &sti);
02203     ptr = str * *air - sti * *aii;
02204     *aii = str * *aii + sti * *air;
02205     *air = ptr;
02206     return 0;
02207 /* ----------------------------------------------------------------------- */
02208 /*     CASE FOR CABS(Z).GT.1.0 */
02209 /* ----------------------------------------------------------------------- */
02210 L70:
02211     fnu = (fid + 1.) / 3.;
02212 /* ----------------------------------------------------------------------- */
02213 /*     SET PARAMETERS RELATED TO MACHINE CONSTANTS. */
02214 /*     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0D-18. */
02215 /*     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. */
02216 /*     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND */
02217 /*     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR */
02218 /*     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. */
02219 /*     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. */
02220 /*     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). */
02221 /* ----------------------------------------------------------------------- */
02222     k1 = i1mach_(&c__15);
02223     k2 = i1mach_(&c__16);
02224     r1m5 = d1mach_(&c__5);
02225 /* Computing MIN */
02226     i__1 = abs(k1), i__2 = abs(k2);
02227     k = min(i__1,i__2);
02228     elim = ((doublereal) ((real) k) * r1m5 - 3.) * 2.303;
02229     k1 = i1mach_(&c__14) - 1;
02230     aa = r1m5 * (doublereal) ((real) k1);
02231     dig = min(aa,18.);
02232     aa *= 2.303;
02233 /* Computing MAX */
02234     d__1 = -aa;
02235     alim = elim + max(d__1,-41.45);
02236     rl = dig * 1.2 + 3.;
02237     alaz = log(az);
02238 /* -------------------------------------------------------------------------- */
02239 /*     TEST FOR PROPER RANGE */
02240 /* ----------------------------------------------------------------------- */
02241     aa = .5 / tol;
02242     bb = (doublereal) ((real) i1mach_(&c__9)) * .5;
02243     aa = min(aa,bb);
02244     aa = pow(aa, tth);
02245     if (az > aa) {
02246         goto L260;
02247     }
02248     aa = sqrt(aa);
02249     if (az > aa) {
02250         *ierr = 3;
02251     }
02252     zzzsqrt_(zr, zi, &csqr, &csqi);
02253     ztar = tth * (*zr * csqr - *zi * csqi);
02254     ztai = tth * (*zr * csqi + *zi * csqr);
02255 /* ----------------------------------------------------------------------- */
02256 /*     RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL */
02257 /* ----------------------------------------------------------------------- */
02258     iflag = 0;
02259     sfac = 1.;
02260     ak = ztai;
02261     if (*zr >= 0.) {
02262         goto L80;
02263     }
02264     bk = ztar;
02265     ck = -abs(bk);
02266     ztar = ck;
02267     ztai = ak;
02268 L80:
02269     if (*zi != 0.) {
02270         goto L90;
02271     }
02272     if (*zr > 0.) {
02273         goto L90;
02274     }
02275     ztar = 0.;
02276     ztai = ak;
02277 L90:
02278     aa = ztar;
02279     if (aa >= 0. && *zr > 0.) {
02280         goto L110;
02281     }
02282     if (*kode == 2) {
02283         goto L100;
02284     }
02285 /* ----------------------------------------------------------------------- */
02286 /*     OVERFLOW TEST */
02287 /* ----------------------------------------------------------------------- */
02288     if (aa > -alim) {
02289         goto L100;
02290     }
02291     aa = -aa + alaz * .25;
02292     iflag = 1;
02293     sfac = tol;
02294     if (aa > elim) {
02295         goto L270;
02296     }
02297 L100:
02298 /* ----------------------------------------------------------------------- */
02299 /*     CBKNU AND CACON RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2 */
02300 /* ----------------------------------------------------------------------- */
02301     mr = 1;
02302     if (*zi < 0.) {
02303         mr = -1;
02304     }
02305     zacai_(&ztar, &ztai, &fnu, kode, &mr, &c__1, cyr, cyi, &nn, &rl, &tol, &
02306             elim, &alim);
02307     if (nn < 0) {
02308         goto L280;
02309     }
02310     *nz += nn;
02311     goto L130;
02312 L110:
02313     if (*kode == 2) {
02314         goto L120;
02315     }
02316 /* ----------------------------------------------------------------------- */
02317 /*     UNDERFLOW TEST */
02318 /* ----------------------------------------------------------------------- */
02319     if (aa < alim) {
02320         goto L120;
02321     }
02322     aa = -aa - alaz * .25;
02323     iflag = 2;
02324     sfac = 1. / tol;
02325     if (aa < -elim) {
02326         goto L210;
02327     }
02328 L120:
02329     zbknu_(&ztar, &ztai, &fnu, kode, &c__1, cyr, cyi, nz, &tol, &elim, &alim);
02330 L130:
02331     s1r = cyr[0] * coef;
02332     s1i = cyi[0] * coef;
02333     if (iflag != 0) {
02334         goto L150;
02335     }
02336     if (*id == 1) {
02337         goto L140;
02338     }
02339     *air = csqr * s1r - csqi * s1i;
02340     *aii = csqr * s1i + csqi * s1r;
02341     return 0;
02342 L140:
02343     *air = -(*zr * s1r - *zi * s1i);
02344     *aii = -(*zr * s1i + *zi * s1r);
02345     return 0;
02346 L150:
02347     s1r *= sfac;
02348     s1i *= sfac;
02349     if (*id == 1) {
02350         goto L160;
02351     }
02352     str = s1r * csqr - s1i * csqi;
02353     s1i = s1r * csqi + s1i * csqr;
02354     s1r = str;
02355     *air = s1r / sfac;
02356     *aii = s1i / sfac;
02357     return 0;
02358 L160:
02359     str = -(s1r * *zr - s1i * *zi);
02360     s1i = -(s1r * *zi + s1i * *zr);
02361     s1r = str;
02362     *air = s1r / sfac;
02363     *aii = s1i / sfac;
02364     return 0;
02365 L170:
02366     aa = d1mach_(&c__1) * 1e3;
02367     s1r = zeror;
02368     s1i = zeroi;
02369     if (*id == 1) {
02370         goto L190;
02371     }
02372     if (az <= aa) {
02373         goto L180;
02374     }
02375     s1r = c2 * *zr;
02376     s1i = c2 * *zi;
02377 L180:
02378     *air = c1 - s1r;
02379     *aii = -s1i;
02380     return 0;
02381 L190:
02382     *air = -c2;
02383     *aii = 0.;
02384     aa = sqrt(aa);
02385     if (az <= aa) {
02386         goto L200;
02387     }
02388     s1r = (*zr * *zr - *zi * *zi) * .5;
02389     s1i = *zr * *zi;
02390 L200:
02391     *air += c1 * s1r;
02392     *aii += c1 * s1i;
02393     return 0;
02394 L210:
02395     *nz = 1;
02396     *air = zeror;
02397     *aii = zeroi;
02398     return 0;
02399 L270:
02400     *nz = 0;
02401     *ierr = 2;
02402     return 0;
02403 L280:
02404     if (nn == -1) {
02405         goto L270;
02406     }
02407     *nz = 0;
02408     *ierr = 5;
02409     return 0;
02410 L260:
02411     *ierr = 4;
02412     *nz = 0;
02413     return 0;
02414 } /* zairy_ */
02415 
02416 /* Subroutine */ int zbiry_(doublereal *zr, doublereal *zi, integer *id, 
02417         integer *kode, doublereal *bir, doublereal *bii, integer *ierr)
02418 {
02419     /* Initialized data */
02420 
02421     static doublereal tth = .666666666666666667;
02422     static doublereal c1 = .614926627446000736;
02423     static doublereal c2 = .448288357353826359;
02424     static doublereal coef = .577350269189625765;
02425     static doublereal pi = 3.14159265358979324;
02426     static doublereal coner = 1.;
02427     static doublereal conei = 0.;
02428 
02429     /* System generated locals */
02430     integer i__1, i__2;
02431     doublereal d__1;
02432 
02433     /* Builtin functions */
02434     double exp(doublereal), pow_dd(doublereal *, doublereal *), sqrt(
02435             doublereal), log(doublereal), cos(doublereal), sin(doublereal);
02436 
02437     /* Local variables */
02438     extern /* Subroutine */ int zzzsqrt_(doublereal *, doublereal *, 
02439             doublereal *, doublereal *);
02440     static integer k;
02441     static doublereal d1, d2;
02442     static integer k1, k2;
02443     static doublereal aa, bb, ad, cc, ak, bk, ck, dk, az, rl;
02444     static integer nz;
02445     static doublereal s1i, az3, s2i, s1r, s2r, z3i, z3r, eaa, fid, dig, cyi[2]
02446             , fmr, r1m5, fnu, cyr[2], tol, sti, str, sfac, alim, elim;
02447     extern doublereal zabs_(doublereal *, doublereal *);
02448     static doublereal csqi, atrm, fnul, ztai, csqr;
02449     extern /* Subroutine */ int zdiv_(doublereal *, doublereal *, doublereal *
02450             , doublereal *, doublereal *, doublereal *);
02451     static doublereal ztar, trm1i, trm2i, trm1r, trm2r;
02452     extern /* Subroutine */ int zbinu_(doublereal *, doublereal *, doublereal 
02453             *, integer *, integer *, doublereal *, doublereal *, integer *, 
02454             doublereal *, doublereal *, doublereal *, doublereal *, 
02455             doublereal *);
02456     extern doublereal d1mach_(integer *);
02457     extern integer i1mach_(integer *);
02458 
02459 /* ***BEGIN PROLOGUE  ZBIRY */
02460 /* ***DATE WRITTEN   830501   (YYMMDD) */
02461 /* ***REVISION DATE  890801, 930101   (YYMMDD) */
02462 /* ***CATEGORY NO.  B5K */
02463 /* ***KEYWORDS  AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD */
02464 /* ***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES */
02465 /* ***PURPOSE  TO COMPUTE AIRY FUNCTIONS BI(Z) AND DBI(Z) FOR COMPLEX Z */
02466 /* ***DESCRIPTION */
02467 
02468 /*                      ***A DOUBLE PRECISION ROUTINE*** */
02469 /*         ON KODE=1, CBIRY COMPUTES THE COMPLEX AIRY FUNCTION BI(Z) OR */
02470 /*         ITS DERIVATIVE DBI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON */
02471 /*         KODE=2, A SCALING OPTION CEXP(-AXZTA)*BI(Z) OR CEXP(-AXZTA)* */
02472 /*         DBI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL BEHAVIOR IN */
02473 /*         BOTH THE LEFT AND RIGHT HALF PLANES WHERE */
02474 /*         ZTA=(2/3)*Z*CSQRT(Z)=CMPLX(XZTA,YZTA) AND AXZTA=ABS(XZTA). */
02475 /*         DEFINTIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF */
02476 /*         MATHEMATICAL FUNCTIONS (REF. 1). */
02477 
02478 /*         INPUT      ZR,ZI ARE DOUBLE PRECISION */
02479 /*           ZR,ZI  - Z=CMPLX(ZR,ZI) */
02480 /*           ID     - ORDER OF DERIVATIVE, ID=0 OR ID=1 */
02481 /*           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION */
02482 /*                    KODE= 1  RETURNS */
02483 /*                             BI=BI(Z)                 ON ID=0 OR */
02484 /*                             BI=DBI(Z)/DZ             ON ID=1 */
02485 /*                        = 2  RETURNS */
02486 /*                             BI=CEXP(-AXZTA)*BI(Z)     ON ID=0 OR */
02487 /*                             BI=CEXP(-AXZTA)*DBI(Z)/DZ ON ID=1 WHERE */
02488 /*                             ZTA=(2/3)*Z*CSQRT(Z)=CMPLX(XZTA,YZTA) */
02489 /*                             AND AXZTA=ABS(XZTA) */
02490 
02491 /*         OUTPUT     BIR,BII ARE DOUBLE PRECISION */
02492 /*           BIR,BII- COMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND */
02493 /*                    KODE */
02494 /*           IERR   - ERROR FLAG */
02495 /*                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED */
02496 /*                    IERR=1, INPUT ERROR   - NO COMPUTATION */
02497 /*                    IERR=2, OVERFLOW      - NO COMPUTATION, REAL(Z) */
02498 /*                            TOO LARGE ON KODE=1 */
02499 /*                    IERR=3, CABS(Z) LARGE      - COMPUTATION COMPLETED */
02500 /*                            LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION */
02501 /*                            PRODUCE LESS THAN HALF OF MACHINE ACCURACY */
02502 /*                    IERR=4, CABS(Z) TOO LARGE  - NO COMPUTATION */
02503 /*                            COMPLETE LOSS OF ACCURACY BY ARGUMENT */
02504 /*                            REDUCTION */
02505 /*                    IERR=5, ERROR              - NO COMPUTATION, */
02506 /*                            ALGORITHM TERMINATION CONDITION NOT MET */
02507 
02508 /* ***LONG DESCRIPTION */
02509 
02510 /*         BI AND DBI ARE COMPUTED FOR CABS(Z).GT.1.0 FROM THE I BESSEL */
02511 /*         FUNCTIONS BY */
02512 
02513 /*                BI(Z)=C*SQRT(Z)*( I(-1/3,ZTA) + I(1/3,ZTA) ) */
02514 /*               DBI(Z)=C *  Z  * ( I(-2/3,ZTA) + I(2/3,ZTA) ) */
02515 /*                               C=1.0/SQRT(3.0) */
02516 /*                             ZTA=(2/3)*Z**(3/2) */
02517 
02518 /*         WITH THE POWER SERIES FOR CABS(Z).LE.1.0. */
02519 
02520 /*         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- */
02521 /*         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES */
02522 /*         OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF */
02523 /*         THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR), */
02524 /*         THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR */
02525 /*         FLAG IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS */
02526 /*         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. */
02527 /*         ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN */
02528 /*         ALL SIGNIFICANCE IS LOST AND IERR=4. IN ORDER TO USE THE INT */
02529 /*         FUNCTION, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE */
02530 /*         LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA */
02531 /*         MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, */
02532 /*         AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE */
02533 /*         PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE */
02534 /*         PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT- */
02535 /*         ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG- */
02536 /*         NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN */
02537 /*         DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN */
02538 /*         EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, */
02539 /*         NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE */
02540 /*         PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER */
02541 /*         MACHINES. */
02542 
02543 /*         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX */
02544 /*         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT */
02545 /*         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- */
02546 /*         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE */
02547 /*         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), */
02548 /*         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF */
02549 /*         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY */
02550 /*         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN */
02551 /*         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY */
02552 /*         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER */
02553 /*         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, */
02554 /*         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS */
02555 /*         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER */
02556 /*         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY */
02557 /*         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER */
02558 /*         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE */
02559 /*         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, */
02560 /*         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, */
02561 /*         OR -PI/2+P. */
02562 
02563 /* ***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ */
02564 /*                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF */
02565 /*                 COMMERCE, 1955. */
02566 
02567 /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
02568 /*                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 */
02569 
02570 /*               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
02571 /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- */
02572 /*                 1018, MAY, 1985 */
02573 
02574 /*               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
02575 /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, ACM */
02576 /*                 TRANS. MATH. SOFTWARE, VOL. 12, NO. 3, SEPTEMBER 1986, */
02577 /*                 PP 265-273. */
02578 
02579 /* ***ROUTINES CALLED  ZBINU,ZABS,ZDIV,ZZZSQRT,D1MACH,I1MACH */
02580 /* ***END PROLOGUE  ZBIRY */
02581 /*     COMPLEX BI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3 */
02582 /* ***FIRST EXECUTABLE STATEMENT  ZBIRY */
02583     *ierr = 0;
02584     nz = 0;
02585     if (*id < 0 || *id > 1) {
02586         *ierr = 1;
02587     }
02588     if (*kode < 1 || *kode > 2) {
02589         *ierr = 1;
02590     }
02591     if (*ierr != 0) {
02592         return 0;
02593     }
02594     az = zabs_(zr, zi);
02595 /* Computing MAX */
02596     d__1 = d1mach_(&c__4);
02597     tol = max(d__1,1e-18);
02598     fid = (doublereal) ((real) (*id));
02599     if (az > 1.f) {
02600         goto L70;
02601     }
02602 /* ----------------------------------------------------------------------- */
02603 /*     POWER SERIES FOR CABS(Z).LE.1. */
02604 /* ----------------------------------------------------------------------- */
02605     s1r = coner;
02606     s1i = conei;
02607     s2r = coner;
02608     s2i = conei;
02609     if (az < tol) {
02610         goto L130;
02611     }
02612     aa = az * az;
02613     if (aa < tol / az) {
02614         goto L40;
02615     }
02616     trm1r = coner;
02617     trm1i = conei;
02618     trm2r = coner;
02619     trm2i = conei;
02620     atrm = 1.;
02621     str = *zr * *zr - *zi * *zi;
02622     sti = *zr * *zi + *zi * *zr;
02623     z3r = str * *zr - sti * *zi;
02624     z3i = str * *zi + sti * *zr;
02625     az3 = az * aa;
02626     ak = fid + 2.;
02627     bk = 3. - fid - fid;
02628     ck = 4. - fid;
02629     dk = fid + 3. + fid;
02630     d1 = ak * dk;
02631     d2 = bk * ck;
02632     ad = min(d1,d2);
02633     ak = fid * 9. + 24.;
02634     bk = 30. - fid * 9.;
02635     for (k = 1; k <= 25; ++k) {
02636         str = (trm1r * z3r - trm1i * z3i) / d1;
02637         trm1i = (trm1r * z3i + trm1i * z3r) / d1;
02638         trm1r = str;
02639         s1r += trm1r;
02640         s1i += trm1i;
02641         str = (trm2r * z3r - trm2i * z3i) / d2;
02642         trm2i = (trm2r * z3i + trm2i * z3r) / d2;
02643         trm2r = str;
02644         s2r += trm2r;
02645         s2i += trm2i;
02646         atrm = atrm * az3 / ad;
02647         d1 += ak;
02648         d2 += bk;
02649         ad = min(d1,d2);
02650         if (atrm < tol * ad) {
02651             goto L40;
02652         }
02653         ak += 18.;
02654         bk += 18.;
02655 /* L30: */
02656     }
02657 L40:
02658     if (*id == 1) {
02659         goto L50;
02660     }
02661     *bir = c1 * s1r + c2 * (*zr * s2r - *zi * s2i);
02662     *bii = c1 * s1i + c2 * (*zr * s2i + *zi * s2r);
02663     if (*kode == 1) {
02664         return 0;
02665     }
02666     zzzsqrt_(zr, zi, &str, &sti);
02667     ztar = tth * (*zr * str - *zi * sti);
02668     ztai = tth * (*zr * sti + *zi * str);
02669     aa = ztar;
02670     aa = -abs(aa);
02671     eaa = exp(aa);
02672     *bir *= eaa;
02673     *bii *= eaa;
02674     return 0;
02675 L50:
02676     *bir = s2r * c2;
02677     *bii = s2i * c2;
02678     if (az <= tol) {
02679         goto L60;
02680     }
02681     cc = c1 / (fid + 1.);
02682     str = s1r * *zr - s1i * *zi;
02683     sti = s1r * *zi + s1i * *zr;
02684     *bir += cc * (str * *zr - sti * *zi);
02685     *bii += cc * (str * *zi + sti * *zr);
02686 L60:
02687     if (*kode == 1) {
02688         return 0;
02689     }
02690     zzzsqrt_(zr, zi, &str, &sti);
02691     ztar = tth * (*zr * str - *zi * sti);
02692     ztai = tth * (*zr * sti + *zi * str);
02693     aa = ztar;
02694     aa = -abs(aa);
02695     eaa = exp(aa);
02696     *bir *= eaa;
02697     *bii *= eaa;
02698     return 0;
02699 /* ----------------------------------------------------------------------- */
02700 /*     CASE FOR CABS(Z).GT.1.0 */
02701 /* ----------------------------------------------------------------------- */
02702 L70:
02703     fnu = (fid + 1.) / 3.;
02704 /* ----------------------------------------------------------------------- */
02705 /*     SET PARAMETERS RELATED TO MACHINE CONSTANTS. */
02706 /*     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. */
02707 /*     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. */
02708 /*     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND */
02709 /*     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR */
02710 /*     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. */
02711 /*     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. */
02712 /*     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). */
02713 /*     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. */
02714 /* ----------------------------------------------------------------------- */
02715     k1 = i1mach_(&c__15);
02716     k2 = i1mach_(&c__16);
02717     r1m5 = d1mach_(&c__5);
02718 /* Computing MIN */
02719     i__1 = abs(k1), i__2 = abs(k2);
02720     k = min(i__1,i__2);
02721     elim = ((doublereal) ((real) k) * r1m5 - 3.) * 2.303;
02722     k1 = i1mach_(&c__14) - 1;
02723     aa = r1m5 * (doublereal) ((real) k1);
02724     dig = min(aa,18.);
02725     aa *= 2.303;
02726 /* Computing MAX */
02727     d__1 = -aa;
02728     alim = elim + max(d__1,-41.45);
02729     rl = dig * 1.2 + 3.;
02730     fnul = (dig - 3.) * 6. + 10.;
02731 /* ----------------------------------------------------------------------- */
02732 /*     TEST FOR RANGE */
02733 /* ----------------------------------------------------------------------- */
02734     aa = .5 / tol;
02735     bb = (doublereal) ((real) i1mach_(&c__9)) * .5;
02736     aa = min(aa,bb);
02737     aa = pow(aa, tth);
02738     if (az > aa) {
02739         goto L260;
02740     }
02741     aa = sqrt(aa);
02742     if (az > aa) {
02743         *ierr = 3;
02744     }
02745     zzzsqrt_(zr, zi, &csqr, &csqi);
02746     ztar = tth * (*zr * csqr - *zi * csqi);
02747     ztai = tth * (*zr * csqi + *zi * csqr);
02748 /* ----------------------------------------------------------------------- */
02749 /*     RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL */
02750 /* ----------------------------------------------------------------------- */
02751     sfac = 1.;
02752     ak = ztai;
02753     if (*zr >= 0.) {
02754         goto L80;
02755     }
02756     bk = ztar;
02757     ck = -abs(bk);
02758     ztar = ck;
02759     ztai = ak;
02760 L80:
02761     if (*zi != 0. || *zr > 0.) {
02762         goto L90;
02763     }
02764     ztar = 0.;
02765     ztai = ak;
02766 L90:
02767     aa = ztar;
02768     if (*kode == 2) {
02769         goto L100;
02770     }
02771 /* ----------------------------------------------------------------------- */
02772 /*     OVERFLOW TEST */
02773 /* ----------------------------------------------------------------------- */
02774     bb = abs(aa);
02775     if (bb < alim) {
02776         goto L100;
02777     }
02778     bb += log(az) * .25;
02779     sfac = tol;
02780     if (bb > elim) {
02781         goto L190;
02782     }
02783 L100:
02784     fmr = 0.;
02785     if (aa >= 0. && *zr > 0.) {
02786         goto L110;
02787     }
02788     fmr = pi;
02789     if (*zi < 0.) {
02790         fmr = -pi;
02791     }
02792     ztar = -ztar;
02793     ztai = -ztai;
02794 L110:
02795 /* ----------------------------------------------------------------------- */
02796 /*     AA=FACTOR FOR ANALYTIC CONTINUATION OF I(FNU,ZTA) */
02797 /*     KODE=2 RETURNS EXP(-ABS(XZTA))*I(FNU,ZTA) FROM ZBESI */
02798 /* ----------------------------------------------------------------------- */
02799     zbinu_(&ztar, &ztai, &fnu, kode, &c__1, cyr, cyi, &nz, &rl, &fnul, &tol, &
02800             elim, &alim);
02801     if (nz < 0) {
02802         goto L200;
02803     }
02804     aa = fmr * fnu;
02805     z3r = sfac;
02806     str = cos(aa);
02807     sti = sin(aa);
02808     s1r = (str * cyr[0] - sti * cyi[0]) * z3r;
02809     s1i = (str * cyi[0] + sti * cyr[0]) * z3r;
02810     fnu = (2. - fid) / 3.;
02811     zbinu_(&ztar, &ztai, &fnu, kode, &c__2, cyr, cyi, &nz, &rl, &fnul, &tol, &
02812             elim, &alim);
02813     cyr[0] *= z3r;
02814     cyi[0] *= z3r;
02815     cyr[1] *= z3r;
02816     cyi[1] *= z3r;
02817 /* ----------------------------------------------------------------------- */
02818 /*     BACKWARD RECUR ONE STEP FOR ORDERS -1/3 OR -2/3 */
02819 /* ----------------------------------------------------------------------- */
02820     zdiv_(cyr, cyi, &ztar, &ztai, &str, &sti);
02821     s2r = (fnu + fnu) * str + cyr[1];
02822     s2i = (fnu + fnu) * sti + cyi[1];
02823     aa = fmr * (fnu - 1.);
02824     str = cos(aa);
02825     sti = sin(aa);
02826     s1r = coef * (s1r + s2r * str - s2i * sti);
02827     s1i = coef * (s1i + s2r * sti + s2i * str);
02828     if (*id == 1) {
02829         goto L120;
02830     }
02831     str = csqr * s1r - csqi * s1i;
02832     s1i = csqr * s1i + csqi * s1r;
02833     s1r = str;
02834     *bir = s1r / sfac;
02835     *bii = s1i / sfac;
02836     return 0;
02837 L120:
02838     str = *zr * s1r - *zi * s1i;
02839     s1i = *zr * s1i + *zi * s1r;
02840     s1r = str;
02841     *bir = s1r / sfac;
02842     *bii = s1i / sfac;
02843     return 0;
02844 L130:
02845     aa = c1 * (1. - fid) + fid * c2;
02846     *bir = aa;
02847     *bii = 0.;
02848     return 0;
02849 L190:
02850     *ierr = 2;
02851     nz = 0;
02852     return 0;
02853 L200:
02854     if (nz == -1) {
02855         goto L190;
02856     }
02857     nz = 0;
02858     *ierr = 5;
02859     return 0;
02860 L260:
02861     *ierr = 4;
02862     nz = 0;
02863     return 0;
02864 } /* zbiry_ */
02865 
02866 /* Subroutine */ int zmlt_(doublereal *ar, doublereal *ai, doublereal *br, 
02867         doublereal *bi, doublereal *cr, doublereal *ci)
02868 {
02869     static doublereal ca, cb;
02870 
02871 /* ***BEGIN PROLOGUE  ZMLT */
02872 /* ***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY */
02873 
02874 /*     DOUBLE PRECISION COMPLEX MULTIPLY, C=A*B. */
02875 
02876 /* ***ROUTINES CALLED  (NONE) */
02877 /* ***END PROLOGUE  ZMLT */
02878     ca = *ar * *br - *ai * *bi;
02879     cb = *ar * *bi + *ai * *br;
02880     *cr = ca;
02881     *ci = cb;
02882     return 0;
02883 } /* zmlt_ */
02884 
02885 /* Subroutine */ int zdiv_(doublereal *ar, doublereal *ai, doublereal *br, 
02886         doublereal *bi, doublereal *cr, doublereal *ci)
02887 {
02888     static doublereal ca, cb, cc, cd, bm;
02889     extern doublereal zabs_(doublereal *, doublereal *);
02890 
02891 /* ***BEGIN PROLOGUE  ZDIV */
02892 /* ***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY */
02893 
02894 /*     DOUBLE PRECISION COMPLEX DIVIDE C=A/B. */
02895 
02896 /* ***ROUTINES CALLED  ZABS */
02897 /* ***END PROLOGUE  ZDIV */
02898     bm = 1. / zabs_(br, bi);
02899     cc = *br * bm;
02900     cd = *bi * bm;
02901     ca = (*ar * cc + *ai * cd) * bm;
02902     cb = (*ai * cc - *ar * cd) * bm;
02903     *cr = ca;
02904     *ci = cb;
02905     return 0;
02906 } /* zdiv_ */
02907 
02908 /* Subroutine */ int zzzsqrt_(doublereal *ar, doublereal *ai, doublereal *br, 
02909         doublereal *bi)
02910 {
02911     /* Initialized data */
02912 
02913     static doublereal drt = .7071067811865475244008443621;
02914     static doublereal dpi = 3.141592653589793238462643383;
02915 
02916     /* Builtin functions */
02917     double sqrt(doublereal), atan(doublereal), cos(doublereal), sin(
02918             doublereal);
02919 
02920     /* Local variables */
02921     static doublereal zm;
02922     extern doublereal zabs_(doublereal *, doublereal *);
02923     static doublereal dtheta;
02924 
02925 /* ***BEGIN PROLOGUE  ZZZSQRT */
02926 /* ***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY */
02927 
02928 /*     DOUBLE PRECISION COMPLEX SQUARE ROOT, B=CSQRT(A) */
02929 
02930 /* ***ROUTINES CALLED  ZABS */
02931 /* ***END PROLOGUE  ZZZSQRT */
02932     zm = zabs_(ar, ai);
02933     zm = sqrt(zm);
02934     if (*ar == 0.) {
02935         goto L10;
02936     }
02937     if (*ai == 0.) {
02938         goto L20;
02939     }
02940     dtheta = atan(*ai / *ar);
02941     if (dtheta <= 0.) {
02942         goto L40;
02943     }
02944     if (*ar < 0.) {
02945         dtheta -= dpi;
02946     }
02947     goto L50;
02948 L10:
02949     if (*ai > 0.) {
02950         goto L60;
02951     }
02952     if (*ai < 0.) {
02953         goto L70;
02954     }
02955     *br = 0.;
02956     *bi = 0.;
02957     return 0;
02958 L20:
02959     if (*ar > 0.) {
02960         goto L30;
02961     }
02962     *br = 0.;
02963     *bi = sqrt((abs(*ar)));
02964     return 0;
02965 L30:
02966     *br = sqrt(*ar);
02967     *bi = 0.;
02968     return 0;
02969 L40:
02970     if (*ar < 0.) {
02971         dtheta += dpi;
02972     }
02973 L50:
02974     dtheta *= .5;
02975     *br = zm * cos(dtheta);
02976     *bi = zm * sin(dtheta);
02977     return 0;
02978 L60:
02979     *br = zm * drt;
02980     *bi = zm * drt;
02981     return 0;
02982 L70:
02983     *br = zm * drt;
02984     *bi = -zm * drt;
02985     return 0;
02986 } /* zzzsqrt_ */
02987 
02988 /* Subroutine */ int zzzexp_(doublereal *ar, doublereal *ai, doublereal *br, 
02989         doublereal *bi)
02990 {
02991     /* Builtin functions */
02992     double exp(doublereal), cos(doublereal), sin(doublereal);
02993 
02994     /* Local variables */
02995     static doublereal ca, cb, zm;
02996 
02997 /* ***BEGIN PROLOGUE  ZZZEXP */
02998 /* ***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY */
02999 
03000 /*     DOUBLE PRECISION COMPLEX EXPONENTIAL FUNCTION B=EXP(A) */
03001 
03002 /* ***ROUTINES CALLED  (NONE) */
03003 /* ***END PROLOGUE  ZZZEXP */
03004     zm = exp(*ar);
03005     ca = zm * cos(*ai);
03006     cb = zm * sin(*ai);
03007     *br = ca;
03008     *bi = cb;
03009     return 0;
03010 } /* zzzexp_ */
03011 
03012 /* Subroutine */ int zzzlog_(doublereal *ar, doublereal *ai, doublereal *br, 
03013         doublereal *bi, integer *ierr)
03014 {
03015     /* Initialized data */
03016 
03017     static doublereal dpi = 3.141592653589793238462643383;
03018     static doublereal dhpi = 1.570796326794896619231321696;
03019 
03020     /* Builtin functions */
03021     double atan(doublereal), log(doublereal);
03022 
03023     /* Local variables */
03024     static doublereal zm;
03025     extern doublereal zabs_(doublereal *, doublereal *);
03026     static doublereal dtheta;
03027 
03028 /* ***BEGIN PROLOGUE  ZZZLOG */
03029 /* ***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY */
03030 
03031 /*     DOUBLE PRECISION COMPLEX LOGARITHM B=CLOG(A) */
03032 /*     IERR=0,NORMAL RETURN      IERR=1, Z=CMPLX(0.0,0.0) */
03033 /* ***ROUTINES CALLED  ZABS */
03034 /* ***END PROLOGUE  ZZZLOG */
03035 
03036     *ierr = 0;
03037     if (*ar == 0.) {
03038         goto L10;
03039     }
03040     if (*ai == 0.) {
03041         goto L20;
03042     }
03043     dtheta = atan(*ai / *ar);
03044     if (dtheta <= 0.) {
03045         goto L40;
03046     }
03047     if (*ar < 0.) {
03048         dtheta -= dpi;
03049     }
03050     goto L50;
03051 L10:
03052     if (*ai == 0.) {
03053         goto L60;
03054     }
03055     *bi = dhpi;
03056     *br = log((abs(*ai)));
03057     if (*ai < 0.) {
03058         *bi = -(*bi);
03059     }
03060     return 0;
03061 L20:
03062     if (*ar > 0.) {
03063         goto L30;
03064     }
03065     *br = log((abs(*ar)));
03066     *bi = dpi;
03067     return 0;
03068 L30:
03069     *br = log(*ar);
03070     *bi = 0.;
03071     return 0;
03072 L40:
03073     if (*ar < 0.) {
03074         dtheta += dpi;
03075     }
03076 L50:
03077     zm = zabs_(ar, ai);
03078     *br = log(zm);
03079     *bi = dtheta;
03080     return 0;
03081 L60:
03082     *ierr = 1;
03083     return 0;
03084 } /* zzzlog_ */
03085 
03086 doublereal zabs_(doublereal *zr, doublereal *zi)
03087 {
03088     /* System generated locals */
03089     doublereal ret_val;
03090 
03091     /* Builtin functions */
03092     double sqrt(doublereal);
03093 
03094     /* Local variables */
03095     static doublereal q, s, u, v;
03096 
03097 /* ***BEGIN PROLOGUE  ZABS */
03098 /* ***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY */
03099 
03100 /*     ZABS COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE */
03101 /*     PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI) */
03102 
03103 /* ***ROUTINES CALLED  (NONE) */
03104 /* ***END PROLOGUE  ZABS */
03105     u = abs(*zr);
03106     v = abs(*zi);
03107     s = u + v;
03108 /* ----------------------------------------------------------------------- */
03109 /*     S*1.0D0 MAKES AN UNNORMALIZED UNDERFLOW ON CDC MACHINES INTO A */
03110 /*     TRUE FLOATING ZERO */
03111 /* ----------------------------------------------------------------------- */
03112     s *= 1.;
03113     if (s == 0.) {
03114         goto L20;
03115     }
03116     if (u > v) {
03117         goto L10;
03118     }
03119     q = u / v;
03120     ret_val = v * sqrt(q * q + 1.);
03121     return ret_val;
03122 L10:
03123     q = v / u;
03124     ret_val = u * sqrt(q * q + 1.);
03125     return ret_val;
03126 L20:
03127     ret_val = 0.;
03128     return ret_val;
03129 } /* zabs_ */
03130 
03131 /* Subroutine */ int zbknu_(doublereal *zr, doublereal *zi, doublereal *fnu, 
03132         integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
03133         nz, doublereal *tol, doublereal *elim, doublereal *alim)
03134 {
03135     /* Initialized data */
03136 
03137     static integer kmax = 30;
03138     static doublereal czeror = 0.;
03139     static doublereal czeroi = 0.;
03140     static doublereal coner = 1.;
03141     static doublereal conei = 0.;
03142     static doublereal ctwor = 2.;
03143     static doublereal r1 = 2.;
03144     static doublereal dpi = 3.14159265358979324;
03145     static doublereal rthpi = 1.25331413731550025;
03146     static doublereal spi = 1.90985931710274403;
03147     static doublereal hpi = 1.57079632679489662;
03148     static doublereal fpi = 1.89769999331517738;
03149     static doublereal tth = .666666666666666666;
03150     static doublereal cc[8] = { .577215664901532861,-.0420026350340952355,
03151             -.0421977345555443367,.00721894324666309954,
03152             -2.15241674114950973e-4,-2.01348547807882387e-5,
03153             1.13302723198169588e-6,6.11609510448141582e-9 };
03154 
03155     /* System generated locals */
03156     integer i__1;
03157     doublereal d__1;
03158 
03159     /* Builtin functions */
03160     double sin(doublereal), exp(doublereal), cos(doublereal), atan(doublereal)
03161             , sqrt(doublereal), log(doublereal);
03162 
03163     /* Local variables */
03164     extern /* Subroutine */ int zzzsqrt_(doublereal *, doublereal *, 
03165             doublereal *, doublereal *);
03166     static integer i__, j, k;
03167     static doublereal s, a1, a2, g1, g2, t1, t2, aa, bb, fc, ak, bk;
03168     static integer ic;
03169     static doublereal fi, fk, as;
03170     static integer kk;
03171     static doublereal fr, pi, qi, tm, pr, qr;
03172     static integer nw;
03173     static doublereal p1i, p2i, s1i, s2i, p2m, p1r, p2r, s1r, s2r, cbi, cbr, 
03174             cki, caz, csi, ckr, fhs, fks, rak, czi, dnu, csr, elm, zdi, bry[3]
03175             , pti, czr, sti, zdr, cyr[2], rzi, ptr, cyi[2];
03176     static integer inu;
03177     static doublereal str, rzr, dnu2, cchi, cchr, alas, cshi;
03178     static integer inub, idum;
03179     extern doublereal zabs_(doublereal *, doublereal *);
03180     static doublereal cshr, fmui, rcaz, csrr[3], cssr[3], fmur;
03181     extern /* Subroutine */ int zdiv_(doublereal *, doublereal *, doublereal *
03182             , doublereal *, doublereal *, doublereal *);
03183     static doublereal smui, smur;
03184     extern /* Subroutine */ int zmlt_(doublereal *, doublereal *, doublereal *
03185             , doublereal *, doublereal *, doublereal *);
03186     static integer iflag, kflag;
03187     static doublereal coefi;
03188     static integer koded;
03189     static doublereal ascle, coefr, helim, celmr, csclr, crscr;
03190     extern /* Subroutine */ int zshch_(doublereal *, doublereal *, doublereal 
03191             *, doublereal *, doublereal *, doublereal *);
03192     static doublereal etest;
03193     extern /* Subroutine */ int zuchk_(doublereal *, doublereal *, integer *, 
03194             doublereal *, doublereal *), zkscl_(doublereal *, doublereal *, 
03195             doublereal *, integer *, doublereal *, doublereal *, integer *, 
03196             doublereal *, doublereal *, doublereal *, doublereal *, 
03197             doublereal *);
03198     extern doublereal d1mach_(integer *);
03199     extern integer i1mach_(integer *);
03200     extern doublereal dgamln_(doublereal *, integer *);
03201     extern /* Subroutine */ int zzzlog_(doublereal *, doublereal *, 
03202             doublereal *, doublereal *, integer *), zzzexp_(doublereal *, 
03203             doublereal *, doublereal *, doublereal *);
03204 
03205 /* ***BEGIN PROLOGUE  ZBKNU */
03206 /* ***REFER TO  ZBESI,ZBESK,ZAIRY,ZBESH */
03207 
03208 /*     ZBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE. */
03209 
03210 /* ***ROUTINES CALLED  DGAMLN,I1MACH,D1MACH,ZKSCL,ZSHCH,ZUCHK,ZABS,ZDIV, */
03211 /*                    ZZZEXP,ZZZLOG,ZMLT,ZZZSQRT */
03212 /* ***END PROLOGUE  ZBKNU */
03213 
03214 /*     COMPLEX Z,Y,A,B,RZ,SMU,FU,FMU,F,FLRZ,CZ,S1,S2,CSH,CCH */
03215 /*     COMPLEX CK,P,Q,COEF,P1,P2,CBK,PT,CZERO,CONE,CTWO,ST,EZ,CS,DK */
03216 
03217     /* Parameter adjustments */
03218     --yi;
03219     --yr;
03220 
03221     /* Function Body */
03222 
03223     caz = zabs_(zr, zi);
03224     csclr = 1. / *tol;
03225     crscr = *tol;
03226     cssr[0] = csclr;
03227     cssr[1] = 1.;
03228     cssr[2] = crscr;
03229     csrr[0] = crscr;
03230     csrr[1] = 1.;
03231     csrr[2] = csclr;
03232     bry[0] = d1mach_(&c__1) * 1e3 / *tol;
03233     bry[1] = 1. / bry[0];
03234     bry[2] = d1mach_(&c__2);
03235     *nz = 0;
03236     iflag = 0;
03237     koded = *kode;
03238     rcaz = 1. / caz;
03239     str = *zr * rcaz;
03240     sti = -(*zi) * rcaz;
03241     rzr = (str + str) * rcaz;
03242     rzi = (sti + sti) * rcaz;
03243     inu = (integer) ((real) (*fnu + .5));
03244     dnu = *fnu - (doublereal) ((real) inu);
03245     if (abs(dnu) == .5) {
03246         goto L110;
03247     }
03248     dnu2 = 0.;
03249     if (abs(dnu) > *tol) {
03250         dnu2 = dnu * dnu;
03251     }
03252     if (caz > r1) {
03253         goto L110;
03254     }
03255 /* ----------------------------------------------------------------------- */
03256 /*     SERIES FOR CABS(Z).LE.R1 */
03257 /* ----------------------------------------------------------------------- */
03258     fc = 1.;
03259     zzzlog_(&rzr, &rzi, &smur, &smui, &idum);
03260     fmur = smur * dnu;
03261     fmui = smui * dnu;
03262     zshch_(&fmur, &fmui, &cshr, &cshi, &cchr, &cchi);
03263     if (dnu == 0.) {
03264         goto L10;
03265     }
03266     fc = dnu * dpi;
03267     fc /= sin(fc);
03268     smur = cshr / dnu;
03269     smui = cshi / dnu;
03270 L10:
03271     a2 = dnu + 1.;
03272 /* ----------------------------------------------------------------------- */
03273 /*     GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU), T2=1/GAM(1+DNU) */
03274 /* ----------------------------------------------------------------------- */
03275     t2 = exp(-dgamln_(&a2, &idum));
03276     t1 = 1. / (t2 * fc);
03277     if (abs(dnu) > .1) {
03278         goto L40;
03279     }
03280 /* ----------------------------------------------------------------------- */
03281 /*     SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) */
03282 /* ----------------------------------------------------------------------- */
03283     ak = 1.;
03284     s = cc[0];
03285     for (k = 2; k <= 8; ++k) {
03286         ak *= dnu2;
03287         tm = cc[k - 1] * ak;
03288         s += tm;
03289         if (abs(tm) < *tol) {
03290             goto L30;
03291         }
03292 /* L20: */
03293     }
03294 L30:
03295     g1 = -s;
03296     goto L50;
03297 L40:
03298     g1 = (t1 - t2) / (dnu + dnu);
03299 L50:
03300     g2 = (t1 + t2) * .5;
03301     fr = fc * (cchr * g1 + smur * g2);
03302     fi = fc * (cchi * g1 + smui * g2);
03303     zzzexp_(&fmur, &fmui, &str, &sti);
03304     pr = str * .5 / t2;
03305     pi = sti * .5 / t2;
03306     zdiv_(&c_b168, &c_b169, &str, &sti, &ptr, &pti);
03307     qr = ptr / t1;
03308     qi = pti / t1;
03309     s1r = fr;
03310     s1i = fi;
03311     s2r = pr;
03312     s2i = pi;
03313     ak = 1.;
03314     a1 = 1.;
03315     ckr = coner;
03316     cki = conei;
03317     bk = 1. - dnu2;
03318     if (inu > 0 || *n > 1) {
03319         goto L80;
03320     }
03321 /* ----------------------------------------------------------------------- */
03322 /*     GENERATE K(FNU,Z), 0.0D0 .LE. FNU .LT. 0.5D0 AND N=1 */
03323 /* ----------------------------------------------------------------------- */
03324     if (caz < *tol) {
03325         goto L70;
03326     }
03327     zmlt_(zr, zi, zr, zi, &czr, &czi);
03328     czr *= .25;
03329     czi *= .25;
03330     t1 = caz * .25 * caz;
03331 L60:
03332     fr = (fr * ak + pr + qr) / bk;
03333     fi = (fi * ak + pi + qi) / bk;
03334     str = 1. / (ak - dnu);
03335     pr *= str;
03336     pi *= str;
03337     str = 1. / (ak + dnu);
03338     qr *= str;
03339     qi *= str;
03340     str = ckr * czr - cki * czi;
03341     rak = 1. / ak;
03342     cki = (ckr * czi + cki * czr) * rak;
03343     ckr = str * rak;
03344     s1r = ckr * fr - cki * fi + s1r;
03345     s1i = ckr * fi + cki * fr + s1i;
03346     a1 = a1 * t1 * rak;
03347     bk = bk + ak + ak + 1.;
03348     ak += 1.;
03349     if (a1 > *tol) {
03350         goto L60;
03351     }
03352 L70:
03353     yr[1] = s1r;
03354     yi[1] = s1i;
03355     if (koded == 1) {
03356         return 0;
03357     }
03358     zzzexp_(zr, zi, &str, &sti);
03359     zmlt_(&s1r, &s1i, &str, &sti, &yr[1], &yi[1]);
03360     return 0;
03361 /* ----------------------------------------------------------------------- */
03362 /*     GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE */
03363 /* ----------------------------------------------------------------------- */
03364 L80:
03365     if (caz < *tol) {
03366         goto L100;
03367     }
03368     zmlt_(zr, zi, zr, zi, &czr, &czi);
03369     czr *= .25;
03370     czi *= .25;
03371     t1 = caz * .25 * caz;
03372 L90:
03373     fr = (fr * ak + pr + qr) / bk;
03374     fi = (fi * ak + pi + qi) / bk;
03375     str = 1. / (ak - dnu);
03376     pr *= str;
03377     pi *= str;
03378     str = 1. / (ak + dnu);
03379     qr *= str;
03380     qi *= str;
03381     str = ckr * czr - cki * czi;
03382     rak = 1. / ak;
03383     cki = (ckr * czi + cki * czr) * rak;
03384     ckr = str * rak;
03385     s1r = ckr * fr - cki * fi + s1r;
03386     s1i = ckr * fi + cki * fr + s1i;
03387     str = pr - fr * ak;
03388     sti = pi - fi * ak;
03389     s2r = ckr * str - cki * sti + s2r;
03390     s2i = ckr * sti + cki * str + s2i;
03391     a1 = a1 * t1 * rak;
03392     bk = bk + ak + ak + 1.;
03393     ak += 1.;
03394     if (a1 > *tol) {
03395         goto L90;
03396     }
03397 L100:
03398     kflag = 2;
03399     a1 = *fnu + 1.;
03400     ak = a1 * abs(smur);
03401     if (ak > *alim) {
03402         kflag = 3;
03403     }
03404     str = cssr[kflag - 1];
03405     p2r = s2r * str;
03406     p2i = s2i * str;
03407     zmlt_(&p2r, &p2i, &rzr, &rzi, &s2r, &s2i);
03408     s1r *= str;
03409     s1i *= str;
03410     if (koded == 1) {
03411         goto L210;
03412     }
03413     zzzexp_(zr, zi, &fr, &fi);
03414     zmlt_(&s1r, &s1i, &fr, &fi, &s1r, &s1i);
03415     zmlt_(&s2r, &s2i, &fr, &fi, &s2r, &s2i);
03416     goto L210;
03417 /* ----------------------------------------------------------------------- */
03418 /*     IFLAG=0 MEANS NO UNDERFLOW OCCURRED */
03419 /*     IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH */
03420 /*     KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD */
03421 /*     RECURSION */
03422 /* ----------------------------------------------------------------------- */
03423 L110:
03424     zzzsqrt_(zr, zi, &str, &sti);
03425     zdiv_(&rthpi, &czeroi, &str, &sti, &coefr, &coefi);
03426     kflag = 2;
03427     if (koded == 2) {
03428         goto L120;
03429     }
03430     if (*zr > *alim) {
03431         goto L290;
03432     }
03433 /*     BLANK LINE */
03434     str = exp(-(*zr)) * cssr[kflag - 1];
03435     sti = -str * sin(*zi);
03436     str *= cos(*zi);
03437     zmlt_(&coefr, &coefi, &str, &sti, &coefr, &coefi);
03438 L120:
03439     if (abs(dnu) == .5) {
03440         goto L300;
03441     }
03442 /* ----------------------------------------------------------------------- */
03443 /*     MILLER ALGORITHM FOR CABS(Z).GT.R1 */
03444 /* ----------------------------------------------------------------------- */
03445     ak = cos(dpi * dnu);
03446     ak = abs(ak);
03447     if (ak == czeror) {
03448         goto L300;
03449     }
03450     fhs = (d__1 = .25 - dnu2, abs(d__1));
03451     if (fhs == czeror) {
03452         goto L300;
03453     }
03454 /* ----------------------------------------------------------------------- */
03455 /*     COMPUTE R2=F(E). IF CABS(Z).GE.R2, USE FORWARD RECURRENCE TO */
03456 /*     DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT LINE ON */
03457 /*     12.LE.E.LE.60. E IS COMPUTED FROM 2**(-E)=B**(1-I1MACH(14))= */
03458 /*     TOL WHERE B IS THE BASE OF THE ARITHMETIC. */
03459 /* ----------------------------------------------------------------------- */
03460     t1 = (doublereal) ((real) (i1mach_(&c__14) - 1));
03461     t1 = t1 * d1mach_(&c__5) * 3.321928094;
03462     t1 = max(t1,12.);
03463     t1 = min(t1,60.);
03464     t2 = tth * t1 - 6.;
03465     if (*zr != 0.) {
03466         goto L130;
03467     }
03468     t1 = hpi;
03469     goto L140;
03470 L130:
03471     t1 = atan(*zi / *zr);
03472     t1 = abs(t1);
03473 L140:
03474     if (t2 > caz) {
03475         goto L170;
03476     }
03477 /* ----------------------------------------------------------------------- */
03478 /*     FORWARD RECURRENCE LOOP WHEN CABS(Z).GE.R2 */
03479 /* ----------------------------------------------------------------------- */
03480     etest = ak / (dpi * caz * *tol);
03481     fk = coner;
03482     if (etest < coner) {
03483         goto L180;
03484     }
03485     fks = ctwor;
03486     ckr = caz + caz + ctwor;
03487     p1r = czeror;
03488     p2r = coner;
03489     i__1 = kmax;
03490     for (i__ = 1; i__ <= i__1; ++i__) {
03491         ak = fhs / fks;
03492         cbr = ckr / (fk + coner);
03493         ptr = p2r;
03494         p2r = cbr * p2r - p1r * ak;
03495         p1r = ptr;
03496         ckr += ctwor;
03497         fks = fks + fk + fk + ctwor;
03498         fhs = fhs + fk + fk;
03499         fk += coner;
03500         str = abs(p2r) * fk;
03501         if (etest < str) {
03502             goto L160;
03503         }
03504 /* L150: */
03505     }
03506     goto L310;
03507 L160:
03508     fk += spi * t1 * sqrt(t2 / caz);
03509     fhs = (d__1 = .25 - dnu2, abs(d__1));
03510     goto L180;
03511 L170:
03512 /* ----------------------------------------------------------------------- */
03513 /*     COMPUTE BACKWARD INDEX K FOR CABS(Z).LT.R2 */
03514 /* ----------------------------------------------------------------------- */
03515     a2 = sqrt(caz);
03516     ak = fpi * ak / (*tol * sqrt(a2));
03517     aa = t1 * 3. / (caz + 1.);
03518     bb = t1 * 14.7 / (caz + 28.);
03519     ak = (log(ak) + caz * cos(aa) / (caz * .008 + 1.)) / cos(bb);
03520     fk = ak * .12125 * ak / caz + 1.5;
03521 L180:
03522 /* ----------------------------------------------------------------------- */
03523 /*     BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM */
03524 /* ----------------------------------------------------------------------- */
03525     k = (integer) ((real) fk);
03526     fk = (doublereal) ((real) k);
03527     fks = fk * fk;
03528     p1r = czeror;
03529     p1i = czeroi;
03530     p2r = *tol;
03531     p2i = czeroi;
03532     csr = p2r;
03533     csi = p2i;
03534     i__1 = k;
03535     for (i__ = 1; i__ <= i__1; ++i__) {
03536         a1 = fks - fk;
03537         ak = (fks + fk) / (a1 + fhs);
03538         rak = 2. / (fk + coner);
03539         cbr = (fk + *zr) * rak;
03540         cbi = *zi * rak;
03541         ptr = p2r;
03542         pti = p2i;
03543         p2r = (ptr * cbr - pti * cbi - p1r) * ak;
03544         p2i = (pti * cbr + ptr * cbi - p1i) * ak;
03545         p1r = ptr;
03546         p1i = pti;
03547         csr += p2r;
03548         csi += p2i;
03549         fks = a1 - fk + coner;
03550         fk -= coner;
03551 /* L190: */
03552     }
03553 /* ----------------------------------------------------------------------- */
03554 /*     COMPUTE (P2/CS)=(P2/CABS(CS))*(CONJG(CS)/CABS(CS)) FOR BETTER */
03555 /*     SCALING */
03556 /* ----------------------------------------------------------------------- */
03557     tm = zabs_(&csr, &csi);
03558     ptr = 1. / tm;
03559     s1r = p2r * ptr;
03560     s1i = p2i * ptr;
03561     csr *= ptr;
03562     csi = -csi * ptr;
03563     zmlt_(&coefr, &coefi, &s1r, &s1i, &str, &sti);
03564     zmlt_(&str, &sti, &csr, &csi, &s1r, &s1i);
03565     if (inu > 0 || *n > 1) {
03566         goto L200;
03567     }
03568     zdr = *zr;
03569     zdi = *zi;
03570     if (iflag == 1) {
03571         goto L270;
03572     }
03573     goto L240;
03574 L200:
03575 /* ----------------------------------------------------------------------- */
03576 /*     COMPUTE P1/P2=(P1/CABS(P2)*CONJG(P2)/CABS(P2) FOR SCALING */
03577 /* ----------------------------------------------------------------------- */
03578     tm = zabs_(&p2r, &p2i);
03579     ptr = 1. / tm;
03580     p1r *= ptr;
03581     p1i *= ptr;
03582     p2r *= ptr;
03583     p2i = -p2i * ptr;
03584     zmlt_(&p1r, &p1i, &p2r, &p2i, &ptr, &pti);
03585     str = dnu + .5 - ptr;
03586     sti = -pti;
03587     zdiv_(&str, &sti, zr, zi, &str, &sti);
03588     str += 1.;
03589     zmlt_(&str, &sti, &s1r, &s1i, &s2r, &s2i);
03590 /* ----------------------------------------------------------------------- */
03591 /*     FORWARD RECURSION ON THE THREE TERM RECURSION WITH RELATION WITH */
03592 /*     SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3 */
03593 /* ----------------------------------------------------------------------- */
03594 L210:
03595     str = dnu + 1.;
03596     ckr = str * rzr;
03597     cki = str * rzi;
03598     if (*n == 1) {
03599         --inu;
03600     }
03601     if (inu > 0) {
03602         goto L220;
03603     }
03604     if (*n > 1) {
03605         goto L215;
03606     }
03607     s1r = s2r;
03608     s1i = s2i;
03609 L215:
03610     zdr = *zr;
03611     zdi = *zi;
03612     if (iflag == 1) {
03613         goto L270;
03614     }
03615     goto L240;
03616 L220:
03617     inub = 1;
03618     if (iflag == 1) {
03619         goto L261;
03620     }
03621 L225:
03622     p1r = csrr[kflag - 1];
03623     ascle = bry[kflag - 1];
03624     i__1 = inu;
03625     for (i__ = inub; i__ <= i__1; ++i__) {
03626         str = s2r;
03627         sti = s2i;
03628         s2r = ckr * str - cki * sti + s1r;
03629         s2i = ckr * sti + cki * str + s1i;
03630         s1r = str;
03631         s1i = sti;
03632         ckr += rzr;
03633         cki += rzi;
03634         if (kflag >= 3) {
03635             goto L230;
03636         }
03637         p2r = s2r * p1r;
03638         p2i = s2i * p1r;
03639         str = abs(p2r);
03640         sti = abs(p2i);
03641         p2m = max(str,sti);
03642         if (p2m <= ascle) {
03643             goto L230;
03644         }
03645         ++kflag;
03646         ascle = bry[kflag - 1];
03647         s1r *= p1r;
03648         s1i *= p1r;
03649         s2r = p2r;
03650         s2i = p2i;
03651         str = cssr[kflag - 1];
03652         s1r *= str;
03653         s1i *= str;
03654         s2r *= str;
03655         s2i *= str;
03656         p1r = csrr[kflag - 1];
03657 L230:
03658         ;
03659     }
03660     if (*n != 1) {
03661         goto L240;
03662     }
03663     s1r = s2r;
03664     s1i = s2i;
03665 L240:
03666     str = csrr[kflag - 1];
03667     yr[1] = s1r * str;
03668     yi[1] = s1i * str;
03669     if (*n == 1) {
03670         return 0;
03671     }
03672     yr[2] = s2r * str;
03673     yi[2] = s2i * str;
03674     if (*n == 2) {
03675         return 0;
03676     }
03677     kk = 2;
03678 L250:
03679     ++kk;
03680     if (kk > *n) {
03681         return 0;
03682     }
03683     p1r = csrr[kflag - 1];
03684     ascle = bry[kflag - 1];
03685     i__1 = *n;
03686     for (i__ = kk; i__ <= i__1; ++i__) {
03687         p2r = s2r;
03688         p2i = s2i;
03689         s2r = ckr * p2r - cki * p2i + s1r;
03690         s2i = cki * p2r + ckr * p2i + s1i;
03691         s1r = p2r;
03692         s1i = p2i;
03693         ckr += rzr;
03694         cki += rzi;
03695         p2r = s2r * p1r;
03696         p2i = s2i * p1r;
03697         yr[i__] = p2r;
03698         yi[i__] = p2i;
03699         if (kflag >= 3) {
03700             goto L260;
03701         }
03702         str = abs(p2r);
03703         sti = abs(p2i);
03704         p2m = max(str,sti);
03705         if (p2m <= ascle) {
03706             goto L260;
03707         }
03708         ++kflag;
03709         ascle = bry[kflag - 1];
03710         s1r *= p1r;
03711         s1i *= p1r;
03712         s2r = p2r;
03713         s2i = p2i;
03714         str = cssr[kflag - 1];
03715         s1r *= str;
03716         s1i *= str;
03717         s2r *= str;
03718         s2i *= str;
03719         p1r = csrr[kflag - 1];
03720 L260:
03721         ;
03722     }
03723     return 0;
03724 /* ----------------------------------------------------------------------- */
03725 /*     IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW */
03726 /* ----------------------------------------------------------------------- */
03727 L261:
03728     helim = *elim * .5;
03729     elm = exp(-(*elim));
03730     celmr = elm;
03731     ascle = bry[0];
03732     zdr = *zr;
03733     zdi = *zi;
03734     ic = -1;
03735     j = 2;
03736     i__1 = inu;
03737     for (i__ = 1; i__ <= i__1; ++i__) {
03738         str = s2r;
03739         sti = s2i;
03740         s2r = str * ckr - sti * cki + s1r;
03741         s2i = sti * ckr + str * cki + s1i;
03742         s1r = str;
03743         s1i = sti;
03744         ckr += rzr;
03745         cki += rzi;
03746         as = zabs_(&s2r, &s2i);
03747         alas = log(as);
03748         p2r = -zdr + alas;
03749         if (p2r < -(*elim)) {
03750             goto L263;
03751         }
03752         zzzlog_(&s2r, &s2i, &str, &sti, &idum);
03753         p2r = -zdr + str;
03754         p2i = -zdi + sti;
03755         p2m = exp(p2r) / *tol;
03756         p1r = p2m * cos(p2i);
03757         p1i = p2m * sin(p2i);
03758         zuchk_(&p1r, &p1i, &nw, &ascle, tol);
03759         if (nw != 0) {
03760             goto L263;
03761         }
03762         j = 3 - j;
03763         cyr[j - 1] = p1r;
03764         cyi[j - 1] = p1i;
03765         if (ic == i__ - 1) {
03766             goto L264;
03767         }
03768         ic = i__;
03769         goto L262;
03770 L263:
03771         if (alas < helim) {
03772             goto L262;
03773         }
03774         zdr -= *elim;
03775         s1r *= celmr;
03776         s1i *= celmr;
03777         s2r *= celmr;
03778         s2i *= celmr;
03779 L262:
03780         ;
03781     }
03782     if (*n != 1) {
03783         goto L270;
03784     }
03785     s1r = s2r;
03786     s1i = s2i;
03787     goto L270;
03788 L264:
03789     kflag = 1;
03790     inub = i__ + 1;
03791     s2r = cyr[j - 1];
03792     s2i = cyi[j - 1];
03793     j = 3 - j;
03794     s1r = cyr[j - 1];
03795     s1i = cyi[j - 1];
03796     if (inub <= inu) {
03797         goto L225;
03798     }
03799     if (*n != 1) {
03800         goto L240;
03801     }
03802     s1r = s2r;
03803     s1i = s2i;
03804     goto L240;
03805 L270:
03806     yr[1] = s1r;
03807     yi[1] = s1i;
03808     if (*n == 1) {
03809         goto L280;
03810     }
03811     yr[2] = s2r;
03812     yi[2] = s2i;
03813 L280:
03814     ascle = bry[0];
03815     zkscl_(&zdr, &zdi, fnu, n, &yr[1], &yi[1], nz, &rzr, &rzi, &ascle, tol, 
03816             elim);
03817     inu = *n - *nz;
03818     if (inu <= 0) {
03819         return 0;
03820     }
03821     kk = *nz + 1;
03822     s1r = yr[kk];
03823     s1i = yi[kk];
03824     yr[kk] = s1r * csrr[0];
03825     yi[kk] = s1i * csrr[0];
03826     if (inu == 1) {
03827         return 0;
03828     }
03829     kk = *nz + 2;
03830     s2r = yr[kk];
03831     s2i = yi[kk];
03832     yr[kk] = s2r * csrr[0];
03833     yi[kk] = s2i * csrr[0];
03834     if (inu == 2) {
03835         return 0;
03836     }
03837     t2 = *fnu + (doublereal) ((real) (kk - 1));
03838     ckr = t2 * rzr;
03839     cki = t2 * rzi;
03840     kflag = 1;
03841     goto L250;
03842 L290:
03843 /* ----------------------------------------------------------------------- */
03844 /*     SCALE BY DEXP(Z), IFLAG = 1 CASES */
03845 /* ----------------------------------------------------------------------- */
03846     koded = 2;
03847     iflag = 1;
03848     kflag = 2;
03849     goto L120;
03850 /* ----------------------------------------------------------------------- */
03851 /*     FNU=HALF ODD INTEGER CASE, DNU=-0.5 */
03852 /* ----------------------------------------------------------------------- */
03853 L300:
03854     s1r = coefr;
03855     s1i = coefi;
03856     s2r = coefr;
03857     s2i = coefi;
03858     goto L210;
03859 
03860 
03861 L310:
03862     *nz = -2;
03863     return 0;
03864 } /* zbknu_ */
03865 
03866 /* Subroutine */ int zkscl_(doublereal *zrr, doublereal *zri, doublereal *fnu,
03867          integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *
03868         rzr, doublereal *rzi, doublereal *ascle, doublereal *tol, doublereal *
03869         elim)
03870 {
03871     /* Initialized data */
03872 
03873     static doublereal zeror = 0.;
03874     static doublereal zeroi = 0.;
03875 
03876     /* System generated locals */
03877     integer i__1;
03878 
03879     /* Builtin functions */
03880     double log(doublereal), exp(doublereal), cos(doublereal), sin(doublereal);
03881 
03882     /* Local variables */
03883     static integer i__, ic;
03884     static doublereal as, fn;
03885     static integer kk, nn, nw;
03886     static doublereal s1i, s2i, s1r, s2r, acs, cki, elm, csi, ckr, cyi[2], 
03887             zdi, csr, cyr[2], zdr, str, alas;
03888     static integer idum;
03889     extern doublereal zabs_(doublereal *, doublereal *);
03890     static doublereal helim, celmr;
03891     extern /* Subroutine */ int zuchk_(doublereal *, doublereal *, integer *, 
03892             doublereal *, doublereal *), zzzlog_(doublereal *, doublereal *, 
03893             doublereal *, doublereal *, integer *);
03894 
03895 /* ***BEGIN PROLOGUE  ZKSCL */
03896 /* ***REFER TO  ZBESK */
03897 
03898 /*     SET K FUNCTIONS TO ZERO ON UNDERFLOW, CONTINUE RECURRENCE */
03899 /*     ON SCALED FUNCTIONS UNTIL TWO MEMBERS COME ON SCALE, THEN */
03900 /*     RETURN WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL. */
03901 
03902 /* ***ROUTINES CALLED  ZUCHK,ZABS,ZZZLOG */
03903 /* ***END PROLOGUE  ZKSCL */
03904 /*     COMPLEX CK,CS,CY,CZERO,RZ,S1,S2,Y,ZR,ZD,CELM */
03905     /* Parameter adjustments */
03906     --yi;
03907     --yr;
03908 
03909     /* Function Body */
03910 
03911     *nz = 0;
03912     ic = 0;
03913     nn = min(2,*n);
03914     i__1 = nn;
03915     for (i__ = 1; i__ <= i__1; ++i__) {
03916         s1r = yr[i__];
03917         s1i = yi[i__];
03918         cyr[i__ - 1] = s1r;
03919         cyi[i__ - 1] = s1i;
03920         as = zabs_(&s1r, &s1i);
03921         acs = -(*zrr) + log(as);
03922         ++(*nz);
03923         yr[i__] = zeror;
03924         yi[i__] = zeroi;
03925         if (acs < -(*elim)) {
03926             goto L10;
03927         }
03928         zzzlog_(&s1r, &s1i, &csr, &csi, &idum);
03929         csr -= *zrr;
03930         csi -= *zri;
03931         str = exp(csr) / *tol;
03932         csr = str * cos(csi);
03933         csi = str * sin(csi);
03934         zuchk_(&csr, &csi, &nw, ascle, tol);
03935         if (nw != 0) {
03936             goto L10;
03937         }
03938         yr[i__] = csr;
03939         yi[i__] = csi;
03940         ic = i__;
03941         --(*nz);
03942 L10:
03943         ;
03944     }
03945     if (*n == 1) {
03946         return 0;
03947     }
03948     if (ic > 1) {
03949         goto L20;
03950     }
03951     yr[1] = zeror;
03952     yi[1] = zeroi;
03953     *nz = 2;
03954 L20:
03955     if (*n == 2) {
03956         return 0;
03957     }
03958     if (*nz == 0) {
03959         return 0;
03960     }
03961     fn = *fnu + 1.;
03962     ckr = fn * *rzr;
03963     cki = fn * *rzi;
03964     s1r = cyr[0];
03965     s1i = cyi[0];
03966     s2r = cyr[1];
03967     s2i = cyi[1];
03968     helim = *elim * .5;
03969     elm = exp(-(*elim));
03970     celmr = elm;
03971     zdr = *zrr;
03972     zdi = *zri;
03973 
03974 /*     FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE RECURRENCE IF */
03975 /*     S2 GETS LARGER THAN EXP(ELIM/2) */
03976 
03977     i__1 = *n;
03978     for (i__ = 3; i__ <= i__1; ++i__) {
03979         kk = i__;
03980         csr = s2r;
03981         csi = s2i;
03982         s2r = ckr * csr - cki * csi + s1r;
03983         s2i = cki * csr + ckr * csi + s1i;
03984         s1r = csr;
03985         s1i = csi;
03986         ckr += *rzr;
03987         cki += *rzi;
03988         as = zabs_(&s2r, &s2i);
03989         alas = log(as);
03990         acs = -zdr + alas;
03991         ++(*nz);
03992         yr[i__] = zeror;
03993         yi[i__] = zeroi;
03994         if (acs < -(*elim)) {
03995             goto L25;
03996         }
03997         zzzlog_(&s2r, &s2i, &csr, &csi, &idum);
03998         csr -= zdr;
03999         csi -= zdi;
04000         str = exp(csr) / *tol;
04001         csr = str * cos(csi);
04002         csi = str * sin(csi);
04003         zuchk_(&csr, &csi, &nw, ascle, tol);
04004         if (nw != 0) {
04005             goto L25;
04006         }
04007         yr[i__] = csr;
04008         yi[i__] = csi;
04009         --(*nz);
04010         if (ic == kk - 1) {
04011             goto L40;
04012         }
04013         ic = kk;
04014         goto L30;
04015 L25:
04016         if (alas < helim) {
04017             goto L30;
04018         }
04019         zdr -= *elim;
04020         s1r *= celmr;
04021         s1i *= celmr;
04022         s2r *= celmr;
04023         s2i *= celmr;
04024 L30:
04025         ;
04026     }
04027     *nz = *n;
04028     if (ic == *n) {
04029         *nz = *n - 1;
04030     }
04031     goto L45;
04032 L40:
04033     *nz = kk - 2;
04034 L45:
04035     i__1 = *nz;
04036     for (i__ = 1; i__ <= i__1; ++i__) {
04037         yr[i__] = zeror;
04038         yi[i__] = zeroi;
04039 /* L50: */
04040     }
04041     return 0;
04042 } /* zkscl_ */
04043 
04044 /* Subroutine */ int zshch_(doublereal *zr, doublereal *zi, doublereal *cshr, 
04045         doublereal *cshi, doublereal *cchr, doublereal *cchi)
04046 {
04047     /* Builtin functions */
04048     double sinh(doublereal), cosh(doublereal), sin(doublereal), cos(
04049             doublereal);
04050 
04051     /* Local variables */
04052     static doublereal ch, cn, sh, sn;
04053 
04054 /* ***BEGIN PROLOGUE  ZSHCH */
04055 /* ***REFER TO  ZBESK,ZBESH */
04056 
04057 /*     ZSHCH COMPUTES THE COMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y) */
04058 /*     AND CCH=COSH(X+I*Y), WHERE I**2=-1. */
04059 
04060 /* ***ROUTINES CALLED  (NONE) */
04061 /* ***END PROLOGUE  ZSHCH */
04062 
04063     sh = sinh(*zr);
04064     ch = cosh(*zr);
04065     sn = sin(*zi);
04066     cn = cos(*zi);
04067     *cshr = sh * cn;
04068     *cshi = ch * sn;
04069     *cchr = ch * cn;
04070     *cchi = sh * sn;
04071     return 0;
04072 } /* zshch_ */
04073 
04074 /* Subroutine */ int zrati_(doublereal *zr, doublereal *zi, doublereal *fnu, 
04075         integer *n, doublereal *cyr, doublereal *cyi, doublereal *tol)
04076 {
04077     /* Initialized data */
04078 
04079     static doublereal czeror = 0.;
04080     static doublereal czeroi = 0.;
04081     static doublereal coner = 1.;
04082     static doublereal conei = 0.;
04083     static doublereal rt2 = 1.41421356237309505;
04084 
04085     /* System generated locals */
04086     integer i__1;
04087     doublereal d__1;
04088 
04089     /* Builtin functions */
04090     double sqrt(doublereal);
04091 
04092     /* Local variables */
04093     static integer i__, k;
04094     static doublereal ak;
04095     static integer id, kk;
04096     static doublereal az, ap1, ap2, p1i, p2i, t1i, p1r, p2r, t1r, arg, rak, 
04097             rho;
04098     static integer inu;
04099     static doublereal pti, tti, rzi, ptr, ttr, rzr, rap1, flam, dfnu, fdnu;
04100     static integer magz;
04101     extern doublereal zabs_(doublereal *, doublereal *);
04102     static integer idnu;
04103     static doublereal fnup;
04104     extern /* Subroutine */ int zdiv_(doublereal *, doublereal *, doublereal *
04105             , doublereal *, doublereal *, doublereal *);
04106     static doublereal test, test1, amagz;
04107     static integer itime;
04108     static doublereal cdfnui, cdfnur;
04109 
04110 /* ***BEGIN PROLOGUE  ZRATI */
04111 /* ***REFER TO  ZBESI,ZBESK,ZBESH */
04112 
04113 /*     ZRATI COMPUTES RATIOS OF I BESSEL FUNCTIONS BY BACKWARD */
04114 /*     RECURRENCE.  THE STARTING INDEX IS DETERMINED BY FORWARD */
04115 /*     RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B, */
04116 /*     MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973, */
04117 /*     BESSEL FUNCTIONS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER, */
04118 /*     BY D. J. SOOKNE. */
04119 
04120 /* ***ROUTINES CALLED  ZABS,ZDIV */
04121 /* ***END PROLOGUE  ZRATI */
04122 /*     COMPLEX Z,CY(1),CONE,CZERO,P1,P2,T1,RZ,PT,CDFNU */
04123     /* Parameter adjustments */
04124     --cyi;
04125     --cyr;
04126 
04127     /* Function Body */
04128     az = zabs_(zr, zi);
04129     inu = (integer) ((real) (*fnu));
04130     idnu = inu + *n - 1;
04131     magz = (integer) ((real) az);
04132     amagz = (doublereal) ((real) (magz + 1));
04133     fdnu = (doublereal) ((real) idnu);
04134     fnup = max(amagz,fdnu);
04135     id = idnu - magz - 1;
04136     itime = 1;
04137     k = 1;
04138     ptr = 1. / az;
04139     rzr = ptr * (*zr + *zr) * ptr;
04140     rzi = -ptr * (*zi + *zi) * ptr;
04141     t1r = rzr * fnup;
04142     t1i = rzi * fnup;
04143     p2r = -t1r;
04144     p2i = -t1i;
04145     p1r = coner;
04146     p1i = conei;
04147     t1r += rzr;
04148     t1i += rzi;
04149     if (id > 0) {
04150         id = 0;
04151     }
04152     ap2 = zabs_(&p2r, &p2i);
04153     ap1 = zabs_(&p1r, &p1i);
04154 /* ----------------------------------------------------------------------- */
04155 /*     THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNU */
04156 /*     GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT */
04157 /*     P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR */
04158 /*     PREMATURELY. */
04159 /* ----------------------------------------------------------------------- */
04160     arg = (ap2 + ap2) / (ap1 * *tol);
04161     test1 = sqrt(arg);
04162     test = test1;
04163     rap1 = 1. / ap1;
04164     p1r *= rap1;
04165     p1i *= rap1;
04166     p2r *= rap1;
04167     p2i *= rap1;
04168     ap2 *= rap1;
04169 L10:
04170     ++k;
04171     ap1 = ap2;
04172     ptr = p2r;
04173     pti = p2i;
04174     p2r = p1r - (t1r * ptr - t1i * pti);
04175     p2i = p1i - (t1r * pti + t1i * ptr);
04176     p1r = ptr;
04177     p1i = pti;
04178     t1r += rzr;
04179     t1i += rzi;
04180     ap2 = zabs_(&p2r, &p2i);
04181     if (ap1 <= test) {
04182         goto L10;
04183     }
04184     if (itime == 2) {
04185         goto L20;
04186     }
04187     ak = zabs_(&t1r, &t1i) * .5;
04188     flam = ak + sqrt(ak * ak - 1.);
04189 /* Computing MIN */
04190     d__1 = ap2 / ap1;
04191     rho = min(d__1,flam);
04192     test = test1 * sqrt(rho / (rho * rho - 1.));
04193     itime = 2;
04194     goto L10;
04195 L20:
04196     kk = k + 1 - id;
04197     ak = (doublereal) ((real) kk);
04198     t1r = ak;
04199     t1i = czeroi;
04200     dfnu = *fnu + (doublereal) ((real) (*n - 1));
04201     p1r = 1. / ap2;
04202     p1i = czeroi;
04203     p2r = czeror;
04204     p2i = czeroi;
04205     i__1 = kk;
04206     for (i__ = 1; i__ <= i__1; ++i__) {
04207         ptr = p1r;
04208         pti = p1i;
04209         rap1 = dfnu + t1r;
04210         ttr = rzr * rap1;
04211         tti = rzi * rap1;
04212         p1r = ptr * ttr - pti * tti + p2r;
04213         p1i = ptr * tti + pti * ttr + p2i;
04214         p2r = ptr;
04215         p2i = pti;
04216         t1r -= coner;
04217 /* L30: */
04218     }
04219     if (p1r != czeror || p1i != czeroi) {
04220         goto L40;
04221     }
04222     p1r = *tol;
04223     p1i = *tol;
04224 L40:
04225     zdiv_(&p2r, &p2i, &p1r, &p1i, &cyr[*n], &cyi[*n]);
04226     if (*n == 1) {
04227         return 0;
04228     }
04229     k = *n - 1;
04230     ak = (doublereal) ((real) k);
04231     t1r = ak;
04232     t1i = czeroi;
04233     cdfnur = *fnu * rzr;
04234     cdfnui = *fnu * rzi;
04235     i__1 = *n;
04236     for (i__ = 2; i__ <= i__1; ++i__) {
04237         ptr = cdfnur + (t1r * rzr - t1i * rzi) + cyr[k + 1];
04238         pti = cdfnui + (t1r * rzi + t1i * rzr) + cyi[k + 1];
04239         ak = zabs_(&ptr, &pti);
04240         if (ak != czeror) {
04241             goto L50;
04242         }
04243         ptr = *tol;
04244         pti = *tol;
04245         ak = *tol * rt2;
04246 L50:
04247         rak = coner / ak;
04248         cyr[k] = rak * ptr * rak;
04249         cyi[k] = -rak * pti * rak;
04250         t1r -= coner;
04251         --k;
04252 /* L60: */
04253     }
04254     return 0;
04255 } /* zrati_ */
04256 
04257 /* Subroutine */ int zs1s2_(doublereal *zrr, doublereal *zri, doublereal *s1r,
04258          doublereal *s1i, doublereal *s2r, doublereal *s2i, integer *nz, 
04259         doublereal *ascle, doublereal *alim, integer *iuf)
04260 {
04261     /* Initialized data */
04262 
04263     static doublereal zeror = 0.;
04264     static doublereal zeroi = 0.;
04265 
04266     /* Builtin functions */
04267     double log(doublereal);
04268 
04269     /* Local variables */
04270     static doublereal aa, c1i, as1, as2, c1r, aln, s1di, s1dr;
04271     static integer idum;
04272     extern doublereal zabs_(doublereal *, doublereal *);
04273     extern /* Subroutine */ int zzzlog_(doublereal *, doublereal *, 
04274             doublereal *, doublereal *, integer *), zzzexp_(doublereal *, 
04275             doublereal *, doublereal *, doublereal *);
04276 
04277 /* ***BEGIN PROLOGUE  ZS1S2 */
04278 /* ***REFER TO  ZBESK,ZAIRY */
04279 
04280 /*     ZS1S2 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE */
04281 /*     ADDITION OF THE I AND K FUNCTIONS IN THE ANALYTIC CON- */
04282 /*     TINUATION FORMULA WHERE S1=K FUNCTION AND S2=I FUNCTION. */
04283 /*     ON KODE=1 THE I AND K FUNCTIONS ARE DIFFERENT ORDERS OF */
04284 /*     MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER */
04285 /*     OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE */
04286 /*     PRECISION ABOVE THE UNDERFLOW LIMIT. */
04287 
04288 /* ***ROUTINES CALLED  ZABS,ZZZEXP,ZZZLOG */
04289 /* ***END PROLOGUE  ZS1S2 */
04290 /*     COMPLEX CZERO,C1,S1,S1D,S2,ZR */
04291     *nz = 0;
04292     as1 = zabs_(s1r, s1i);
04293     as2 = zabs_(s2r, s2i);
04294     if (*s1r == 0. && *s1i == 0.) {
04295         goto L10;
04296     }
04297     if (as1 == 0.) {
04298         goto L10;
04299     }
04300     aln = -(*zrr) - *zrr + log(as1);
04301     s1dr = *s1r;
04302     s1di = *s1i;
04303     *s1r = zeror;
04304     *s1i = zeroi;
04305     as1 = zeror;
04306     if (aln < -(*alim)) {
04307         goto L10;
04308     }
04309     zzzlog_(&s1dr, &s1di, &c1r, &c1i, &idum);
04310     c1r = c1r - *zrr - *zrr;
04311     c1i = c1i - *zri - *zri;
04312     zzzexp_(&c1r, &c1i, s1r, s1i);
04313     as1 = zabs_(s1r, s1i);
04314     ++(*iuf);
04315 L10:
04316     aa = max(as1,as2);
04317     if (aa > *ascle) {
04318         return 0;
04319     }
04320     *s1r = zeror;
04321     *s1i = zeroi;
04322     *s2r = zeror;
04323     *s2i = zeroi;
04324     *nz = 1;
04325     *iuf = 0;
04326     return 0;
04327 } /* zs1s2_ */
04328 
04329 /* Subroutine */ int zbunk_(doublereal *zr, doublereal *zi, doublereal *fnu, 
04330         integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *
04331         yi, integer *nz, doublereal *tol, doublereal *elim, doublereal *alim)
04332 {
04333     static doublereal ax, ay;
04334     extern /* Subroutine */ int zunk1_(doublereal *, doublereal *, doublereal 
04335             *, integer *, integer *, integer *, doublereal *, doublereal *, 
04336             integer *, doublereal *, doublereal *, doublereal *), zunk2_(
04337             doublereal *, doublereal *, doublereal *, integer *, integer *, 
04338             integer *, doublereal *, doublereal *, integer *, doublereal *, 
04339             doublereal *, doublereal *);
04340 
04341 /* ***BEGIN PROLOGUE  ZBUNK */
04342 /* ***REFER TO  ZBESK,ZBESH */
04343 
04344 /*     ZBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU.GT.FNUL. */
04345 /*     ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z) */
04346 /*     IN ZUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN ZUNK2 */
04347 
04348 /* ***ROUTINES CALLED  ZUNK1,ZUNK2 */
04349 /* ***END PROLOGUE  ZBUNK */
04350 /*     COMPLEX Y,Z */
04351     /* Parameter adjustments */
04352     --yi;
04353     --yr;
04354 
04355     /* Function Body */
04356     *nz = 0;
04357     ax = abs(*zr) * 1.7321;
04358     ay = abs(*zi);
04359     if (ay > ax) {
04360         goto L10;
04361     }
04362 /* ----------------------------------------------------------------------- */
04363 /*     ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN */
04364 /*     -PI/3.LE.ARG(Z).LE.PI/3 */
04365 /* ----------------------------------------------------------------------- */
04366     zunk1_(zr, zi, fnu, kode, mr, n, &yr[1], &yi[1], nz, tol, elim, alim);
04367     goto L20;
04368 L10:
04369 /* ----------------------------------------------------------------------- */
04370 /*     ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU */
04371 /*     APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I */
04372 /*     AND HPI=PI/2 */
04373 /* ----------------------------------------------------------------------- */
04374     zunk2_(zr, zi, fnu, kode, mr, n, &yr[1], &yi[1], nz, tol, elim, alim);
04375 L20:
04376     return 0;
04377 } /* zbunk_ */
04378 
04379 /* Subroutine */ int zmlri_(doublereal *zr, doublereal *zi, doublereal *fnu, 
04380         integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
04381         nz, doublereal *tol)
04382 {
04383     /* Initialized data */
04384 
04385     static doublereal zeror = 0.;
04386     static doublereal zeroi = 0.;
04387     static doublereal coner = 1.;
04388     static doublereal conei = 0.;
04389 
04390     /* System generated locals */
04391     integer i__1, i__2;
04392     doublereal d__1, d__2, d__3;
04393 
04394     /* Builtin functions */
04395     double sqrt(doublereal), exp(doublereal);
04396 
04397     /* Local variables */
04398     static integer i__, k, m;
04399     static doublereal ak, bk, ap, at;
04400     static integer kk, km;
04401     static doublereal az, p1i, p2i, p1r, p2r, ack, cki, fnf, fkk, ckr;
04402     static integer iaz;
04403     static doublereal rho;
04404     static integer inu;
04405     static doublereal pti, raz, sti, rzi, ptr, str, tst, rzr, rho2, flam, 
04406             fkap, scle, tfnf;
04407     static integer idum;
04408     extern doublereal zabs_(doublereal *, doublereal *);
04409     static integer ifnu;
04410     static doublereal sumi, sumr;
04411     extern /* Subroutine */ int zmlt_(doublereal *, doublereal *, doublereal *
04412             , doublereal *, doublereal *, doublereal *);
04413     static integer itime;
04414     extern doublereal d1mach_(integer *), dgamln_(doublereal *, integer *);
04415     static doublereal cnormi, cnormr;
04416     extern /* Subroutine */ int zzzlog_(doublereal *, doublereal *, 
04417             doublereal *, doublereal *, integer *), zzzexp_(doublereal *, 
04418             doublereal *, doublereal *, doublereal *);
04419 
04420 /* ***BEGIN PROLOGUE  ZMLRI */
04421 /* ***REFER TO  ZBESI,ZBESK */
04422 
04423 /*     ZMLRI COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY THE */
04424 /*     MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES. */
04425 
04426 /* ***ROUTINES CALLED  DGAMLN,D1MACH,ZABS,ZZZEXP,ZZZLOG,ZMLT */
04427 /* ***END PROLOGUE  ZMLRI */
04428 /*     COMPLEX CK,CNORM,CONE,CTWO,CZERO,PT,P1,P2,RZ,SUM,Y,Z */
04429     /* Parameter adjustments */
04430     --yi;
04431     --yr;
04432 
04433     /* Function Body */
04434     scle = d1mach_(&c__1) / *tol;
04435     *nz = 0;
04436     az = zabs_(zr, zi);
04437     iaz = (integer) ((real) az);
04438     ifnu = (integer) ((real) (*fnu));
04439     inu = ifnu + *n - 1;
04440     at = (doublereal) ((real) iaz) + 1.;
04441     raz = 1. / az;
04442     str = *zr * raz;
04443     sti = -(*zi) * raz;
04444     ckr = str * at * raz;
04445     cki = sti * at * raz;
04446     rzr = (str + str) * raz;
04447     rzi = (sti + sti) * raz;
04448     p1r = zeror;
04449     p1i = zeroi;
04450     p2r = coner;
04451     p2i = conei;
04452     ack = (at + 1.) * raz;
04453     rho = ack + sqrt(ack * ack - 1.);
04454     rho2 = rho * rho;
04455     tst = (rho2 + rho2) / ((rho2 - 1.) * (rho - 1.));
04456     tst /= *tol;
04457 /* ----------------------------------------------------------------------- */
04458 /*     COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES */
04459 /* ----------------------------------------------------------------------- */
04460     ak = at;
04461     for (i__ = 1; i__ <= 80; ++i__) {
04462         ptr = p2r;
04463         pti = p2i;
04464         p2r = p1r - (ckr * ptr - cki * pti);
04465         p2i = p1i - (cki * ptr + ckr * pti);
04466         p1r = ptr;
04467         p1i = pti;
04468         ckr += rzr;
04469         cki += rzi;
04470         ap = zabs_(&p2r, &p2i);
04471         if (ap > tst * ak * ak) {
04472             goto L20;
04473         }
04474         ak += 1.;
04475 /* L10: */
04476     }
04477     goto L110;
04478 L20:
04479     ++i__;
04480     k = 0;
04481     if (inu < iaz) {
04482         goto L40;
04483     }
04484 /* ----------------------------------------------------------------------- */
04485 /*     COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS */
04486 /* ----------------------------------------------------------------------- */
04487     p1r = zeror;
04488     p1i = zeroi;
04489     p2r = coner;
04490     p2i = conei;
04491     at = (doublereal) ((real) inu) + 1.;
04492     str = *zr * raz;
04493     sti = -(*zi) * raz;
04494     ckr = str * at * raz;
04495     cki = sti * at * raz;
04496     ack = at * raz;
04497     tst = sqrt(ack / *tol);
04498     itime = 1;
04499     for (k = 1; k <= 80; ++k) {
04500         ptr = p2r;
04501         pti = p2i;
04502         p2r = p1r - (ckr * ptr - cki * pti);
04503         p2i = p1i - (ckr * pti + cki * ptr);
04504         p1r = ptr;
04505         p1i = pti;
04506         ckr += rzr;
04507         cki += rzi;
04508         ap = zabs_(&p2r, &p2i);
04509         if (ap < tst) {
04510             goto L30;
04511         }
04512         if (itime == 2) {
04513             goto L40;
04514         }
04515         ack = zabs_(&ckr, &cki);
04516         flam = ack + sqrt(ack * ack - 1.);
04517         fkap = ap / zabs_(&p1r, &p1i);
04518         rho = min(flam,fkap);
04519         tst *= sqrt(rho / (rho * rho - 1.));
04520         itime = 2;
04521 L30:
04522         ;
04523     }
04524     goto L110;
04525 L40:
04526 /* ----------------------------------------------------------------------- */
04527 /*     BACKWARD RECURRENCE AND SUM NORMALIZING RELATION */
04528 /* ----------------------------------------------------------------------- */
04529     ++k;
04530 /* Computing MAX */
04531     i__1 = i__ + iaz, i__2 = k + inu;
04532     kk = max(i__1,i__2);
04533     fkk = (doublereal) ((real) kk);
04534     p1r = zeror;
04535     p1i = zeroi;
04536 /* ----------------------------------------------------------------------- */
04537 /*     SCALE P2 AND SUM BY SCLE */
04538 /* ----------------------------------------------------------------------- */
04539     p2r = scle;
04540     p2i = zeroi;
04541     fnf = *fnu - (doublereal) ((real) ifnu);
04542     tfnf = fnf + fnf;
04543     d__1 = fkk + tfnf + 1.;
04544     d__2 = fkk + 1.;
04545     d__3 = tfnf + 1.;
04546     bk = dgamln_(&d__1, &idum) - dgamln_(&d__2, &idum) - dgamln_(&d__3, &idum)
04547             ;
04548     bk = exp(bk);
04549     sumr = zeror;
04550     sumi = zeroi;
04551     km = kk - inu;
04552     i__1 = km;
04553     for (i__ = 1; i__ <= i__1; ++i__) {
04554         ptr = p2r;
04555         pti = p2i;
04556         p2r = p1r + (fkk + fnf) * (rzr * ptr - rzi * pti);
04557         p2i = p1i + (fkk + fnf) * (rzi * ptr + rzr * pti);
04558         p1r = ptr;
04559         p1i = pti;
04560         ak = 1. - tfnf / (fkk + tfnf);
04561         ack = bk * ak;
04562         sumr += (ack + bk) * p1r;
04563         sumi += (ack + bk) * p1i;
04564         bk = ack;
04565         fkk += -1.;
04566 /* L50: */
04567     }
04568     yr[*n] = p2r;
04569     yi[*n] = p2i;
04570     if (*n == 1) {
04571         goto L70;
04572     }
04573     i__1 = *n;
04574     for (i__ = 2; i__ <= i__1; ++i__) {
04575         ptr = p2r;
04576         pti = p2i;
04577         p2r = p1r + (fkk + fnf) * (rzr * ptr - rzi * pti);
04578         p2i = p1i + (fkk + fnf) * (rzi * ptr + rzr * pti);
04579         p1r = ptr;
04580         p1i = pti;
04581         ak = 1. - tfnf / (fkk + tfnf);
04582         ack = bk * ak;
04583         sumr += (ack + bk) * p1r;
04584         sumi += (ack + bk) * p1i;
04585         bk = ack;
04586         fkk += -1.;
04587         m = *n - i__ + 1;
04588         yr[m] = p2r;
04589         yi[m] = p2i;
04590 /* L60: */
04591     }
04592 L70:
04593     if (ifnu <= 0) {
04594         goto L90;
04595     }
04596     i__1 = ifnu;
04597     for (i__ = 1; i__ <= i__1; ++i__) {
04598         ptr = p2r;
04599         pti = p2i;
04600         p2r = p1r + (fkk + fnf) * (rzr * ptr - rzi * pti);
04601         p2i = p1i + (fkk + fnf) * (rzr * pti + rzi * ptr);
04602         p1r = ptr;
04603         p1i = pti;
04604         ak = 1. - tfnf / (fkk + tfnf);
04605         ack = bk * ak;
04606         sumr += (ack + bk) * p1r;
04607         sumi += (ack + bk) * p1i;
04608         bk = ack;
04609         fkk += -1.;
04610 /* L80: */
04611     }
04612 L90:
04613     ptr = *zr;
04614     pti = *zi;
04615     if (*kode == 2) {
04616         ptr = zeror;
04617     }
04618     zzzlog_(&rzr, &rzi, &str, &sti, &idum);
04619     p1r = -fnf * str + ptr;
04620     p1i = -fnf * sti + pti;
04621     d__1 = fnf + 1.;
04622     ap = dgamln_(&d__1, &idum);
04623     ptr = p1r - ap;
04624     pti = p1i;
04625 /* ----------------------------------------------------------------------- */
04626 /*     THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW */
04627 /*     IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES */
04628 /* ----------------------------------------------------------------------- */
04629     p2r += sumr;
04630     p2i += sumi;
04631     ap = zabs_(&p2r, &p2i);
04632     p1r = 1. / ap;
04633     zzzexp_(&ptr, &pti, &str, &sti);
04634     ckr = str * p1r;
04635     cki = sti * p1r;
04636     ptr = p2r * p1r;
04637     pti = -p2i * p1r;
04638     zmlt_(&ckr, &cki, &ptr, &pti, &cnormr, &cnormi);
04639     i__1 = *n;
04640     for (i__ = 1; i__ <= i__1; ++i__) {
04641         str = yr[i__] * cnormr - yi[i__] * cnormi;
04642         yi[i__] = yr[i__] * cnormi + yi[i__] * cnormr;
04643         yr[i__] = str;
04644 /* L100: */
04645     }
04646     return 0;
04647 L110:
04648     *nz = -2;
04649     return 0;
04650 } /* zmlri_ */
04651 
04652 /* Subroutine */ int zwrsk_(doublereal *zrr, doublereal *zri, doublereal *fnu,
04653          integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
04654         nz, doublereal *cwr, doublereal *cwi, doublereal *tol, doublereal *
04655         elim, doublereal *alim)
04656 {
04657     /* System generated locals */
04658     integer i__1;
04659 
04660     /* Builtin functions */
04661     double cos(doublereal), sin(doublereal);
04662 
04663     /* Local variables */
04664     static integer i__, nw;
04665     static doublereal c1i, c2i, c1r, c2r, act, acw, cti, ctr, pti, sti, ptr, 
04666             str, ract;
04667     extern doublereal zabs_(doublereal *, doublereal *);
04668     static doublereal ascle, csclr, cinui, cinur;
04669     extern /* Subroutine */ int zbknu_(doublereal *, doublereal *, doublereal 
04670             *, integer *, integer *, doublereal *, doublereal *, integer *, 
04671             doublereal *, doublereal *, doublereal *), zrati_(doublereal *, 
04672             doublereal *, doublereal *, integer *, doublereal *, doublereal *,
04673              doublereal *);
04674     extern doublereal d1mach_(integer *);
04675 
04676 /* ***BEGIN PROLOGUE  ZWRSK */
04677 /* ***REFER TO  ZBESI,ZBESK */
04678 
04679 /*     ZWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY */
04680 /*     NORMALIZING THE I FUNCTION RATIOS FROM ZRATI BY THE WRONSKIAN */
04681 
04682 /* ***ROUTINES CALLED  D1MACH,ZBKNU,ZRATI,ZABS */
04683 /* ***END PROLOGUE  ZWRSK */
04684 /*     COMPLEX CINU,CSCL,CT,CW,C1,C2,RCT,ST,Y,ZR */
04685 /* ----------------------------------------------------------------------- */
04686 /*     I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS */
04687 /*     Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM CRATI NORMALIZED BY THE */
04688 /*     WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM CBKNU. */
04689 /* ----------------------------------------------------------------------- */
04690     /* Parameter adjustments */
04691     --yi;
04692     --yr;
04693     --cwr;
04694     --cwi;
04695 
04696     /* Function Body */
04697     *nz = 0;
04698     zbknu_(zrr, zri, fnu, kode, &c__2, &cwr[1], &cwi[1], &nw, tol, elim, alim)
04699             ;
04700     if (nw != 0) {
04701         goto L50;
04702     }
04703     zrati_(zrr, zri, fnu, n, &yr[1], &yi[1], tol);
04704 /* ----------------------------------------------------------------------- */
04705 /*     RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z), */
04706 /*     R(FNU+J-1,Z)=Y(J),  J=1,...,N */
04707 /* ----------------------------------------------------------------------- */
04708     cinur = 1.;
04709     cinui = 0.;
04710     if (*kode == 1) {
04711         goto L10;
04712     }
04713     cinur = cos(*zri);
04714     cinui = sin(*zri);
04715 L10:
04716 /* ----------------------------------------------------------------------- */
04717 /*     ON LOW EXPONENT MACHINES THE K FUNCTIONS CAN BE CLOSE TO BOTH */
04718 /*     THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE */
04719 /*     SCALED TO PREVENT OVER OR UNDERFLOW. CUOIK HAS DETERMINED THAT */
04720 /*     THE RESULT IS ON SCALE. */
04721 /* ----------------------------------------------------------------------- */
04722     acw = zabs_(&cwr[2], &cwi[2]);
04723     ascle = d1mach_(&c__1) * 1e3 / *tol;
04724     csclr = 1.;
04725     if (acw > ascle) {
04726         goto L20;
04727     }
04728     csclr = 1. / *tol;
04729     goto L30;
04730 L20:
04731     ascle = 1. / ascle;
04732     if (acw < ascle) {
04733         goto L30;
04734     }
04735     csclr = *tol;
04736 L30:
04737     c1r = cwr[1] * csclr;
04738     c1i = cwi[1] * csclr;
04739     c2r = cwr[2] * csclr;
04740     c2i = cwi[2] * csclr;
04741     str = yr[1];
04742     sti = yi[1];
04743 /* ----------------------------------------------------------------------- */
04744 /*     CINU=CINU*(CONJG(CT)/CABS(CT))*(1.0D0/CABS(CT) PREVENTS */
04745 /*     UNDER- OR OVERFLOW PREMATURELY BY SQUARING CABS(CT) */
04746 /* ----------------------------------------------------------------------- */
04747     ptr = str * c1r - sti * c1i;
04748     pti = str * c1i + sti * c1r;
04749     ptr += c2r;
04750     pti += c2i;
04751     ctr = *zrr * ptr - *zri * pti;
04752     cti = *zrr * pti + *zri * ptr;
04753     act = zabs_(&ctr, &cti);
04754     ract = 1. / act;
04755     ctr *= ract;
04756     cti = -cti * ract;
04757     ptr = cinur * ract;
04758     pti = cinui * ract;
04759     cinur = ptr * ctr - pti * cti;
04760     cinui = ptr * cti + pti * ctr;
04761     yr[1] = cinur * csclr;
04762     yi[1] = cinui * csclr;
04763     if (*n == 1) {
04764         return 0;
04765     }
04766     i__1 = *n;
04767     for (i__ = 2; i__ <= i__1; ++i__) {
04768         ptr = str * cinur - sti * cinui;
04769         cinui = str * cinui + sti * cinur;
04770         cinur = ptr;
04771         str = yr[i__];
04772         sti = yi[i__];
04773         yr[i__] = cinur * csclr;
04774         yi[i__] = cinui * csclr;
04775 /* L40: */
04776     }
04777     return 0;
04778 L50:
04779     *nz = -1;
04780     if (nw == -2) {
04781         *nz = -2;
04782     }
04783     return 0;
04784 } /* zwrsk_ */
04785 
04786 /* Subroutine */ int zseri_(doublereal *zr, doublereal *zi, doublereal *fnu, 
04787         integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
04788         nz, doublereal *tol, doublereal *elim, doublereal *alim)
04789 {
04790     /* Initialized data */
04791 
04792     static doublereal zeror = 0.;
04793     static doublereal zeroi = 0.;
04794     static doublereal coner = 1.;
04795     static doublereal conei = 0.;
04796 
04797     /* System generated locals */
04798     integer i__1;
04799 
04800     /* Builtin functions */
04801     double sqrt(doublereal), exp(doublereal), cos(doublereal), sin(doublereal)
04802             ;
04803 
04804     /* Local variables */
04805     static integer i__, k, l, m;
04806     static doublereal s, aa;
04807     static integer ib;
04808     static doublereal ak;
04809     static integer il;
04810     static doublereal az;
04811     static integer nn;
04812     static doublereal wi[2], rs, ss;
04813     static integer nw;
04814     static doublereal wr[2], s1i, s2i, s1r, s2r, cki, acz, arm, ckr, czi, hzi,
04815              raz, czr, sti, hzr, rzi, str, rzr, ak1i, ak1r, rtr1, dfnu;
04816     static integer idum;
04817     extern doublereal zabs_(doublereal *, doublereal *);
04818     static doublereal atol, fnup;
04819     extern /* Subroutine */ int zdiv_(doublereal *, doublereal *, doublereal *
04820             , doublereal *, doublereal *, doublereal *), zmlt_(doublereal *, 
04821             doublereal *, doublereal *, doublereal *, doublereal *, 
04822             doublereal *);
04823     static integer iflag;
04824     static doublereal coefi, ascle, coefr, crscr;
04825     extern /* Subroutine */ int zuchk_(doublereal *, doublereal *, integer *, 
04826             doublereal *, doublereal *);
04827     extern doublereal d1mach_(integer *), dgamln_(doublereal *, integer *);
04828     extern /* Subroutine */ int zzzlog_(doublereal *, doublereal *, 
04829             doublereal *, doublereal *, integer *);
04830 
04831 /* ***BEGIN PROLOGUE  ZSERI */
04832 /* ***REFER TO  ZBESI,ZBESK */
04833 
04834 /*     ZSERI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY */
04835 /*     MEANS OF THE POWER SERIES FOR LARGE CABS(Z) IN THE */
04836 /*     REGION CABS(Z).LE.2*SQRT(FNU+1). NZ=0 IS A NORMAL RETURN. */
04837 /*     NZ.GT.0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO */
04838 /*     DUE TO UNDERFLOW. NZ.LT.0 MEANS UNDERFLOW OCCURRED, BUT THE */
04839 /*     CONDITION CABS(Z).LE.2*SQRT(FNU+1) WAS VIOLATED AND THE */
04840 /*     COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ). */
04841 
04842 /* ***ROUTINES CALLED  DGAMLN,D1MACH,ZUCHK,ZABS,ZDIV,ZZZLOG,ZMLT */
04843 /* ***END PROLOGUE  ZSERI */
04844 /*     COMPLEX AK1,CK,COEF,CONE,CRSC,CSCL,CZ,CZERO,HZ,RZ,S1,S2,Y,Z */
04845     /* Parameter adjustments */
04846     --yi;
04847     --yr;
04848 
04849     /* Function Body */
04850 
04851     *nz = 0;
04852     az = zabs_(zr, zi);
04853     if (az == 0.) {
04854         goto L160;
04855     }
04856     arm = d1mach_(&c__1) * 1e3;
04857     rtr1 = sqrt(arm);
04858     crscr = 1.;
04859     iflag = 0;
04860     if (az < arm) {
04861         goto L150;
04862     }
04863     hzr = *zr * .5;
04864     hzi = *zi * .5;
04865     czr = zeror;
04866     czi = zeroi;
04867     if (az <= rtr1) {
04868         goto L10;
04869     }
04870     zmlt_(&hzr, &hzi, &hzr, &hzi, &czr, &czi);
04871 L10:
04872     acz = zabs_(&czr, &czi);
04873     nn = *n;
04874     zzzlog_(&hzr, &hzi, &ckr, &cki, &idum);
04875 L20:
04876     dfnu = *fnu + (doublereal) ((real) (nn - 1));
04877     fnup = dfnu + 1.;
04878 /* ----------------------------------------------------------------------- */
04879 /*     UNDERFLOW TEST */
04880 /* ----------------------------------------------------------------------- */
04881     ak1r = ckr * dfnu;
04882     ak1i = cki * dfnu;
04883     ak = dgamln_(&fnup, &idum);
04884     ak1r -= ak;
04885     if (*kode == 2) {
04886         ak1r -= *zr;
04887     }
04888     if (ak1r > -(*elim)) {
04889         goto L40;
04890     }
04891 L30:
04892     ++(*nz);
04893     yr[nn] = zeror;
04894     yi[nn] = zeroi;
04895     if (acz > dfnu) {
04896         goto L190;
04897     }
04898     --nn;
04899     if (nn == 0) {
04900         return 0;
04901     }
04902     goto L20;
04903 L40:
04904     if (ak1r > -(*alim)) {
04905         goto L50;
04906     }
04907     iflag = 1;
04908     ss = 1. / *tol;
04909     crscr = *tol;
04910     ascle = arm * ss;
04911 L50:
04912     aa = exp(ak1r);
04913     if (iflag == 1) {
04914         aa *= ss;
04915     }
04916     coefr = aa * cos(ak1i);
04917     coefi = aa * sin(ak1i);
04918     atol = *tol * acz / fnup;
04919     il = min(2,nn);
04920     i__1 = il;
04921     for (i__ = 1; i__ <= i__1; ++i__) {
04922         dfnu = *fnu + (doublereal) ((real) (nn - i__));
04923         fnup = dfnu + 1.;
04924         s1r = coner;
04925         s1i = conei;
04926         if (acz < *tol * fnup) {
04927             goto L70;
04928         }
04929         ak1r = coner;
04930         ak1i = conei;
04931         ak = fnup + 2.;
04932         s = fnup;
04933         aa = 2.;
04934 L60:
04935         rs = 1. / s;
04936         str = ak1r * czr - ak1i * czi;
04937         sti = ak1r * czi + ak1i * czr;
04938         ak1r = str * rs;
04939         ak1i = sti * rs;
04940         s1r += ak1r;
04941         s1i += ak1i;
04942         s += ak;
04943         ak += 2.;
04944         aa = aa * acz * rs;
04945         if (aa > atol) {
04946             goto L60;
04947         }
04948 L70:
04949         s2r = s1r * coefr - s1i * coefi;
04950         s2i = s1r * coefi + s1i * coefr;
04951         wr[i__ - 1] = s2r;
04952         wi[i__ - 1] = s2i;
04953         if (iflag == 0) {
04954             goto L80;
04955         }
04956         zuchk_(&s2r, &s2i, &nw, &ascle, tol);
04957         if (nw != 0) {
04958             goto L30;
04959         }
04960 L80:
04961         m = nn - i__ + 1;
04962         yr[m] = s2r * crscr;
04963         yi[m] = s2i * crscr;
04964         if (i__ == il) {
04965             goto L90;
04966         }
04967         zdiv_(&coefr, &coefi, &hzr, &hzi, &str, &sti);
04968         coefr = str * dfnu;
04969         coefi = sti * dfnu;
04970 L90:
04971         ;
04972     }
04973     if (nn <= 2) {
04974         return 0;
04975     }
04976     k = nn - 2;
04977     ak = (doublereal) ((real) k);
04978     raz = 1. / az;
04979     str = *zr * raz;
04980     sti = -(*zi) * raz;
04981     rzr = (str + str) * raz;
04982     rzi = (sti + sti) * raz;
04983     if (iflag == 1) {
04984         goto L120;
04985     }
04986     ib = 3;
04987 L100:
04988     i__1 = nn;
04989     for (i__ = ib; i__ <= i__1; ++i__) {
04990         yr[k] = (ak + *fnu) * (rzr * yr[k + 1] - rzi * yi[k + 1]) + yr[k + 2];
04991         yi[k] = (ak + *fnu) * (rzr * yi[k + 1] + rzi * yr[k + 1]) + yi[k + 2];
04992         ak += -1.;
04993         --k;
04994 /* L110: */
04995     }
04996     return 0;
04997 /* ----------------------------------------------------------------------- */
04998 /*     RECUR BACKWARD WITH SCALED VALUES */
04999 /* ----------------------------------------------------------------------- */
05000 L120:
05001 /* ----------------------------------------------------------------------- */
05002 /*     EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE */
05003 /*     UNDERFLOW LIMIT = ASCLE = D1MACH(1)*SS*1.0D+3 */
05004 /* ----------------------------------------------------------------------- */
05005     s1r = wr[0];
05006     s1i = wi[0];
05007     s2r = wr[1];
05008     s2i = wi[1];
05009     i__1 = nn;
05010     for (l = 3; l <= i__1; ++l) {
05011         ckr = s2r;
05012         cki = s2i;
05013         s2r = s1r + (ak + *fnu) * (rzr * ckr - rzi * cki);
05014         s2i = s1i + (ak + *fnu) * (rzr * cki + rzi * ckr);
05015         s1r = ckr;
05016         s1i = cki;
05017         ckr = s2r * crscr;
05018         cki = s2i * crscr;
05019         yr[k] = ckr;
05020         yi[k] = cki;
05021         ak += -1.;
05022         --k;
05023         if (zabs_(&ckr, &cki) > ascle) {
05024             goto L140;
05025         }
05026 /* L130: */
05027     }
05028     return 0;
05029 L140:
05030     ib = l + 1;
05031     if (ib > nn) {
05032         return 0;
05033     }
05034     goto L100;
05035 L150:
05036     *nz = *n;
05037     if (*fnu == 0.) {
05038         --(*nz);
05039     }
05040 L160:
05041     yr[1] = zeror;
05042     yi[1] = zeroi;
05043     if (*fnu != 0.) {
05044         goto L170;
05045     }
05046     yr[1] = coner;
05047     yi[1] = conei;
05048 L170:
05049     if (*n == 1) {
05050         return 0;
05051     }
05052     i__1 = *n;
05053     for (i__ = 2; i__ <= i__1; ++i__) {
05054         yr[i__] = zeror;
05055         yi[i__] = zeroi;
05056 /* L180: */
05057     }
05058     return 0;
05059 /* ----------------------------------------------------------------------- */
05060 /*     RETURN WITH NZ.LT.0 IF CABS(Z*Z/4).GT.FNU+N-NZ-1 COMPLETE */
05061 /*     THE CALCULATION IN CBINU WITH N=N-IABS(NZ) */
05062 /* ----------------------------------------------------------------------- */
05063 L190:
05064     *nz = -(*nz);
05065     return 0;
05066 } /* zseri_ */
05067 
05068 /* Subroutine */ int zasyi_(doublereal *zr, doublereal *zi, doublereal *fnu, 
05069         integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
05070         nz, doublereal *rl, doublereal *tol, doublereal *elim, doublereal *
05071         alim)
05072 {
05073     /* Initialized data */
05074 
05075     static doublereal pi = 3.14159265358979324;
05076     static doublereal rtpi = .159154943091895336;
05077     static doublereal zeror = 0.;
05078     static doublereal zeroi = 0.;
05079     static doublereal coner = 1.;
05080     static doublereal conei = 0.;
05081 
05082     /* System generated locals */
05083     integer i__1, i__2;
05084     doublereal d__1, d__2;
05085 
05086     /* Builtin functions */
05087     double sqrt(doublereal), sin(doublereal), cos(doublereal);
05088 
05089     /* Local variables */
05090     extern /* Subroutine */ int zzzsqrt_(doublereal *, doublereal *, 
05091             doublereal *, doublereal *);
05092     static integer i__, j, k, m;
05093     static doublereal s, aa, bb;
05094     static integer ib;
05095     static doublereal ak, bk;
05096     static integer il, jl;
05097     static doublereal az;
05098     static integer nn;
05099     static doublereal p1i, s2i, p1r, s2r, cki, dki, fdn, arg, aez, arm, ckr, 
05100             dkr, czi, ezi, sgn;
05101     static integer inu;
05102     static doublereal raz, czr, ezr, sqk, sti, rzi, tzi, str, rzr, tzr, ak1i, 
05103             ak1r, cs1i, cs2i, cs1r, cs2r, dnu2, rtr1, dfnu;
05104     extern doublereal zabs_(doublereal *, doublereal *);
05105     static doublereal atol;
05106     extern /* Subroutine */ int zdiv_(doublereal *, doublereal *, doublereal *
05107             , doublereal *, doublereal *, doublereal *), zmlt_(doublereal *, 
05108             doublereal *, doublereal *, doublereal *, doublereal *, 
05109             doublereal *);
05110     static integer koded;
05111     extern doublereal d1mach_(integer *);
05112     extern /* Subroutine */ int zzzexp_(doublereal *, doublereal *, 
05113             doublereal *, doublereal *);
05114 
05115 /* ***BEGIN PROLOGUE  ZASYI */
05116 /* ***REFER TO  ZBESI,ZBESK */
05117 
05118 /*     ZASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY */
05119 /*     MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z) IN THE */
05120 /*     REGION CABS(Z).GT.MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL RETURN. */
05121 /*     NZ.LT.0 INDICATES AN OVERFLOW ON KODE=1. */
05122 
05123 /* ***ROUTINES CALLED  D1MACH,ZABS,ZDIV,ZZZEXP,ZMLT,ZZZSQRT */
05124 /* ***END PROLOGUE  ZASYI */
05125 /*     COMPLEX AK1,CK,CONE,CS1,CS2,CZ,CZERO,DK,EZ,P1,RZ,S2,Y,Z */
05126     /* Parameter adjustments */
05127     --yi;
05128     --yr;
05129 
05130     /* Function Body */
05131 
05132     *nz = 0;
05133     az = zabs_(zr, zi);
05134     arm = d1mach_(&c__1) * 1e3;
05135     rtr1 = sqrt(arm);
05136     il = min(2,*n);
05137     dfnu = *fnu + (doublereal) ((real) (*n - il));
05138 /* ----------------------------------------------------------------------- */
05139 /*     OVERFLOW TEST */
05140 /* ----------------------------------------------------------------------- */
05141     raz = 1. / az;
05142     str = *zr * raz;
05143     sti = -(*zi) * raz;
05144     ak1r = rtpi * str * raz;
05145     ak1i = rtpi * sti * raz;
05146     zzzsqrt_(&ak1r, &ak1i, &ak1r, &ak1i);
05147     czr = *zr;
05148     czi = *zi;
05149     if (*kode != 2) {
05150         goto L10;
05151     }
05152     czr = zeror;
05153     czi = *zi;
05154 L10:
05155     if (abs(czr) > *elim) {
05156         goto L100;
05157     }
05158     dnu2 = dfnu + dfnu;
05159     koded = 1;
05160     if (abs(czr) > *alim && *n > 2) {
05161         goto L20;
05162     }
05163     koded = 0;
05164     zzzexp_(&czr, &czi, &str, &sti);
05165     zmlt_(&ak1r, &ak1i, &str, &sti, &ak1r, &ak1i);
05166 L20:
05167     fdn = 0.;
05168     if (dnu2 > rtr1) {
05169         fdn = dnu2 * dnu2;
05170     }
05171     ezr = *zr * 8.;
05172     ezi = *zi * 8.;
05173 /* ----------------------------------------------------------------------- */
05174 /*     WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO THE */
05175 /*     FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF THE */
05176 /*     EXPANSION FOR THE IMAGINARY PART. */
05177 /* ----------------------------------------------------------------------- */
05178     aez = az * 8.;
05179     s = *tol / aez;
05180     jl = (integer) ((real) (*rl + *rl)) + 2;
05181     p1r = zeror;
05182     p1i = zeroi;
05183     if (*zi == 0.) {
05184         goto L30;
05185     }
05186 /* ----------------------------------------------------------------------- */
05187 /*     CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF */
05188 /*     SIGNIFICANCE WHEN FNU OR N IS LARGE */
05189 /* ----------------------------------------------------------------------- */
05190     inu = (integer) ((real) (*fnu));
05191     arg = (*fnu - (doublereal) ((real) inu)) * pi;
05192     inu = inu + *n - il;
05193     ak = -sin(arg);
05194     bk = cos(arg);
05195     if (*zi < 0.) {
05196         bk = -bk;
05197     }
05198     p1r = ak;
05199     p1i = bk;
05200     if (inu % 2 == 0) {
05201         goto L30;
05202     }
05203     p1r = -p1r;
05204     p1i = -p1i;
05205 L30:
05206     i__1 = il;
05207     for (k = 1; k <= i__1; ++k) {
05208         sqk = fdn - 1.;
05209         atol = s * abs(sqk);
05210         sgn = 1.;
05211         cs1r = coner;
05212         cs1i = conei;
05213         cs2r = coner;
05214         cs2i = conei;
05215         ckr = coner;
05216         cki = conei;
05217         ak = 0.;
05218         aa = 1.;
05219         bb = aez;
05220         dkr = ezr;
05221         dki = ezi;
05222         i__2 = jl;
05223         for (j = 1; j <= i__2; ++j) {
05224             zdiv_(&ckr, &cki, &dkr, &dki, &str, &sti);
05225             ckr = str * sqk;
05226             cki = sti * sqk;
05227             cs2r += ckr;
05228             cs2i += cki;
05229             sgn = -sgn;
05230             cs1r += ckr * sgn;
05231             cs1i += cki * sgn;
05232             dkr += ezr;
05233             dki += ezi;
05234             aa = aa * abs(sqk) / bb;
05235             bb += aez;
05236             ak += 8.;
05237             sqk -= ak;
05238             if (aa <= atol) {
05239                 goto L50;
05240             }
05241 /* L40: */
05242         }
05243         goto L110;
05244 L50:
05245         s2r = cs1r;
05246         s2i = cs1i;
05247         if (*zr + *zr >= *elim) {
05248             goto L60;
05249         }
05250         tzr = *zr + *zr;
05251         tzi = *zi + *zi;
05252         d__1 = -tzr;
05253         d__2 = -tzi;
05254         zzzexp_(&d__1, &d__2, &str, &sti);
05255         zmlt_(&str, &sti, &p1r, &p1i, &str, &sti);
05256         zmlt_(&str, &sti, &cs2r, &cs2i, &str, &sti);
05257         s2r += str;
05258         s2i += sti;
05259 L60:
05260         fdn = fdn + dfnu * 8. + 4.;
05261         p1r = -p1r;
05262         p1i = -p1i;
05263         m = *n - il + k;
05264         yr[m] = s2r * ak1r - s2i * ak1i;
05265         yi[m] = s2r * ak1i + s2i * ak1r;
05266 /* L70: */
05267     }
05268     if (*n <= 2) {
05269         return 0;
05270     }
05271     nn = *n;
05272     k = nn - 2;
05273     ak = (doublereal) ((real) k);
05274     str = *zr * raz;
05275     sti = -(*zi) * raz;
05276     rzr = (str + str) * raz;
05277     rzi = (sti + sti) * raz;
05278     ib = 3;
05279     i__1 = nn;
05280     for (i__ = ib; i__ <= i__1; ++i__) {
05281         yr[k] = (ak + *fnu) * (rzr * yr[k + 1] - rzi * yi[k + 1]) + yr[k + 2];
05282         yi[k] = (ak + *fnu) * (rzr * yi[k + 1] + rzi * yr[k + 1]) + yi[k + 2];
05283         ak += -1.;
05284         --k;
05285 /* L80: */
05286     }
05287     if (koded == 0) {
05288         return 0;
05289     }
05290     zzzexp_(&czr, &czi, &ckr, &cki);
05291     i__1 = nn;
05292     for (i__ = 1; i__ <= i__1; ++i__) {
05293         str = yr[i__] * ckr - yi[i__] * cki;
05294         yi[i__] = yr[i__] * cki + yi[i__] * ckr;
05295         yr[i__] = str;
05296 /* L90: */
05297     }
05298     return 0;
05299 L100:
05300     *nz = -1;
05301     return 0;
05302 L110:
05303     *nz = -2;
05304     return 0;
05305 } /* zasyi_ */
05306 
05307 /* Subroutine */ int zuoik_(doublereal *zr, doublereal *zi, doublereal *fnu, 
05308         integer *kode, integer *ikflg, integer *n, doublereal *yr, doublereal 
05309         *yi, integer *nuf, doublereal *tol, doublereal *elim, doublereal *
05310         alim)
05311 {
05312     /* Initialized data */
05313 
05314     static doublereal zeror = 0.;
05315     static doublereal zeroi = 0.;
05316     static doublereal aic = 1.265512123484645396;
05317 
05318     /* System generated locals */
05319     integer i__1;
05320 
05321     /* Builtin functions */
05322     double log(doublereal), exp(doublereal), cos(doublereal), sin(doublereal);
05323 
05324     /* Local variables */
05325     static integer i__;
05326     static doublereal ax, ay;
05327     static integer nn, nw;
05328     static doublereal fnn, gnn, zbi, czi, gnu, zbr, czr, rcz, sti, zni, zri, 
05329             str, znr, zrr, aarg, aphi, argi, phii, argr;
05330     static integer idum;
05331     extern doublereal zabs_(doublereal *, doublereal *);
05332     static doublereal phir;
05333     static integer init;
05334     static doublereal sumi, sumr, ascle;
05335     static integer iform;
05336     static doublereal asumi, bsumi, cwrki[16];
05337     extern /* Subroutine */ int zuchk_(doublereal *, doublereal *, integer *, 
05338             doublereal *, doublereal *);
05339     static doublereal asumr, bsumr, cwrkr[16];
05340     extern doublereal d1mach_(integer *);
05341     extern /* Subroutine */ int zunhj_(doublereal *, doublereal *, doublereal 
05342             *, integer *, doublereal *, doublereal *, doublereal *, 
05343             doublereal *, doublereal *, doublereal *, doublereal *, 
05344             doublereal *, doublereal *, doublereal *, doublereal *, 
05345             doublereal *, doublereal *), zunik_(doublereal *, doublereal *, 
05346             doublereal *, integer *, integer *, doublereal *, integer *, 
05347             doublereal *, doublereal *, doublereal *, doublereal *, 
05348             doublereal *, doublereal *, doublereal *, doublereal *, 
05349             doublereal *, doublereal *);
05350     static doublereal zeta1i, zeta2i, zeta1r, zeta2r;
05351     extern /* Subroutine */ int zzzlog_(doublereal *, doublereal *, 
05352             doublereal *, doublereal *, integer *);
05353 
05354 /* ***BEGIN PROLOGUE  ZUOIK */
05355 /* ***REFER TO  ZBESI,ZBESK,ZBESH */
05356 
05357 /*     ZUOIK COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC */
05358 /*     EXPANSIONS FOR THE I AND K FUNCTIONS AND COMPARES THEM */
05359 /*     (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW */
05360 /*     WHERE ALIM.LT.ELIM. IF THE MAGNITUDE, BASED ON THE LEADING */
05361 /*     EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN */
05362 /*     THE RESULT IS ON SCALE. IF NOT, THEN A REFINED TEST USING OTHER */
05363 /*     MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE */
05364 /*     EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)= */
05365 /*     EXP(-ELIM)/TOL */
05366 
05367 /*     IKFLG=1 MEANS THE I SEQUENCE IS TESTED */
05368 /*          =2 MEANS THE K SEQUENCE IS TESTED */
05369 /*     NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE */
05370 /*         =-1 MEANS AN OVERFLOW WOULD OCCUR */
05371 /*     IKFLG=1 AND NUF.GT.0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO */
05372 /*             THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE */
05373 /*     IKFLG=2 AND NUF.EQ.N MEANS ALL Y VALUES WERE SET TO ZERO */
05374 /*     IKFLG=2 AND 0.LT.NUF.LT.N NOT CONSIDERED. Y MUST BE SET BY */
05375 /*             ANOTHER ROUTINE */
05376 
05377 /* ***ROUTINES CALLED  ZUCHK,ZUNHJ,ZUNIK,D1MACH,ZABS,ZZZLOG */
05378 /* ***END PROLOGUE  ZUOIK */
05379 /*     COMPLEX ARG,ASUM,BSUM,CWRK,CZ,CZERO,PHI,SUM,Y,Z,ZB,ZETA1,ZETA2,ZN, */
05380 /*    *ZR */
05381     /* Parameter adjustments */
05382     --yi;
05383     --yr;
05384 
05385     /* Function Body */
05386     *nuf = 0;
05387     nn = *n;
05388     zrr = *zr;
05389     zri = *zi;
05390     if (*zr >= 0.) {
05391         goto L10;
05392     }
05393     zrr = -(*zr);
05394     zri = -(*zi);
05395 L10:
05396     zbr = zrr;
05397     zbi = zri;
05398     ax = abs(*zr) * 1.7321;
05399     ay = abs(*zi);
05400     iform = 1;
05401     if (ay > ax) {
05402         iform = 2;
05403     }
05404     gnu = max(*fnu,1.);
05405     if (*ikflg == 1) {
05406         goto L20;
05407     }
05408     fnn = (doublereal) ((real) nn);
05409     gnn = *fnu + fnn - 1.;
05410     gnu = max(gnn,fnn);
05411 L20:
05412 /* ----------------------------------------------------------------------- */
05413 /*     ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE */
05414 /*     REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET */
05415 /*     THE SIGN OF THE IMAGINARY PART CORRECT. */
05416 /* ----------------------------------------------------------------------- */
05417     if (iform == 2) {
05418         goto L30;
05419     }
05420     init = 0;
05421     zunik_(&zrr, &zri, &gnu, ikflg, &c__1, tol, &init, &phir, &phii, &zeta1r, 
05422             &zeta1i, &zeta2r, &zeta2i, &sumr, &sumi, cwrkr, cwrki);
05423     czr = -zeta1r + zeta2r;
05424     czi = -zeta1i + zeta2i;
05425     goto L50;
05426 L30:
05427     znr = zri;
05428     zni = -zrr;
05429     if (*zi > 0.) {
05430         goto L40;
05431     }
05432     znr = -znr;
05433 L40:
05434     zunhj_(&znr, &zni, &gnu, &c__1, tol, &phir, &phii, &argr, &argi, &zeta1r, 
05435             &zeta1i, &zeta2r, &zeta2i, &asumr, &asumi, &bsumr, &bsumi);
05436     czr = -zeta1r + zeta2r;
05437     czi = -zeta1i + zeta2i;
05438     aarg = zabs_(&argr, &argi);
05439 L50:
05440     if (*kode == 1) {
05441         goto L60;
05442     }
05443     czr -= zbr;
05444     czi -= zbi;
05445 L60:
05446     if (*ikflg == 1) {
05447         goto L70;
05448     }
05449     czr = -czr;
05450     czi = -czi;
05451 L70:
05452     aphi = zabs_(&phir, &phii);
05453     rcz = czr;
05454 /* ----------------------------------------------------------------------- */
05455 /*     OVERFLOW TEST */
05456 /* ----------------------------------------------------------------------- */
05457     if (rcz > *elim) {
05458         goto L210;
05459     }
05460     if (rcz < *alim) {
05461         goto L80;
05462     }
05463     rcz += log(aphi);
05464     if (iform == 2) {
05465         rcz = rcz - log(aarg) * .25 - aic;
05466     }
05467     if (rcz > *elim) {
05468         goto L210;
05469     }
05470     goto L130;
05471 L80:
05472 /* ----------------------------------------------------------------------- */
05473 /*     UNDERFLOW TEST */
05474 /* ----------------------------------------------------------------------- */
05475     if (rcz < -(*elim)) {
05476         goto L90;
05477     }
05478     if (rcz > -(*alim)) {
05479         goto L130;
05480     }
05481     rcz += log(aphi);
05482     if (iform == 2) {
05483         rcz = rcz - log(aarg) * .25 - aic;
05484     }
05485     if (rcz > -(*elim)) {
05486         goto L110;
05487     }
05488 L90:
05489     i__1 = nn;
05490     for (i__ = 1; i__ <= i__1; ++i__) {
05491         yr[i__] = zeror;
05492         yi[i__] = zeroi;
05493 /* L100: */
05494     }
05495     *nuf = nn;
05496     return 0;
05497 L110:
05498     ascle = d1mach_(&c__1) * 1e3 / *tol;
05499     zzzlog_(&phir, &phii, &str, &sti, &idum);
05500     czr += str;
05501     czi += sti;
05502     if (iform == 1) {
05503         goto L120;
05504     }
05505     zzzlog_(&argr, &argi, &str, &sti, &idum);
05506     czr = czr - str * .25 - aic;
05507     czi -= sti * .25;
05508 L120:
05509     ax = exp(rcz) / *tol;
05510     ay = czi;
05511     czr = ax * cos(ay);
05512     czi = ax * sin(ay);
05513     zuchk_(&czr, &czi, &nw, &ascle, tol);
05514     if (nw != 0) {
05515         goto L90;
05516     }
05517 L130:
05518     if (*ikflg == 2) {
05519         return 0;
05520     }
05521     if (*n == 1) {
05522         return 0;
05523     }
05524 /* ----------------------------------------------------------------------- */
05525 /*     SET UNDERFLOWS ON I SEQUENCE */
05526 /* ----------------------------------------------------------------------- */
05527 L140:
05528     gnu = *fnu + (doublereal) ((real) (nn - 1));
05529     if (iform == 2) {
05530         goto L150;
05531     }
05532     init = 0;
05533     zunik_(&zrr, &zri, &gnu, ikflg, &c__1, tol, &init, &phir, &phii, &zeta1r, 
05534             &zeta1i, &zeta2r, &zeta2i, &sumr, &sumi, cwrkr, cwrki);
05535     czr = -zeta1r + zeta2r;
05536     czi = -zeta1i + zeta2i;
05537     goto L160;
05538 L150:
05539     zunhj_(&znr, &zni, &gnu, &c__1, tol, &phir, &phii, &argr, &argi, &zeta1r, 
05540             &zeta1i, &zeta2r, &zeta2i, &asumr, &asumi, &bsumr, &bsumi);
05541     czr = -zeta1r + zeta2r;
05542     czi = -zeta1i + zeta2i;
05543     aarg = zabs_(&argr, &argi);
05544 L160:
05545     if (*kode == 1) {
05546         goto L170;
05547     }
05548     czr -= zbr;
05549     czi -= zbi;
05550 L170:
05551     aphi = zabs_(&phir, &phii);
05552     rcz = czr;
05553     if (rcz < -(*elim)) {
05554         goto L180;
05555     }
05556     if (rcz > -(*alim)) {
05557         return 0;
05558     }
05559     rcz += log(aphi);
05560     if (iform == 2) {
05561         rcz = rcz - log(aarg) * .25 - aic;
05562     }
05563     if (rcz > -(*elim)) {
05564         goto L190;
05565     }
05566 L180:
05567     yr[nn] = zeror;
05568     yi[nn] = zeroi;
05569     --nn;
05570     ++(*nuf);
05571     if (nn == 0) {
05572         return 0;
05573     }
05574     goto L140;
05575 L190:
05576     ascle = d1mach_(&c__1) * 1e3 / *tol;
05577     zzzlog_(&phir, &phii, &str, &sti, &idum);
05578     czr += str;
05579     czi += sti;
05580     if (iform == 1) {
05581         goto L200;
05582     }
05583     zzzlog_(&argr, &argi, &str, &sti, &idum);
05584     czr = czr - str * .25 - aic;
05585     czi -= sti * .25;
05586 L200:
05587     ax = exp(rcz) / *tol;
05588     ay = czi;
05589     czr = ax * cos(ay);
05590     czi = ax * sin(ay);
05591     zuchk_(&czr, &czi, &nw, &ascle, tol);
05592     if (nw != 0) {
05593         goto L180;
05594     }
05595     return 0;
05596 L210:
05597     *nuf = -1;
05598     return 0;
05599 } /* zuoik_ */
05600 
05601 /* Subroutine */ int zacon_(doublereal *zr, doublereal *zi, doublereal *fnu, 
05602         integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *
05603         yi, integer *nz, doublereal *rl, doublereal *fnul, doublereal *tol, 
05604         doublereal *elim, doublereal *alim)
05605 {
05606     /* Initialized data */
05607 
05608     static doublereal pi = 3.14159265358979324;
05609     static doublereal zeror = 0.;
05610     static doublereal coner = 1.;
05611 
05612     /* System generated locals */
05613     integer i__1;
05614 
05615     /* Builtin functions */
05616     double d_sign(doublereal *, doublereal *), cos(doublereal), sin(
05617             doublereal);
05618 
05619     /* Local variables */
05620     static integer i__;
05621     static doublereal fn;
05622     static integer nn, nw;
05623     static doublereal yy, c1i, c2i, c1m, as2, c1r, c2r, s1i, s2i, s1r, s2r, 
05624             cki, arg, ckr, cpn;
05625     static integer iuf;
05626     static doublereal cyi[2], fmr, csr, azn, sgn;
05627     static integer inu;
05628     static doublereal bry[3], cyr[2], pti, spn, sti, zni, rzi, ptr, str, znr, 
05629             rzr, sc1i, sc2i, sc1r, sc2r, cscl, cscr;
05630     extern doublereal zabs_(doublereal *, doublereal *);
05631     static doublereal csrr[3], cssr[3], razn;
05632     extern /* Subroutine */ int zs1s2_(doublereal *, doublereal *, doublereal 
05633             *, doublereal *, doublereal *, doublereal *, integer *, 
05634             doublereal *, doublereal *, integer *), zmlt_(doublereal *, 
05635             doublereal *, doublereal *, doublereal *, doublereal *, 
05636             doublereal *);
05637     static integer kflag;
05638     static doublereal ascle, bscle, csgni, csgnr, cspni, cspnr;
05639     extern /* Subroutine */ int zbinu_(doublereal *, doublereal *, doublereal 
05640             *, integer *, integer *, doublereal *, doublereal *, integer *, 
05641             doublereal *, doublereal *, doublereal *, doublereal *, 
05642             doublereal *), zbknu_(doublereal *, doublereal *, doublereal *, 
05643             integer *, integer *, doublereal *, doublereal *, integer *, 
05644             doublereal *, doublereal *, doublereal *);
05645     extern doublereal d1mach_(integer *);
05646 
05647 /* ***BEGIN PROLOGUE  ZACON */
05648 /* ***REFER TO  ZBESK,ZBESH */
05649 
05650 /*     ZACON APPLIES THE ANALYTIC CONTINUATION FORMULA */
05651 
05652 /*         K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) */
05653 /*                 MP=PI*MR*CMPLX(0.0,1.0) */
05654 
05655 /*     TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT */
05656 /*     HALF Z PLANE */
05657 
05658 /* ***ROUTINES CALLED  ZBINU,ZBKNU,ZS1S2,D1MACH,ZABS,ZMLT */
05659 /* ***END PROLOGUE  ZACON */
05660 /*     COMPLEX CK,CONE,CSCL,CSCR,CSGN,CSPN,CY,CZERO,C1,C2,RZ,SC1,SC2,ST, */
05661 /*    *S1,S2,Y,Z,ZN */
05662     /* Parameter adjustments */
05663     --yi;
05664     --yr;
05665 
05666     /* Function Body */
05667     *nz = 0;
05668     znr = -(*zr);
05669     zni = -(*zi);
05670     nn = *n;
05671     zbinu_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, rl, fnul, tol, 
05672             elim, alim);
05673     if (nw < 0) {
05674         goto L90;
05675     }
05676 /* ----------------------------------------------------------------------- */
05677 /*     ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION */
05678 /* ----------------------------------------------------------------------- */
05679     nn = min(2,*n);
05680     zbknu_(&znr, &zni, fnu, kode, &nn, cyr, cyi, &nw, tol, elim, alim);
05681     if (nw != 0) {
05682         goto L90;
05683     }
05684     s1r = cyr[0];
05685     s1i = cyi[0];
05686     fmr = (doublereal) ((real) (*mr));
05687     sgn = -DSIGN(pi, fmr);
05688     csgnr = zeror;
05689     csgni = sgn;
05690     if (*kode == 1) {
05691         goto L10;
05692     }
05693     yy = -zni;
05694     cpn = cos(yy);
05695     spn = sin(yy);
05696     zmlt_(&csgnr, &csgni, &cpn, &spn, &csgnr, &csgni);
05697 L10:
05698 /* ----------------------------------------------------------------------- */
05699 /*     CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE */
05700 /*     WHEN FNU IS LARGE */
05701 /* ----------------------------------------------------------------------- */
05702     inu = (integer) ((real) (*fnu));
05703     arg = (*fnu - (doublereal) ((real) inu)) * sgn;
05704     cpn = cos(arg);
05705     spn = sin(arg);
05706     cspnr = cpn;
05707     cspni = spn;
05708     if (inu % 2 == 0) {
05709         goto L20;
05710     }
05711     cspnr = -cspnr;
05712     cspni = -cspni;
05713 L20:
05714     iuf = 0;
05715     c1r = s1r;
05716     c1i = s1i;
05717     c2r = yr[1];
05718     c2i = yi[1];
05719     ascle = d1mach_(&c__1) * 1e3 / *tol;
05720     if (*kode == 1) {
05721         goto L30;
05722     }
05723     zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
05724     *nz += nw;
05725     sc1r = c1r;
05726     sc1i = c1i;
05727 L30:
05728     zmlt_(&cspnr, &cspni, &c1r, &c1i, &str, &sti);
05729     zmlt_(&csgnr, &csgni, &c2r, &c2i, &ptr, &pti);
05730     yr[1] = str + ptr;
05731     yi[1] = sti + pti;
05732     if (*n == 1) {
05733         return 0;
05734     }
05735     cspnr = -cspnr;
05736     cspni = -cspni;
05737     s2r = cyr[1];
05738     s2i = cyi[1];
05739     c1r = s2r;
05740     c1i = s2i;
05741     c2r = yr[2];
05742     c2i = yi[2];
05743     if (*kode == 1) {
05744         goto L40;
05745     }
05746     zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
05747     *nz += nw;
05748     sc2r = c1r;
05749     sc2i = c1i;
05750 L40:
05751     zmlt_(&cspnr, &cspni, &c1r, &c1i, &str, &sti);
05752     zmlt_(&csgnr, &csgni, &c2r, &c2i, &ptr, &pti);
05753     yr[2] = str + ptr;
05754     yi[2] = sti + pti;
05755     if (*n == 2) {
05756         return 0;
05757     }
05758     cspnr = -cspnr;
05759     cspni = -cspni;
05760     azn = zabs_(&znr, &zni);
05761     razn = 1. / azn;
05762     str = znr * razn;
05763     sti = -zni * razn;
05764     rzr = (str + str) * razn;
05765     rzi = (sti + sti) * razn;
05766     fn = *fnu + 1.;
05767     ckr = fn * rzr;
05768     cki = fn * rzi;
05769 /* ----------------------------------------------------------------------- */
05770 /*     SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS */
05771 /* ----------------------------------------------------------------------- */
05772     cscl = 1. / *tol;
05773     cscr = *tol;
05774     cssr[0] = cscl;
05775     cssr[1] = coner;
05776     cssr[2] = cscr;
05777     csrr[0] = cscr;
05778     csrr[1] = coner;
05779     csrr[2] = cscl;
05780     bry[0] = ascle;
05781     bry[1] = 1. / ascle;
05782     bry[2] = d1mach_(&c__2);
05783     as2 = zabs_(&s2r, &s2i);
05784     kflag = 2;
05785     if (as2 > bry[0]) {
05786         goto L50;
05787     }
05788     kflag = 1;
05789     goto L60;
05790 L50:
05791     if (as2 < bry[1]) {
05792         goto L60;
05793     }
05794     kflag = 3;
05795 L60:
05796     bscle = bry[kflag - 1];
05797     s1r *= cssr[kflag - 1];
05798     s1i *= cssr[kflag - 1];
05799     s2r *= cssr[kflag - 1];
05800     s2i *= cssr[kflag - 1];
05801     csr = csrr[kflag - 1];
05802     i__1 = *n;
05803     for (i__ = 3; i__ <= i__1; ++i__) {
05804         str = s2r;
05805         sti = s2i;
05806         s2r = ckr * str - cki * sti + s1r;
05807         s2i = ckr * sti + cki * str + s1i;
05808         s1r = str;
05809         s1i = sti;
05810         c1r = s2r * csr;
05811         c1i = s2i * csr;
05812         str = c1r;
05813         sti = c1i;
05814         c2r = yr[i__];
05815         c2i = yi[i__];
05816         if (*kode == 1) {
05817             goto L70;
05818         }
05819         if (iuf < 0) {
05820             goto L70;
05821         }
05822         zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
05823         *nz += nw;
05824         sc1r = sc2r;
05825         sc1i = sc2i;
05826         sc2r = c1r;
05827         sc2i = c1i;
05828         if (iuf != 3) {
05829             goto L70;
05830         }
05831         iuf = -4;
05832         s1r = sc1r * cssr[kflag - 1];
05833         s1i = sc1i * cssr[kflag - 1];
05834         s2r = sc2r * cssr[kflag - 1];
05835         s2i = sc2i * cssr[kflag - 1];
05836         str = sc2r;
05837         sti = sc2i;
05838 L70:
05839         ptr = cspnr * c1r - cspni * c1i;
05840         pti = cspnr * c1i + cspni * c1r;
05841         yr[i__] = ptr + csgnr * c2r - csgni * c2i;
05842         yi[i__] = pti + csgnr * c2i + csgni * c2r;
05843         ckr += rzr;
05844         cki += rzi;
05845         cspnr = -cspnr;
05846         cspni = -cspni;
05847         if (kflag >= 3) {
05848             goto L80;
05849         }
05850         ptr = abs(c1r);
05851         pti = abs(c1i);
05852         c1m = max(ptr,pti);
05853         if (c1m <= bscle) {
05854             goto L80;
05855         }
05856         ++kflag;
05857         bscle = bry[kflag - 1];
05858         s1r *= csr;
05859         s1i *= csr;
05860         s2r = str;
05861         s2i = sti;
05862         s1r *= cssr[kflag - 1];
05863         s1i *= cssr[kflag - 1];
05864         s2r *= cssr[kflag - 1];
05865         s2i *= cssr[kflag - 1];
05866         csr = csrr[kflag - 1];
05867 L80:
05868         ;
05869     }
05870     return 0;
05871 L90:
05872     *nz = -1;
05873     if (nw == -2) {
05874         *nz = -2;
05875     }
05876     return 0;
05877 } /* zacon_ */
05878 
05879 /* Subroutine */ int zbinu_(doublereal *zr, doublereal *zi, doublereal *fnu, 
05880         integer *kode, integer *n, doublereal *cyr, doublereal *cyi, integer *
05881         nz, doublereal *rl, doublereal *fnul, doublereal *tol, doublereal *
05882         elim, doublereal *alim)
05883 {
05884     /* Initialized data */
05885 
05886     static doublereal zeror = 0.;
05887     static doublereal zeroi = 0.;
05888 
05889     /* System generated locals */
05890     integer i__1;
05891 
05892     /* Local variables */
05893     static integer i__;
05894     static doublereal az;
05895     static integer nn, nw;
05896     static doublereal cwi[2], cwr[2];
05897     static integer nui, inw;
05898     static doublereal dfnu;
05899     extern doublereal zabs_(doublereal *, doublereal *);
05900     static integer nlast;
05901     extern /* Subroutine */ int zbuni_(doublereal *, doublereal *, doublereal 
05902             *, integer *, integer *, doublereal *, doublereal *, integer *, 
05903             integer *, integer *, doublereal *, doublereal *, doublereal *, 
05904             doublereal *), zseri_(doublereal *, doublereal *, doublereal *, 
05905             integer *, integer *, doublereal *, doublereal *, integer *, 
05906             doublereal *, doublereal *, doublereal *), zmlri_(doublereal *, 
05907             doublereal *, doublereal *, integer *, integer *, doublereal *, 
05908             doublereal *, integer *, doublereal *), zasyi_(doublereal *, 
05909             doublereal *, doublereal *, integer *, integer *, doublereal *, 
05910             doublereal *, integer *, doublereal *, doublereal *, doublereal *,
05911              doublereal *), zuoik_(doublereal *, doublereal *, doublereal *, 
05912             integer *, integer *, integer *, doublereal *, doublereal *, 
05913             integer *, doublereal *, doublereal *, doublereal *), zwrsk_(
05914             doublereal *, doublereal *, doublereal *, integer *, integer *, 
05915             doublereal *, doublereal *, integer *, doublereal *, doublereal *,
05916              doublereal *, doublereal *, doublereal *);
05917 
05918 /* ***BEGIN PROLOGUE  ZBINU */
05919 /* ***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZAIRY,ZBIRY */
05920 
05921 /*     ZBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE */
05922 
05923 /* ***ROUTINES CALLED  ZABS,ZASYI,ZBUNI,ZMLRI,ZSERI,ZUOIK,ZWRSK */
05924 /* ***END PROLOGUE  ZBINU */
05925     /* Parameter adjustments */
05926     --cyi;
05927     --cyr;
05928 
05929     /* Function Body */
05930 
05931     *nz = 0;
05932     az = zabs_(zr, zi);
05933     nn = *n;
05934     dfnu = *fnu + (doublereal) ((real) (*n - 1));
05935     if (az <= 2.) {
05936         goto L10;
05937     }
05938     if (az * az * .25 > dfnu + 1.) {
05939         goto L20;
05940     }
05941 L10:
05942 /* ----------------------------------------------------------------------- */
05943 /*     POWER SERIES */
05944 /* ----------------------------------------------------------------------- */
05945     zseri_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, tol, elim, alim);
05946     inw = abs(nw);
05947     *nz += inw;
05948     nn -= inw;
05949     if (nn == 0) {
05950         return 0;
05951     }
05952     if (nw >= 0) {
05953         goto L120;
05954     }
05955     dfnu = *fnu + (doublereal) ((real) (nn - 1));
05956 L20:
05957     if (az < *rl) {
05958         goto L40;
05959     }
05960     if (dfnu <= 1.) {
05961         goto L30;
05962     }
05963     if (az + az < dfnu * dfnu) {
05964         goto L50;
05965     }
05966 /* ----------------------------------------------------------------------- */
05967 /*     ASYMPTOTIC EXPANSION FOR LARGE Z */
05968 /* ----------------------------------------------------------------------- */
05969 L30:
05970     zasyi_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, rl, tol, elim, alim)
05971             ;
05972     if (nw < 0) {
05973         goto L130;
05974     }
05975     goto L120;
05976 L40:
05977     if (dfnu <= 1.) {
05978         goto L70;
05979     }
05980 L50:
05981 /* ----------------------------------------------------------------------- */
05982 /*     OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM */
05983 /* ----------------------------------------------------------------------- */
05984     zuoik_(zr, zi, fnu, kode, &c__1, &nn, &cyr[1], &cyi[1], &nw, tol, elim, 
05985             alim);
05986     if (nw < 0) {
05987         goto L130;
05988     }
05989     *nz += nw;
05990     nn -= nw;
05991     if (nn == 0) {
05992         return 0;
05993     }
05994     dfnu = *fnu + (doublereal) ((real) (nn - 1));
05995     if (dfnu > *fnul) {
05996         goto L110;
05997     }
05998     if (az > *fnul) {
05999         goto L110;
06000     }
06001 L60:
06002     if (az > *rl) {
06003         goto L80;
06004     }
06005 L70:
06006 /* ----------------------------------------------------------------------- */
06007 /*     MILLER ALGORITHM NORMALIZED BY THE SERIES */
06008 /* ----------------------------------------------------------------------- */
06009     zmlri_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, tol);
06010     if (nw < 0) {
06011         goto L130;
06012     }
06013     goto L120;
06014 L80:
06015 /* ----------------------------------------------------------------------- */
06016 /*     MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN */
06017 /* ----------------------------------------------------------------------- */
06018 /* ----------------------------------------------------------------------- */
06019 /*     OVERFLOW TEST ON K FUNCTIONS USED IN WRONSKIAN */
06020 /* ----------------------------------------------------------------------- */
06021     zuoik_(zr, zi, fnu, kode, &c__2, &c__2, cwr, cwi, &nw, tol, elim, alim);
06022     if (nw >= 0) {
06023         goto L100;
06024     }
06025     *nz = nn;
06026     i__1 = nn;
06027     for (i__ = 1; i__ <= i__1; ++i__) {
06028         cyr[i__] = zeror;
06029         cyi[i__] = zeroi;
06030 /* L90: */
06031     }
06032     return 0;
06033 L100:
06034     if (nw > 0) {
06035         goto L130;
06036     }
06037     zwrsk_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, cwr, cwi, tol, elim,
06038              alim);
06039     if (nw < 0) {
06040         goto L130;
06041     }
06042     goto L120;
06043 L110:
06044 /* ----------------------------------------------------------------------- */
06045 /*     INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD */
06046 /* ----------------------------------------------------------------------- */
06047     nui = (integer) ((real) (*fnul - dfnu)) + 1;
06048     nui = max(nui,0);
06049     zbuni_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, &nui, &nlast, fnul, 
06050             tol, elim, alim);
06051     if (nw < 0) {
06052         goto L130;
06053     }
06054     *nz += nw;
06055     if (nlast == 0) {
06056         goto L120;
06057     }
06058     nn = nlast;
06059     goto L60;
06060 L120:
06061     return 0;
06062 L130:
06063     *nz = -1;
06064     if (nw == -2) {
06065         *nz = -2;
06066     }
06067     return 0;
06068 } /* zbinu_ */
06069 
06070 doublereal dgamln_(doublereal *z__, integer *ierr)
06071 {
06072     /* Initialized data */
06073 
06074     static doublereal gln[100] = { 0.,0.,.693147180559945309,
06075             1.791759469228055,3.17805383034794562,4.78749174278204599,
06076             6.579251212010101,8.5251613610654143,10.6046029027452502,
06077             12.8018274800814696,15.1044125730755153,17.5023078458738858,
06078             19.9872144956618861,22.5521638531234229,25.1912211827386815,
06079             27.8992713838408916,30.6718601060806728,33.5050734501368889,
06080             36.3954452080330536,39.339884187199494,42.335616460753485,
06081             45.380138898476908,48.4711813518352239,51.6066755677643736,
06082             54.7847293981123192,58.0036052229805199,61.261701761002002,
06083             64.5575386270063311,67.889743137181535,71.257038967168009,
06084             74.6582363488301644,78.0922235533153106,81.5579594561150372,
06085             85.0544670175815174,88.5808275421976788,92.1361756036870925,
06086             95.7196945421432025,99.3306124547874269,102.968198614513813,
06087             106.631760260643459,110.320639714757395,114.034211781461703,
06088             117.771881399745072,121.533081515438634,125.317271149356895,
06089             129.123933639127215,132.95257503561631,136.802722637326368,
06090             140.673923648234259,144.565743946344886,148.477766951773032,
06091             152.409592584497358,156.360836303078785,160.331128216630907,
06092             164.320112263195181,168.327445448427652,172.352797139162802,
06093             176.395848406997352,180.456291417543771,184.533828861449491,
06094             188.628173423671591,192.739047287844902,196.866181672889994,
06095             201.009316399281527,205.168199482641199,209.342586752536836,
06096             213.532241494563261,217.736934113954227,221.956441819130334,
06097             226.190548323727593,230.439043565776952,234.701723442818268,
06098             238.978389561834323,243.268849002982714,247.572914096186884,
06099             251.890402209723194,256.221135550009525,260.564940971863209,
06100             264.921649798552801,269.291097651019823,273.673124285693704,
06101             278.067573440366143,282.474292687630396,286.893133295426994,
06102             291.323950094270308,295.766601350760624,300.220948647014132,
06103             304.686856765668715,309.164193580146922,313.652829949879062,
06104             318.152639620209327,322.663499126726177,327.185287703775217,
06105             331.717887196928473,336.261181979198477,340.815058870799018,
06106             345.379407062266854,349.954118040770237,354.539085519440809,
06107             359.134205369575399 };
06108     static doublereal cf[22] = { .0833333333333333333,-.00277777777777777778,
06109             7.93650793650793651e-4,-5.95238095238095238e-4,
06110             8.41750841750841751e-4,-.00191752691752691753,
06111             .00641025641025641026,-.0295506535947712418,.179644372368830573,
06112             -1.39243221690590112,13.402864044168392,-156.848284626002017,
06113             2193.10333333333333,-36108.7712537249894,691472.268851313067,
06114             -15238221.5394074162,382900751.391414141,-10882266035.7843911,
06115             347320283765.002252,-12369602142269.2745,488788064793079.335,
06116             -21320333960919373.9 };
06117     static doublereal con = 1.83787706640934548;
06118 
06119     /* System generated locals */
06120     integer i__1;
06121     doublereal ret_val;
06122 
06123     /* Builtin functions */
06124     double log(doublereal);
06125 
06126     /* Local variables */
06127     static integer i__, k;
06128     static doublereal s, t1, fz, zm;
06129     static integer mz, nz;
06130     static doublereal zp;
06131     static integer i1m;
06132     static doublereal fln, tlg, rln, trm, tst, zsq, zinc, zmin, zdmy, wdtol;
06133     extern doublereal d1mach_(integer *);
06134     extern integer i1mach_(integer *);
06135 
06136 /* ***BEGIN PROLOGUE  DGAMLN */
06137 /* ***DATE WRITTEN   830501   (YYMMDD) */
06138 /* ***REVISION DATE  830501   (YYMMDD) */
06139 /* ***CATEGORY NO.  B5F */
06140 /* ***KEYWORDS  GAMMA FUNCTION,LOGARITHM OF GAMMA FUNCTION */
06141 /* ***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES */
06142 /* ***PURPOSE  TO COMPUTE THE LOGARITHM OF THE GAMMA FUNCTION */
06143 /* ***DESCRIPTION */
06144 
06145 /*               **** A DOUBLE PRECISION ROUTINE **** */
06146 /*         DGAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR */
06147 /*         Z.GT.0.  THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES */
06148 /*         GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION */
06149 /*         G(Z+1)=Z*G(Z) FOR Z.LE.ZMIN.  THE FUNCTION WAS MADE AS */
06150 /*         PORTABLE AS POSSIBLE BY COMPUTIMG ZMIN FROM THE NUMBER OF BASE */
06151 /*         10 DIGITS IN A WORD, RLN=AMAX1(-ALOG10(R1MACH(4)),0.5E-18) */
06152 /*         LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY. */
06153 
06154 /*         SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100 */
06155 /*         VALUES IS USED FOR SPEED OF EXECUTION. */
06156 
06157 /*     DESCRIPTION OF ARGUMENTS */
06158 
06159 /*         INPUT      Z IS D0UBLE PRECISION */
06160 /*           Z      - ARGUMENT, Z.GT.0.0D0 */
06161 
06162 /*         OUTPUT      DGAMLN IS DOUBLE PRECISION */
06163 /*           DGAMLN  - NATURAL LOG OF THE GAMMA FUNCTION AT Z.NE.0.0D0 */
06164 /*           IERR    - ERROR FLAG */
06165 /*                     IERR=0, NORMAL RETURN, COMPUTATION COMPLETED */
06166 /*                     IERR=1, Z.LE.0.0D0,    NO COMPUTATION */
06167 
06168 
06169 /* ***REFERENCES  COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
06170 /*                 BY D. E. AMOS, SAND83-0083, MAY, 1983. */
06171 /* ***ROUTINES CALLED  I1MACH,D1MACH */
06172 /* ***END PROLOGUE  DGAMLN */
06173 /*           LNGAMMA(N), N=1,100 */
06174 /*             COEFFICIENTS OF ASYMPTOTIC EXPANSION */
06175 
06176 /*             LN(2*PI) */
06177 
06178 /* ***FIRST EXECUTABLE STATEMENT  DGAMLN */
06179     *ierr = 0;
06180     if (*z__ <= 0.) {
06181         goto L70;
06182     }
06183     if (*z__ > 101.) {
06184         goto L10;
06185     }
06186     nz = (integer) ((real) (*z__));
06187     fz = *z__ - (real) nz;
06188     if (fz > 0.) {
06189         goto L10;
06190     }
06191     if (nz > 100) {
06192         goto L10;
06193     }
06194     ret_val = gln[nz - 1];
06195     return ret_val;
06196 L10:
06197     wdtol = d1mach_(&c__4);
06198     wdtol = max(wdtol,5e-19);
06199     i1m = i1mach_(&c__14);
06200     rln = d1mach_(&c__5) * (real) i1m;
06201     fln = min(rln,20.);
06202     fln = max(fln,3.);
06203     fln += -3.;
06204     zm = fln * .3875 + 1.8;
06205     mz = (integer) ((real) zm) + 1;
06206     zmin = (real) mz;
06207     zdmy = *z__;
06208     zinc = 0.;
06209     if (*z__ >= zmin) {
06210         goto L20;
06211     }
06212     zinc = zmin - (real) nz;
06213     zdmy = *z__ + zinc;
06214 L20:
06215     zp = 1. / zdmy;
06216     t1 = cf[0] * zp;
06217     s = t1;
06218     if (zp < wdtol) {
06219         goto L40;
06220     }
06221     zsq = zp * zp;
06222     tst = t1 * wdtol;
06223     for (k = 2; k <= 22; ++k) {
06224         zp *= zsq;
06225         trm = cf[k - 1] * zp;
06226         if (abs(trm) < tst) {
06227             goto L40;
06228         }
06229         s += trm;
06230 /* L30: */
06231     }
06232 L40:
06233     if (zinc != 0.) {
06234         goto L50;
06235     }
06236     tlg = log(*z__);
06237     ret_val = *z__ * (tlg - 1.) + (con - tlg) * .5 + s;
06238     return ret_val;
06239 L50:
06240     zp = 1.;
06241     nz = (integer) ((real) zinc);
06242     i__1 = nz;
06243     for (i__ = 1; i__ <= i__1; ++i__) {
06244         zp *= *z__ + (real) (i__ - 1);
06245 /* L60: */
06246     }
06247     tlg = log(zdmy);
06248     ret_val = zdmy * (tlg - 1.) - log(zp) + (con - tlg) * .5 + s;
06249     return ret_val;
06250 
06251 
06252 L70:
06253     *ierr = 1;
06254     return ret_val;
06255 } /* dgamln_ */
06256 
06257 /* Subroutine */ int zacai_(doublereal *zr, doublereal *zi, doublereal *fnu, 
06258         integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *
06259         yi, integer *nz, doublereal *rl, doublereal *tol, doublereal *elim, 
06260         doublereal *alim)
06261 {
06262     /* Initialized data */
06263 
06264     static doublereal pi = 3.14159265358979324;
06265 
06266     /* Builtin functions */
06267     double d_sign(doublereal *, doublereal *), sin(doublereal), cos(
06268             doublereal);
06269 
06270     /* Local variables */
06271     static doublereal az;
06272     static integer nn, nw;
06273     static doublereal yy, c1i, c2i, c1r, c2r, arg;
06274     static integer iuf;
06275     static doublereal cyi[2], fmr, sgn;
06276     static integer inu;
06277     static doublereal cyr[2], zni, znr, dfnu;
06278     extern doublereal zabs_(doublereal *, doublereal *);
06279     extern /* Subroutine */ int zs1s2_(doublereal *, doublereal *, doublereal 
06280             *, doublereal *, doublereal *, doublereal *, integer *, 
06281             doublereal *, doublereal *, integer *);
06282     static doublereal ascle, csgni, csgnr, cspni, cspnr;
06283     extern /* Subroutine */ int zbknu_(doublereal *, doublereal *, doublereal 
06284             *, integer *, integer *, doublereal *, doublereal *, integer *, 
06285             doublereal *, doublereal *, doublereal *), zseri_(doublereal *, 
06286             doublereal *, doublereal *, integer *, integer *, doublereal *, 
06287             doublereal *, integer *, doublereal *, doublereal *, doublereal *)
06288             ;
06289     extern doublereal d1mach_(integer *);
06290     extern /* Subroutine */ int zmlri_(doublereal *, doublereal *, doublereal 
06291             *, integer *, integer *, doublereal *, doublereal *, integer *, 
06292             doublereal *), zasyi_(doublereal *, doublereal *, doublereal *, 
06293             integer *, integer *, doublereal *, doublereal *, integer *, 
06294             doublereal *, doublereal *, doublereal *, doublereal *);
06295 
06296 /* ***BEGIN PROLOGUE  ZACAI */
06297 /* ***REFER TO  ZAIRY */
06298 
06299 /*     ZACAI APPLIES THE ANALYTIC CONTINUATION FORMULA */
06300 
06301 /*         K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) */
06302 /*                 MP=PI*MR*CMPLX(0.0,1.0) */
06303 
06304 /*     TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT */
06305 /*     HALF Z PLANE FOR USE WITH ZAIRY WHERE FNU=1/3 OR 2/3 AND N=1. */
06306 /*     ZACAI IS THE SAME AS ZACON WITH THE PARTS FOR LARGER ORDERS AND */
06307 /*     RECURRENCE REMOVED. A RECURSIVE CALL TO ZACON CAN RESULT IF ZACON */
06308 /*     IS CALLED FROM ZAIRY. */
06309 
06310 /* ***ROUTINES CALLED  ZASYI,ZBKNU,ZMLRI,ZSERI,ZS1S2,D1MACH,ZABS */
06311 /* ***END PROLOGUE  ZACAI */
06312 /*     COMPLEX CSGN,CSPN,C1,C2,Y,Z,ZN,CY */
06313     /* Parameter adjustments */
06314     --yi;
06315     --yr;
06316 
06317     /* Function Body */
06318     *nz = 0;
06319     znr = -(*zr);
06320     zni = -(*zi);
06321     az = zabs_(zr, zi);
06322     nn = *n;
06323     dfnu = *fnu + (doublereal) ((real) (*n - 1));
06324     if (az <= 2.) {
06325         goto L10;
06326     }
06327     if (az * az * .25 > dfnu + 1.) {
06328         goto L20;
06329     }
06330 L10:
06331 /* ----------------------------------------------------------------------- */
06332 /*     POWER SERIES FOR THE I FUNCTION */
06333 /* ----------------------------------------------------------------------- */
06334     zseri_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, tol, elim, alim);
06335     goto L40;
06336 L20:
06337     if (az < *rl) {
06338         goto L30;
06339     }
06340 /* ----------------------------------------------------------------------- */
06341 /*     ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I FUNCTION */
06342 /* ----------------------------------------------------------------------- */
06343     zasyi_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, rl, tol, elim, 
06344             alim);
06345     if (nw < 0) {
06346         goto L80;
06347     }
06348     goto L40;
06349 L30:
06350 /* ----------------------------------------------------------------------- */
06351 /*     MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION */
06352 /* ----------------------------------------------------------------------- */
06353     zmlri_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, tol);
06354     if (nw < 0) {
06355         goto L80;
06356     }
06357 L40:
06358 /* ----------------------------------------------------------------------- */
06359 /*     ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION */
06360 /* ----------------------------------------------------------------------- */
06361     zbknu_(&znr, &zni, fnu, kode, &c__1, cyr, cyi, &nw, tol, elim, alim);
06362     if (nw != 0) {
06363         goto L80;
06364     }
06365     fmr = (doublereal) ((real) (*mr));
06366     sgn = -DSIGN(pi, fmr);
06367     csgnr = 0.;
06368     csgni = sgn;
06369     if (*kode == 1) {
06370         goto L50;
06371     }
06372     yy = -zni;
06373     csgnr = -csgni * sin(yy);
06374     csgni *= cos(yy);
06375 L50:
06376 /* ----------------------------------------------------------------------- */
06377 /*     CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE */
06378 /*     WHEN FNU IS LARGE */
06379 /* ----------------------------------------------------------------------- */
06380     inu = (integer) ((real) (*fnu));
06381     arg = (*fnu - (doublereal) ((real) inu)) * sgn;
06382     cspnr = cos(arg);
06383     cspni = sin(arg);
06384     if (inu % 2 == 0) {
06385         goto L60;
06386     }
06387     cspnr = -cspnr;
06388     cspni = -cspni;
06389 L60:
06390     c1r = cyr[0];
06391     c1i = cyi[0];
06392     c2r = yr[1];
06393     c2i = yi[1];
06394     if (*kode == 1) {
06395         goto L70;
06396     }
06397     iuf = 0;
06398     ascle = d1mach_(&c__1) * 1e3 / *tol;
06399     zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
06400     *nz += nw;
06401 L70:
06402     yr[1] = cspnr * c1r - cspni * c1i + csgnr * c2r - csgni * c2i;
06403     yi[1] = cspnr * c1i + cspni * c1r + csgnr * c2i + csgni * c2r;
06404     return 0;
06405 L80:
06406     *nz = -1;
06407     if (nw == -2) {
06408         *nz = -2;
06409     }
06410     return 0;
06411 } /* zacai_ */
06412 
06413 /* Subroutine */ int zuchk_(doublereal *yr, doublereal *yi, integer *nz, 
06414         doublereal *ascle, doublereal *tol)
06415 {
06416     static doublereal wi, ss, st, wr;
06417 
06418 /* ***BEGIN PROLOGUE  ZUCHK */
06419 /* ***REFER TO ZSERI,ZUOIK,ZUNK1,ZUNK2,ZUNI1,ZUNI2,ZKSCL */
06420 
06421 /*      Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN */
06422 /*      EXP(-ALIM)=ASCLE=1.0E+3*D1MACH(1)/TOL. THE TEST IS MADE TO SEE */
06423 /*      IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDERFLOW */
06424 /*      WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED */
06425 /*      IF THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE */
06426 /*      OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE */
06427 /*      ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED. */
06428 
06429 /* ***ROUTINES CALLED  (NONE) */
06430 /* ***END PROLOGUE  ZUCHK */
06431 
06432 /*     COMPLEX Y */
06433     *nz = 0;
06434     wr = abs(*yr);
06435     wi = abs(*yi);
06436     st = min(wr,wi);
06437     if (st > *ascle) {
06438         return 0;
06439     }
06440     ss = max(wr,wi);
06441     st /= *tol;
06442     if (ss < st) {
06443         *nz = 1;
06444     }
06445     return 0;
06446 } /* zuchk_ */
06447 
06448 /* Subroutine */ int zunik_(doublereal *zrr, doublereal *zri, doublereal *fnu,
06449          integer *ikflg, integer *ipmtr, doublereal *tol, integer *init, 
06450         doublereal *phir, doublereal *phii, doublereal *zeta1r, doublereal *
06451         zeta1i, doublereal *zeta2r, doublereal *zeta2i, doublereal *sumr, 
06452         doublereal *sumi, doublereal *cwrkr, doublereal *cwrki)
06453 {
06454     /* Initialized data */
06455 
06456     static doublereal zeror = 0.;
06457     static doublereal zeroi = 0.;
06458     static doublereal coner = 1.;
06459     static doublereal conei = 0.;
06460     static doublereal con[2] = { .398942280401432678,1.25331413731550025 };
06461     static doublereal c__[120] = { 1.,-.208333333333333333,.125,
06462             .334201388888888889,-.401041666666666667,.0703125,
06463             -1.02581259645061728,1.84646267361111111,-.8912109375,.0732421875,
06464             4.66958442342624743,-11.2070026162229938,8.78912353515625,
06465             -2.3640869140625,.112152099609375,-28.2120725582002449,
06466             84.6362176746007346,-91.8182415432400174,42.5349987453884549,
06467             -7.3687943594796317,.227108001708984375,212.570130039217123,
06468             -765.252468141181642,1059.99045252799988,-699.579627376132541,
06469             218.19051174421159,-26.4914304869515555,.572501420974731445,
06470             -1919.457662318407,8061.72218173730938,-13586.5500064341374,
06471             11655.3933368645332,-5305.64697861340311,1200.90291321635246,
06472             -108.090919788394656,1.7277275025844574,20204.2913309661486,
06473             -96980.5983886375135,192547.001232531532,-203400.177280415534,
06474             122200.46498301746,-41192.6549688975513,7109.51430248936372,
06475             -493.915304773088012,6.07404200127348304,-242919.187900551333,
06476             1311763.6146629772,-2998015.91853810675,3763271.297656404,
06477             -2813563.22658653411,1268365.27332162478,-331645.172484563578,
06478             45218.7689813627263,-2499.83048181120962,24.3805296995560639,
06479             3284469.85307203782,-19706819.1184322269,50952602.4926646422,
06480             -74105148.2115326577,66344512.2747290267,-37567176.6607633513,
06481             13288767.1664218183,-2785618.12808645469,308186.404612662398,
06482             -13886.0897537170405,110.017140269246738,-49329253.664509962,
06483             325573074.185765749,-939462359.681578403,1553596899.57058006,
06484             -1621080552.10833708,1106842816.82301447,-495889784.275030309,
06485             142062907.797533095,-24474062.7257387285,2243768.17792244943,
06486             -84005.4336030240853,551.335896122020586,814789096.118312115,
06487             -5866481492.05184723,18688207509.2958249,-34632043388.1587779,
06488             41280185579.753974,-33026599749.8007231,17954213731.1556001,
06489             -6563293792.61928433,1559279864.87925751,-225105661.889415278,
06490             17395107.5539781645,-549842.327572288687,3038.09051092238427,
06491             -14679261247.6956167,114498237732.02581,-399096175224.466498,
06492             819218669548.577329,-1098375156081.22331,1008158106865.38209,
06493             -645364869245.376503,287900649906.150589,-87867072178.0232657,
06494             17634730606.8349694,-2167164983.22379509,143157876.718888981,
06495             -3871833.44257261262,18257.7554742931747,286464035717.679043,
06496             -2406297900028.50396,9109341185239.89896,-20516899410934.4374,
06497             30565125519935.3206,-31667088584785.1584,23348364044581.8409,
06498             -12320491305598.2872,4612725780849.13197,-1196552880196.1816,
06499             205914503232.410016,-21822927757.5292237,1247009293.51271032,
06500             -29188388.1222208134,118838.426256783253 };
06501 
06502     /* System generated locals */
06503     integer i__1;
06504     doublereal d__1, d__2;
06505 
06506     /* Builtin functions */
06507     double log(doublereal);
06508 
06509     /* Local variables */
06510     extern /* Subroutine */ int zzzsqrt_(doublereal *, doublereal *, 
06511             doublereal *, doublereal *);
06512     static integer i__, j, k, l;
06513     static doublereal ac, si, ti, sr, tr, t2i, t2r, rfn, sri, sti, zni, srr, 
06514             str, znr;
06515     static integer idum;
06516     extern /* Subroutine */ int zdiv_(doublereal *, doublereal *, doublereal *
06517             , doublereal *, doublereal *, doublereal *);
06518     static doublereal test, crfni, crfnr;
06519     extern doublereal d1mach_(integer *);
06520     extern /* Subroutine */ int zzzlog_(doublereal *, doublereal *, 
06521             doublereal *, doublereal *, integer *);
06522 
06523 /* ***BEGIN PROLOGUE  ZUNIK */
06524 /* ***REFER TO  ZBESI,ZBESK */
06525 
06526 /*        ZUNIK COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC */
06527 /*        EXPANSIONS OF THE I AND K FUNCTIONS ON IKFLG= 1 OR 2 */
06528 /*        RESPECTIVELY BY */
06529 
06530 /*        W(FNU,ZR) = PHI*EXP(ZETA)*SUM */
06531 
06532 /*        WHERE       ZETA=-ZETA1 + ZETA2       OR */
06533 /*                          ZETA1 - ZETA2 */
06534 
06535 /*        THE FIRST CALL MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE */
06536 /*        SAME ZR AND FNU WILL RETURN THE I OR K FUNCTION ON IKFLG= */
06537 /*        1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK */
06538 /*        ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI, */
06539 /*        ZETA1,ZETA2. */
06540 
06541 /* ***ROUTINES CALLED  ZDIV,ZZZLOG,ZZZSQRT,D1MACH */
06542 /* ***END PROLOGUE  ZUNIK */
06543 /*     COMPLEX CFN,CON,CONE,CRFN,CWRK,CZERO,PHI,S,SR,SUM,T,T2,ZETA1, */
06544 /*    *ZETA2,ZN,ZR */
06545     /* Parameter adjustments */
06546     --cwrki;
06547     --cwrkr;
06548 
06549     /* Function Body */
06550 
06551     if (*init != 0) {
06552         goto L40;
06553     }
06554 /* ----------------------------------------------------------------------- */
06555 /*     INITIALIZE ALL VARIABLES */
06556 /* ----------------------------------------------------------------------- */
06557     rfn = 1. / *fnu;
06558 /* ----------------------------------------------------------------------- */
06559 /*     OVERFLOW TEST (ZR/FNU TOO SMALL) */
06560 /* ----------------------------------------------------------------------- */
06561     test = d1mach_(&c__1) * 1e3;
06562     ac = *fnu * test;
06563     if (abs(*zrr) > ac || abs(*zri) > ac) {
06564         goto L15;
06565     }
06566     *zeta1r = (d__1 = log(test), abs(d__1)) * 2. + *fnu;
06567     *zeta1i = 0.;
06568     *zeta2r = *fnu;
06569     *zeta2i = 0.;
06570     *phir = 1.;
06571     *phii = 0.;
06572     return 0;
06573 L15:
06574     tr = *zrr * rfn;
06575     ti = *zri * rfn;
06576     sr = coner + (tr * tr - ti * ti);
06577     si = conei + (tr * ti + ti * tr);
06578     zzzsqrt_(&sr, &si, &srr, &sri);
06579     str = coner + srr;
06580     sti = conei + sri;
06581     zdiv_(&str, &sti, &tr, &ti, &znr, &zni);
06582     zzzlog_(&znr, &zni, &str, &sti, &idum);
06583     *zeta1r = *fnu * str;
06584     *zeta1i = *fnu * sti;
06585     *zeta2r = *fnu * srr;
06586     *zeta2i = *fnu * sri;
06587     zdiv_(&coner, &conei, &srr, &sri, &tr, &ti);
06588     srr = tr * rfn;
06589     sri = ti * rfn;
06590     zzzsqrt_(&srr, &sri, &cwrkr[16], &cwrki[16]);
06591     *phir = cwrkr[16] * con[*ikflg - 1];
06592     *phii = cwrki[16] * con[*ikflg - 1];
06593     if (*ipmtr != 0) {
06594         return 0;
06595     }
06596     zdiv_(&coner, &conei, &sr, &si, &t2r, &t2i);
06597     cwrkr[1] = coner;
06598     cwrki[1] = conei;
06599     crfnr = coner;
06600     crfni = conei;
06601     ac = 1.;
06602     l = 1;
06603     for (k = 2; k <= 15; ++k) {
06604         sr = zeror;
06605         si = zeroi;
06606         i__1 = k;
06607         for (j = 1; j <= i__1; ++j) {
06608             ++l;
06609             str = sr * t2r - si * t2i + c__[l - 1];
06610             si = sr * t2i + si * t2r;
06611             sr = str;
06612 /* L10: */
06613         }
06614         str = crfnr * srr - crfni * sri;
06615         crfni = crfnr * sri + crfni * srr;
06616         crfnr = str;
06617         cwrkr[k] = crfnr * sr - crfni * si;
06618         cwrki[k] = crfnr * si + crfni * sr;
06619         ac *= rfn;
06620         test = (d__1 = cwrkr[k], abs(d__1)) + (d__2 = cwrki[k], abs(d__2));
06621         if (ac < *tol && test < *tol) {
06622             goto L30;
06623         }
06624 /* L20: */
06625     }
06626     k = 15;
06627 L30:
06628     *init = k;
06629 L40:
06630     if (*ikflg == 2) {
06631         goto L60;
06632     }
06633 /* ----------------------------------------------------------------------- */
06634 /*     COMPUTE SUM FOR THE I FUNCTION */
06635 /* ----------------------------------------------------------------------- */
06636     sr = zeror;
06637     si = zeroi;
06638     i__1 = *init;
06639     for (i__ = 1; i__ <= i__1; ++i__) {
06640         sr += cwrkr[i__];
06641         si += cwrki[i__];
06642 /* L50: */
06643     }
06644     *sumr = sr;
06645     *sumi = si;
06646     *phir = cwrkr[16] * con[0];
06647     *phii = cwrki[16] * con[0];
06648     return 0;
06649 L60:
06650 /* ----------------------------------------------------------------------- */
06651 /*     COMPUTE SUM FOR THE K FUNCTION */
06652 /* ----------------------------------------------------------------------- */
06653     sr = zeror;
06654     si = zeroi;
06655     tr = coner;
06656     i__1 = *init;
06657     for (i__ = 1; i__ <= i__1; ++i__) {
06658         sr += tr * cwrkr[i__];
06659         si += tr * cwrki[i__];
06660         tr = -tr;
06661 /* L70: */
06662     }
06663     *sumr = sr;
06664     *sumi = si;
06665     *phir = cwrkr[16] * con[1];
06666     *phii = cwrki[16] * con[1];
06667     return 0;
06668 } /* zunik_ */
06669 
06670 /* Subroutine */ int zunhj_(doublereal *zr, doublereal *zi, doublereal *fnu, 
06671         integer *ipmtr, doublereal *tol, doublereal *phir, doublereal *phii, 
06672         doublereal *argr, doublereal *argi, doublereal *zeta1r, doublereal *
06673         zeta1i, doublereal *zeta2r, doublereal *zeta2i, doublereal *asumr, 
06674         doublereal *asumi, doublereal *bsumr, doublereal *bsumi)
06675 {
06676     /* Initialized data */
06677 
06678     static doublereal ar[14] = { 1.,.104166666666666667,.0835503472222222222,
06679             .12822657455632716,.291849026464140464,.881627267443757652,
06680             3.32140828186276754,14.9957629868625547,78.9230130115865181,
06681             474.451538868264323,3207.49009089066193,24086.5496408740049,
06682             198923.119169509794,1791902.00777534383 };
06683     static doublereal br[14] = { 1.,-.145833333333333333,
06684             -.0987413194444444444,-.143312053915895062,-.317227202678413548,
06685             -.942429147957120249,-3.51120304082635426,-15.7272636203680451,
06686             -82.2814390971859444,-492.355370523670524,-3316.21856854797251,
06687             -24827.6742452085896,-204526.587315129788,-1838444.9170682099 };
06688     static doublereal c__[105] = { 1.,-.208333333333333333,.125,
06689             .334201388888888889,-.401041666666666667,.0703125,
06690             -1.02581259645061728,1.84646267361111111,-.8912109375,.0732421875,
06691             4.66958442342624743,-11.2070026162229938,8.78912353515625,
06692             -2.3640869140625,.112152099609375,-28.2120725582002449,
06693             84.6362176746007346,-91.8182415432400174,42.5349987453884549,
06694             -7.3687943594796317,.227108001708984375,212.570130039217123,
06695             -765.252468141181642,1059.99045252799988,-699.579627376132541,
06696             218.19051174421159,-26.4914304869515555,.572501420974731445,
06697             -1919.457662318407,8061.72218173730938,-13586.5500064341374,
06698             11655.3933368645332,-5305.64697861340311,1200.90291321635246,
06699             -108.090919788394656,1.7277275025844574,20204.2913309661486,
06700             -96980.5983886375135,192547.001232531532,-203400.177280415534,
06701             122200.46498301746,-41192.6549688975513,7109.51430248936372,
06702             -493.915304773088012,6.07404200127348304,-242919.187900551333,
06703             1311763.6146629772,-2998015.91853810675,3763271.297656404,
06704             -2813563.22658653411,1268365.27332162478,-331645.172484563578,
06705             45218.7689813627263,-2499.83048181120962,24.3805296995560639,
06706             3284469.85307203782,-19706819.1184322269,50952602.4926646422,
06707             -74105148.2115326577,66344512.2747290267,-37567176.6607633513,
06708             13288767.1664218183,-2785618.12808645469,308186.404612662398,
06709             -13886.0897537170405,110.017140269246738,-49329253.664509962,
06710             325573074.185765749,-939462359.681578403,1553596899.57058006,
06711             -1621080552.10833708,1106842816.82301447,-495889784.275030309,
06712             142062907.797533095,-24474062.7257387285,2243768.17792244943,
06713             -84005.4336030240853,551.335896122020586,814789096.118312115,
06714             -5866481492.05184723,18688207509.2958249,-34632043388.1587779,
06715             41280185579.753974,-33026599749.8007231,17954213731.1556001,
06716             -6563293792.61928433,1559279864.87925751,-225105661.889415278,
06717             17395107.5539781645,-549842.327572288687,3038.09051092238427,
06718             -14679261247.6956167,114498237732.02581,-399096175224.466498,
06719             819218669548.577329,-1098375156081.22331,1008158106865.38209,
06720             -645364869245.376503,287900649906.150589,-87867072178.0232657,
06721             17634730606.8349694,-2167164983.22379509,143157876.718888981,
06722             -3871833.44257261262,18257.7554742931747 };
06723     static doublereal alfa[180] = { -.00444444444444444444,
06724             -9.22077922077922078e-4,-8.84892884892884893e-5,
06725             1.65927687832449737e-4,2.4669137274179291e-4,
06726             2.6599558934625478e-4,2.61824297061500945e-4,
06727             2.48730437344655609e-4,2.32721040083232098e-4,
06728             2.16362485712365082e-4,2.00738858762752355e-4,
06729             1.86267636637545172e-4,1.73060775917876493e-4,
06730             1.61091705929015752e-4,1.50274774160908134e-4,
06731             1.40503497391269794e-4,1.31668816545922806e-4,
06732             1.23667445598253261e-4,1.16405271474737902e-4,
06733             1.09798298372713369e-4,1.03772410422992823e-4,
06734             9.82626078369363448e-5,9.32120517249503256e-5,
06735             8.85710852478711718e-5,8.42963105715700223e-5,
06736             8.03497548407791151e-5,7.66981345359207388e-5,
06737             7.33122157481777809e-5,7.01662625163141333e-5,
06738             6.72375633790160292e-5,6.93735541354588974e-4,
06739             2.32241745182921654e-4,-1.41986273556691197e-5,
06740             -1.1644493167204864e-4,-1.50803558053048762e-4,
06741             -1.55121924918096223e-4,-1.46809756646465549e-4,
06742             -1.33815503867491367e-4,-1.19744975684254051e-4,
06743             -1.0618431920797402e-4,-9.37699549891194492e-5,
06744             -8.26923045588193274e-5,-7.29374348155221211e-5,
06745             -6.44042357721016283e-5,-5.69611566009369048e-5,
06746             -5.04731044303561628e-5,-4.48134868008882786e-5,
06747             -3.98688727717598864e-5,-3.55400532972042498e-5,
06748             -3.1741425660902248e-5,-2.83996793904174811e-5,
06749             -2.54522720634870566e-5,-2.28459297164724555e-5,
06750             -2.05352753106480604e-5,-1.84816217627666085e-5,
06751             -1.66519330021393806e-5,-1.50179412980119482e-5,
06752             -1.35554031379040526e-5,-1.22434746473858131e-5,
06753             -1.10641884811308169e-5,-3.54211971457743841e-4,
06754             -1.56161263945159416e-4,3.0446550359493641e-5,
06755             1.30198655773242693e-4,1.67471106699712269e-4,
06756             1.70222587683592569e-4,1.56501427608594704e-4,
06757             1.3633917097744512e-4,1.14886692029825128e-4,
06758             9.45869093034688111e-5,7.64498419250898258e-5,
06759             6.07570334965197354e-5,4.74394299290508799e-5,
06760             3.62757512005344297e-5,2.69939714979224901e-5,
06761             1.93210938247939253e-5,1.30056674793963203e-5,
06762             7.82620866744496661e-6,3.59257485819351583e-6,
06763             1.44040049814251817e-7,-2.65396769697939116e-6,
06764             -4.9134686709848591e-6,-6.72739296091248287e-6,
06765             -8.17269379678657923e-6,-9.31304715093561232e-6,
06766             -1.02011418798016441e-5,-1.0880596251059288e-5,
06767             -1.13875481509603555e-5,-1.17519675674556414e-5,
06768             -1.19987364870944141e-5,3.78194199201772914e-4,
06769             2.02471952761816167e-4,-6.37938506318862408e-5,
06770             -2.38598230603005903e-4,-3.10916256027361568e-4,
06771             -3.13680115247576316e-4,-2.78950273791323387e-4,
06772             -2.28564082619141374e-4,-1.75245280340846749e-4,
06773             -1.25544063060690348e-4,-8.22982872820208365e-5,
06774             -4.62860730588116458e-5,-1.72334302366962267e-5,
06775             5.60690482304602267e-6,2.313954431482868e-5,
06776             3.62642745856793957e-5,4.58006124490188752e-5,
06777             5.2459529495911405e-5,5.68396208545815266e-5,
06778             5.94349820393104052e-5,6.06478527578421742e-5,
06779             6.08023907788436497e-5,6.01577894539460388e-5,
06780             5.891996573446985e-5,5.72515823777593053e-5,
06781             5.52804375585852577e-5,5.3106377380288017e-5,
06782             5.08069302012325706e-5,4.84418647620094842e-5,
06783             4.6056858160747537e-5,-6.91141397288294174e-4,
06784             -4.29976633058871912e-4,1.83067735980039018e-4,
06785             6.60088147542014144e-4,8.75964969951185931e-4,
06786             8.77335235958235514e-4,7.49369585378990637e-4,
06787             5.63832329756980918e-4,3.68059319971443156e-4,
06788             1.88464535514455599e-4,3.70663057664904149e-5,
06789             -8.28520220232137023e-5,-1.72751952869172998e-4,
06790             -2.36314873605872983e-4,-2.77966150694906658e-4,
06791             -3.02079514155456919e-4,-3.12594712643820127e-4,
06792             -3.12872558758067163e-4,-3.05678038466324377e-4,
06793             -2.93226470614557331e-4,-2.77255655582934777e-4,
06794             -2.59103928467031709e-4,-2.39784014396480342e-4,
06795             -2.20048260045422848e-4,-2.00443911094971498e-4,
06796             -1.81358692210970687e-4,-1.63057674478657464e-4,
06797             -1.45712672175205844e-4,-1.29425421983924587e-4,
06798             -1.14245691942445952e-4,.00192821964248775885,
06799             .00135592576302022234,-7.17858090421302995e-4,
06800             -.00258084802575270346,-.00349271130826168475,
06801             -.00346986299340960628,-.00282285233351310182,
06802             -.00188103076404891354,-8.895317183839476e-4,
06803             3.87912102631035228e-6,7.28688540119691412e-4,
06804             .00126566373053457758,.00162518158372674427,.00183203153216373172,
06805             .00191588388990527909,.00190588846755546138,.00182798982421825727,
06806             .0017038950642112153,.00155097127171097686,.00138261421852276159,
06807             .00120881424230064774,.00103676532638344962,
06808             8.71437918068619115e-4,7.16080155297701002e-4,
06809             5.72637002558129372e-4,4.42089819465802277e-4,
06810             3.24724948503090564e-4,2.20342042730246599e-4,
06811             1.28412898401353882e-4,4.82005924552095464e-5 };
06812     static doublereal beta[210] = { .0179988721413553309,
06813             .00559964911064388073,.00288501402231132779,.00180096606761053941,
06814             .00124753110589199202,9.22878876572938311e-4,
06815             7.14430421727287357e-4,5.71787281789704872e-4,
06816             4.69431007606481533e-4,3.93232835462916638e-4,
06817             3.34818889318297664e-4,2.88952148495751517e-4,
06818             2.52211615549573284e-4,2.22280580798883327e-4,
06819             1.97541838033062524e-4,1.76836855019718004e-4,
06820             1.59316899661821081e-4,1.44347930197333986e-4,
06821             1.31448068119965379e-4,1.20245444949302884e-4,
06822             1.10449144504599392e-4,1.01828770740567258e-4,
06823             9.41998224204237509e-5,8.74130545753834437e-5,
06824             8.13466262162801467e-5,7.59002269646219339e-5,
06825             7.09906300634153481e-5,6.65482874842468183e-5,
06826             6.25146958969275078e-5,5.88403394426251749e-5,
06827             -.00149282953213429172,-8.78204709546389328e-4,
06828             -5.02916549572034614e-4,-2.94822138512746025e-4,
06829             -1.75463996970782828e-4,-1.04008550460816434e-4,
06830             -5.96141953046457895e-5,-3.1203892907609834e-5,
06831             -1.26089735980230047e-5,-2.42892608575730389e-7,
06832             8.05996165414273571e-6,1.36507009262147391e-5,
06833             1.73964125472926261e-5,1.9867297884213378e-5,
06834             2.14463263790822639e-5,2.23954659232456514e-5,
06835             2.28967783814712629e-5,2.30785389811177817e-5,
06836             2.30321976080909144e-5,2.28236073720348722e-5,
06837             2.25005881105292418e-5,2.20981015361991429e-5,
06838             2.16418427448103905e-5,2.11507649256220843e-5,
06839             2.06388749782170737e-5,2.01165241997081666e-5,
06840             1.95913450141179244e-5,1.9068936791043674e-5,
06841             1.85533719641636667e-5,1.80475722259674218e-5,
06842             5.5221307672129279e-4,4.47932581552384646e-4,
06843             2.79520653992020589e-4,1.52468156198446602e-4,
06844             6.93271105657043598e-5,1.76258683069991397e-5,
06845             -1.35744996343269136e-5,-3.17972413350427135e-5,
06846             -4.18861861696693365e-5,-4.69004889379141029e-5,
06847             -4.87665447413787352e-5,-4.87010031186735069e-5,
06848             -4.74755620890086638e-5,-4.55813058138628452e-5,
06849             -4.33309644511266036e-5,-4.09230193157750364e-5,
06850             -3.84822638603221274e-5,-3.60857167535410501e-5,
06851             -3.37793306123367417e-5,-3.15888560772109621e-5,
06852             -2.95269561750807315e-5,-2.75978914828335759e-5,
06853             -2.58006174666883713e-5,-2.413083567612802e-5,
06854             -2.25823509518346033e-5,-2.11479656768912971e-5,
06855             -1.98200638885294927e-5,-1.85909870801065077e-5,
06856             -1.74532699844210224e-5,-1.63997823854497997e-5,
06857             -4.74617796559959808e-4,-4.77864567147321487e-4,
06858             -3.20390228067037603e-4,-1.61105016119962282e-4,
06859             -4.25778101285435204e-5,3.44571294294967503e-5,
06860             7.97092684075674924e-5,1.031382367082722e-4,
06861             1.12466775262204158e-4,1.13103642108481389e-4,
06862             1.08651634848774268e-4,1.01437951597661973e-4,
06863             9.29298396593363896e-5,8.40293133016089978e-5,
06864             7.52727991349134062e-5,6.69632521975730872e-5,
06865             5.92564547323194704e-5,5.22169308826975567e-5,
06866             4.58539485165360646e-5,4.01445513891486808e-5,
06867             3.50481730031328081e-5,3.05157995034346659e-5,
06868             2.64956119950516039e-5,2.29363633690998152e-5,
06869             1.97893056664021636e-5,1.70091984636412623e-5,
06870             1.45547428261524004e-5,1.23886640995878413e-5,
06871             1.04775876076583236e-5,8.79179954978479373e-6,
06872             7.36465810572578444e-4,8.72790805146193976e-4,
06873             6.22614862573135066e-4,2.85998154194304147e-4,
06874             3.84737672879366102e-6,-1.87906003636971558e-4,
06875             -2.97603646594554535e-4,-3.45998126832656348e-4,
06876             -3.53382470916037712e-4,-3.35715635775048757e-4,
06877             -3.04321124789039809e-4,-2.66722723047612821e-4,
06878             -2.27654214122819527e-4,-1.89922611854562356e-4,
06879             -1.5505891859909387e-4,-1.2377824076187363e-4,
06880             -9.62926147717644187e-5,-7.25178327714425337e-5,
06881             -5.22070028895633801e-5,-3.50347750511900522e-5,
06882             -2.06489761035551757e-5,-8.70106096849767054e-6,
06883             1.1369868667510029e-6,9.16426474122778849e-6,
06884             1.5647778542887262e-5,2.08223629482466847e-5,
06885             2.48923381004595156e-5,2.80340509574146325e-5,
06886             3.03987774629861915e-5,3.21156731406700616e-5,
06887             -.00180182191963885708,-.00243402962938042533,
06888             -.00183422663549856802,-7.62204596354009765e-4,
06889             2.39079475256927218e-4,9.49266117176881141e-4,
06890             .00134467449701540359,.00148457495259449178,.00144732339830617591,
06891             .00130268261285657186,.00110351597375642682,
06892             8.86047440419791759e-4,6.73073208165665473e-4,
06893             4.77603872856582378e-4,3.05991926358789362e-4,
06894             1.6031569459472163e-4,4.00749555270613286e-5,
06895             -5.66607461635251611e-5,-1.32506186772982638e-4,
06896             -1.90296187989614057e-4,-2.32811450376937408e-4,
06897             -2.62628811464668841e-4,-2.82050469867598672e-4,
06898             -2.93081563192861167e-4,-2.97435962176316616e-4,
06899             -2.96557334239348078e-4,-2.91647363312090861e-4,
06900             -2.83696203837734166e-4,-2.73512317095673346e-4,
06901             -2.6175015580676858e-4,.00638585891212050914,
06902             .00962374215806377941,.00761878061207001043,.00283219055545628054,
06903             -.0020984135201272009,-.00573826764216626498,
06904             -.0077080424449541462,-.00821011692264844401,
06905             -.00765824520346905413,-.00647209729391045177,
06906             -.00499132412004966473,-.0034561228971313328,
06907             -.00201785580014170775,-7.59430686781961401e-4,
06908             2.84173631523859138e-4,.00110891667586337403,
06909             .00172901493872728771,.00216812590802684701,.00245357710494539735,
06910             .00261281821058334862,.00267141039656276912,.0026520307339598043,
06911             .00257411652877287315,.00245389126236094427,.00230460058071795494,
06912             .00213684837686712662,.00195896528478870911,.00177737008679454412,
06913             .00159690280765839059,.00142111975664438546 };
06914     static doublereal gama[30] = { .629960524947436582,.251984209978974633,
06915             .154790300415655846,.110713062416159013,.0857309395527394825,
06916             .0697161316958684292,.0586085671893713576,.0504698873536310685,
06917             .0442600580689154809,.0393720661543509966,.0354283195924455368,
06918             .0321818857502098231,.0294646240791157679,.0271581677112934479,
06919             .0251768272973861779,.0234570755306078891,.0219508390134907203,
06920             .020621082823564624,.0194388240897880846,.0183810633800683158,
06921             .0174293213231963172,.0165685837786612353,.0157865285987918445,
06922             .0150729501494095594,.0144193250839954639,.0138184805735341786,
06923             .0132643378994276568,.0127517121970498651,.0122761545318762767,
06924             .0118338262398482403 };
06925     static doublereal ex1 = .333333333333333333;
06926     static doublereal ex2 = .666666666666666667;
06927     static doublereal hpi = 1.57079632679489662;
06928     static doublereal gpi = 3.14159265358979324;
06929     static doublereal thpi = 4.71238898038468986;
06930     static doublereal zeror = 0.;
06931     static doublereal zeroi = 0.;
06932     static doublereal coner = 1.;
06933     static doublereal conei = 0.;
06934 
06935     /* System generated locals */
06936     integer i__1, i__2;
06937     doublereal d__1;
06938 
06939     /* Builtin functions */
06940     double log(doublereal), pow_dd(doublereal *, doublereal *), atan(
06941             doublereal), cos(doublereal), sin(doublereal), sqrt(doublereal);
06942 
06943     /* Local variables */
06944     extern /* Subroutine */ int zzzsqrt_(doublereal *, doublereal *, 
06945             doublereal *, doublereal *);
06946     static integer j, k, l, m, l1, l2;
06947     static doublereal ac, ap[30], pi[30];
06948     static integer is, jr, ks, ju;
06949     static doublereal pp, wi, pr[30];
06950     static integer lr;
06951     static doublereal wr, aw2;
06952     static integer kp1;
06953     static doublereal t2i, w2i, t2r, w2r, ang, fn13, fn23;
06954     static integer ias;
06955     static doublereal cri[14], dri[14];
06956     static integer ibs;
06957     static doublereal zai, zbi, zci, crr[14], drr[14], raw, zar, upi[14], sti,
06958              zbr, zcr, upr[14], str, raw2;
06959     static integer lrp1;
06960     static doublereal rfn13;
06961     static integer idum;
06962     extern doublereal zabs_(doublereal *, doublereal *);
06963     static doublereal atol, btol, tfni;
06964     static integer kmax;
06965     static doublereal azth, tzai, tfnr, rfnu;
06966     extern /* Subroutine */ int zdiv_(doublereal *, doublereal *, doublereal *
06967             , doublereal *, doublereal *, doublereal *);
06968     static doublereal zthi, test, tzar, zthr, rfnu2, zetai, ptfni, sumai, 
06969             sumbi, zetar, ptfnr, razth, sumar, sumbr, rzthi;
06970     extern doublereal d1mach_(integer *);
06971     static doublereal rzthr, rtzti, rtztr, przthi, przthr;
06972     extern /* Subroutine */ int zzzlog_(doublereal *, doublereal *, 
06973             doublereal *, doublereal *, integer *);
06974 
06975 /* ***BEGIN PROLOGUE  ZUNHJ */
06976 /* ***REFER TO  ZBESI,ZBESK */
06977 
06978 /*     REFERENCES */
06979 /*         HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ AND I.A. */
06980 /*         STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9. */
06981 
06982 /*         ASYMPTOTICS AND SPECIAL FUNCTIONS BY F.W.J. OLVER, ACADEMIC */
06983 /*         PRESS, N.Y., 1974, PAGE 420 */
06984 
06985 /*     ABSTRACT */
06986 /*         ZUNHJ COMPUTES PARAMETERS FOR BESSEL FUNCTIONS C(FNU,Z) = */
06987 /*         J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU */
06988 /*         BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION */
06989 
06990 /*         C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) ) */
06991 
06992 /*         FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS */
06993 /*         AN AIRY FUNCTION AND DAIRY IS ITS DERIVATIVE. */
06994 
06995 /*               (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2, */
06996 
06997 /*         ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING */
06998 /*         PURPOSES IN AIRY FUNCTIONS FROM CAIRY OR CBIRY. */
06999 
07000 /*         MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND */
07001 /*         MUST BE SPECIFIED. IPMTR=0 RETURNS ALL PARAMETERS. IPMTR= */
07002 /*         1 COMPUTES ALL EXCEPT ASUM AND BSUM. */
07003 
07004 /* ***ROUTINES CALLED  ZABS,ZDIV,ZZZLOG,ZZZSQRT,D1MACH */
07005 /* ***END PROLOGUE  ZUNHJ */
07006 /*     COMPLEX ARG,ASUM,BSUM,CFNU,CONE,CR,CZERO,DR,P,PHI,PRZTH,PTFN, */
07007 /*    *RFN13,RTZTA,RZTH,SUMA,SUMB,TFN,T2,UP,W,W2,Z,ZA,ZB,ZC,ZETA,ZETA1, */
07008 /*    *ZETA2,ZTH */
07009 
07010     rfnu = 1. / *fnu;
07011 /* ----------------------------------------------------------------------- */
07012 /*     OVERFLOW TEST (Z/FNU TOO SMALL) */
07013 /* ----------------------------------------------------------------------- */
07014     test = d1mach_(&c__1) * 1e3;
07015     ac = *fnu * test;
07016     if (abs(*zr) > ac || abs(*zi) > ac) {
07017         goto L15;
07018     }
07019     *zeta1r = (d__1 = log(test), abs(d__1)) * 2. + *fnu;
07020     *zeta1i = 0.;
07021     *zeta2r = *fnu;
07022     *zeta2i = 0.;
07023     *phir = 1.;
07024     *phii = 0.;
07025     *argr = 1.;
07026     *argi = 0.;
07027     return 0;
07028 L15:
07029     zbr = *zr * rfnu;
07030     zbi = *zi * rfnu;
07031     rfnu2 = rfnu * rfnu;
07032 /* ----------------------------------------------------------------------- */
07033 /*     COMPUTE IN THE FOURTH QUADRANT */
07034 /* ----------------------------------------------------------------------- */
07035     fn13 = pow(*fnu, ex1);
07036     fn23 = fn13 * fn13;
07037     rfn13 = 1. / fn13;
07038     w2r = coner - zbr * zbr + zbi * zbi;
07039     w2i = conei - zbr * zbi - zbr * zbi;
07040     aw2 = zabs_(&w2r, &w2i);
07041     if (aw2 > .25) {
07042         goto L130;
07043     }
07044 /* ----------------------------------------------------------------------- */
07045 /*     POWER SERIES FOR CABS(W2).LE.0.25D0 */
07046 /* ----------------------------------------------------------------------- */
07047     k = 1;
07048     pr[0] = coner;
07049     pi[0] = conei;
07050     sumar = gama[0];
07051     sumai = zeroi;
07052     ap[0] = 1.;
07053     if (aw2 < *tol) {
07054         goto L20;
07055     }
07056     for (k = 2; k <= 30; ++k) {
07057         pr[k - 1] = pr[k - 2] * w2r - pi[k - 2] * w2i;
07058         pi[k - 1] = pr[k - 2] * w2i + pi[k - 2] * w2r;
07059         sumar += pr[k - 1] * gama[k - 1];
07060         sumai += pi[k - 1] * gama[k - 1];
07061         ap[k - 1] = ap[k - 2] * aw2;
07062         if (ap[k - 1] < *tol) {
07063             goto L20;
07064         }
07065 /* L10: */
07066     }
07067     k = 30;
07068 L20:
07069     kmax = k;
07070     zetar = w2r * sumar - w2i * sumai;
07071     zetai = w2r * sumai + w2i * sumar;
07072     *argr = zetar * fn23;
07073     *argi = zetai * fn23;
07074     zzzsqrt_(&sumar, &sumai, &zar, &zai);
07075     zzzsqrt_(&w2r, &w2i, &str, &sti);
07076     *zeta2r = str * *fnu;
07077     *zeta2i = sti * *fnu;
07078     str = coner + ex2 * (zetar * zar - zetai * zai);
07079     sti = conei + ex2 * (zetar * zai + zetai * zar);
07080     *zeta1r = str * *zeta2r - sti * *zeta2i;
07081     *zeta1i = str * *zeta2i + sti * *zeta2r;
07082     zar += zar;
07083     zai += zai;
07084     zzzsqrt_(&zar, &zai, &str, &sti);
07085     *phir = str * rfn13;
07086     *phii = sti * rfn13;
07087     if (*ipmtr == 1) {
07088         goto L120;
07089     }
07090 /* ----------------------------------------------------------------------- */
07091 /*     SUM SERIES FOR ASUM AND BSUM */
07092 /* ----------------------------------------------------------------------- */
07093     sumbr = zeror;
07094     sumbi = zeroi;
07095     i__1 = kmax;
07096     for (k = 1; k <= i__1; ++k) {
07097         sumbr += pr[k - 1] * beta[k - 1];
07098         sumbi += pi[k - 1] * beta[k - 1];
07099 /* L30: */
07100     }
07101     *asumr = zeror;
07102     *asumi = zeroi;
07103     *bsumr = sumbr;
07104     *bsumi = sumbi;
07105     l1 = 0;
07106     l2 = 30;
07107     btol = *tol * (abs(*bsumr) + abs(*bsumi));
07108     atol = *tol;
07109     pp = 1.;
07110     ias = 0;
07111     ibs = 0;
07112     if (rfnu2 < *tol) {
07113         goto L110;
07114     }
07115     for (is = 2; is <= 7; ++is) {
07116         atol /= rfnu2;
07117         pp *= rfnu2;
07118         if (ias == 1) {
07119             goto L60;
07120         }
07121         sumar = zeror;
07122         sumai = zeroi;
07123         i__1 = kmax;
07124         for (k = 1; k <= i__1; ++k) {
07125             m = l1 + k;
07126             sumar += pr[k - 1] * alfa[m - 1];
07127             sumai += pi[k - 1] * alfa[m - 1];
07128             if (ap[k - 1] < atol) {
07129                 goto L50;
07130             }
07131 /* L40: */
07132         }
07133 L50:
07134         *asumr += sumar * pp;
07135         *asumi += sumai * pp;
07136         if (pp < *tol) {
07137             ias = 1;
07138         }
07139 L60:
07140         if (ibs == 1) {
07141             goto L90;
07142         }
07143         sumbr = zeror;
07144         sumbi = zeroi;
07145         i__1 = kmax;
07146         for (k = 1; k <= i__1; ++k) {
07147             m = l2 + k;
07148             sumbr += pr[k - 1] * beta[m - 1];
07149             sumbi += pi[k - 1] * beta[m - 1];
07150             if (ap[k - 1] < atol) {
07151                 goto L80;
07152             }
07153 /* L70: */
07154         }
07155 L80:
07156         *bsumr += sumbr * pp;
07157         *bsumi += sumbi * pp;
07158         if (pp < btol) {
07159             ibs = 1;
07160         }
07161 L90:
07162         if (ias == 1 && ibs == 1) {
07163             goto L110;
07164         }
07165         l1 += 30;
07166         l2 += 30;
07167 /* L100: */
07168     }
07169 L110:
07170     *asumr += coner;
07171     pp = rfnu * rfn13;
07172     *bsumr *= pp;
07173     *bsumi *= pp;
07174 L120:
07175     return 0;
07176 /* ----------------------------------------------------------------------- */
07177 /*     CABS(W2).GT.0.25D0 */
07178 /* ----------------------------------------------------------------------- */
07179 L130:
07180     zzzsqrt_(&w2r, &w2i, &wr, &wi);
07181     if (wr < 0.) {
07182         wr = 0.;
07183     }
07184     if (wi < 0.) {
07185         wi = 0.;
07186     }
07187     str = coner + wr;
07188     sti = wi;
07189     zdiv_(&str, &sti, &zbr, &zbi, &zar, &zai);
07190     zzzlog_(&zar, &zai, &zcr, &zci, &idum);
07191     if (zci < 0.) {
07192         zci = 0.;
07193     }
07194     if (zci > hpi) {
07195         zci = hpi;
07196     }
07197     if (zcr < 0.) {
07198         zcr = 0.;
07199     }
07200     zthr = (zcr - wr) * 1.5;
07201     zthi = (zci - wi) * 1.5;
07202     *zeta1r = zcr * *fnu;
07203     *zeta1i = zci * *fnu;
07204     *zeta2r = wr * *fnu;
07205     *zeta2i = wi * *fnu;
07206     azth = zabs_(&zthr, &zthi);
07207     ang = thpi;
07208     if (zthr >= 0. && zthi < 0.) {
07209         goto L140;
07210     }
07211     ang = hpi;
07212     if (zthr == 0.) {
07213         goto L140;
07214     }
07215     ang = atan(zthi / zthr);
07216     if (zthr < 0.) {
07217         ang += gpi;
07218     }
07219 L140:
07220     pp = pow(azth, ex2);
07221     ang *= ex2;
07222     zetar = pp * cos(ang);
07223     zetai = pp * sin(ang);
07224     if (zetai < 0.) {
07225         zetai = 0.;
07226     }
07227     *argr = zetar * fn23;
07228     *argi = zetai * fn23;
07229     zdiv_(&zthr, &zthi, &zetar, &zetai, &rtztr, &rtzti);
07230     zdiv_(&rtztr, &rtzti, &wr, &wi, &zar, &zai);
07231     tzar = zar + zar;
07232     tzai = zai + zai;
07233     zzzsqrt_(&tzar, &tzai, &str, &sti);
07234     *phir = str * rfn13;
07235     *phii = sti * rfn13;
07236     if (*ipmtr == 1) {
07237         goto L120;
07238     }
07239     raw = 1. / sqrt(aw2);
07240     str = wr * raw;
07241     sti = -wi * raw;
07242     tfnr = str * rfnu * raw;
07243     tfni = sti * rfnu * raw;
07244     razth = 1. / azth;
07245     str = zthr * razth;
07246     sti = -zthi * razth;
07247     rzthr = str * razth * rfnu;
07248     rzthi = sti * razth * rfnu;
07249     zcr = rzthr * ar[1];
07250     zci = rzthi * ar[1];
07251     raw2 = 1. / aw2;
07252     str = w2r * raw2;
07253     sti = -w2i * raw2;
07254     t2r = str * raw2;
07255     t2i = sti * raw2;
07256     str = t2r * c__[1] + c__[2];
07257     sti = t2i * c__[1];
07258     upr[1] = str * tfnr - sti * tfni;
07259     upi[1] = str * tfni + sti * tfnr;
07260     *bsumr = upr[1] + zcr;
07261     *bsumi = upi[1] + zci;
07262     *asumr = zeror;
07263     *asumi = zeroi;
07264     if (rfnu < *tol) {
07265         goto L220;
07266     }
07267     przthr = rzthr;
07268     przthi = rzthi;
07269     ptfnr = tfnr;
07270     ptfni = tfni;
07271     upr[0] = coner;
07272     upi[0] = conei;
07273     pp = 1.;
07274     btol = *tol * (abs(*bsumr) + abs(*bsumi));
07275     ks = 0;
07276     kp1 = 2;
07277     l = 3;
07278     ias = 0;
07279     ibs = 0;
07280     for (lr = 2; lr <= 12; lr += 2) {
07281         lrp1 = lr + 1;
07282 /* ----------------------------------------------------------------------- */
07283 /*     COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE TERMS IN */
07284 /*     NEXT SUMA AND SUMB */
07285 /* ----------------------------------------------------------------------- */
07286         i__1 = lrp1;
07287         for (k = lr; k <= i__1; ++k) {
07288             ++ks;
07289             ++kp1;
07290             ++l;
07291             zar = c__[l - 1];
07292             zai = zeroi;
07293             i__2 = kp1;
07294             for (j = 2; j <= i__2; ++j) {
07295                 ++l;
07296                 str = zar * t2r - t2i * zai + c__[l - 1];
07297                 zai = zar * t2i + zai * t2r;
07298                 zar = str;
07299 /* L150: */
07300             }
07301             str = ptfnr * tfnr - ptfni * tfni;
07302             ptfni = ptfnr * tfni + ptfni * tfnr;
07303             ptfnr = str;
07304             upr[kp1 - 1] = ptfnr * zar - ptfni * zai;
07305             upi[kp1 - 1] = ptfni * zar + ptfnr * zai;
07306             crr[ks - 1] = przthr * br[ks];
07307             cri[ks - 1] = przthi * br[ks];
07308             str = przthr * rzthr - przthi * rzthi;
07309             przthi = przthr * rzthi + przthi * rzthr;
07310             przthr = str;
07311             drr[ks - 1] = przthr * ar[ks + 1];
07312             dri[ks - 1] = przthi * ar[ks + 1];
07313 /* L160: */
07314         }
07315         pp *= rfnu2;
07316         if (ias == 1) {
07317             goto L180;
07318         }
07319         sumar = upr[lrp1 - 1];
07320         sumai = upi[lrp1 - 1];
07321         ju = lrp1;
07322         i__1 = lr;
07323         for (jr = 1; jr <= i__1; ++jr) {
07324             --ju;
07325             sumar = sumar + crr[jr - 1] * upr[ju - 1] - cri[jr - 1] * upi[ju 
07326                     - 1];
07327             sumai = sumai + crr[jr - 1] * upi[ju - 1] + cri[jr - 1] * upr[ju 
07328                     - 1];
07329 /* L170: */
07330         }
07331         *asumr += sumar;
07332         *asumi += sumai;
07333         test = abs(sumar) + abs(sumai);
07334         if (pp < *tol && test < *tol) {
07335             ias = 1;
07336         }
07337 L180:
07338         if (ibs == 1) {
07339             goto L200;
07340         }
07341         sumbr = upr[lr + 1] + upr[lrp1 - 1] * zcr - upi[lrp1 - 1] * zci;
07342         sumbi = upi[lr + 1] + upr[lrp1 - 1] * zci + upi[lrp1 - 1] * zcr;
07343         ju = lrp1;
07344         i__1 = lr;
07345         for (jr = 1; jr <= i__1; ++jr) {
07346             --ju;
07347             sumbr = sumbr + drr[jr - 1] * upr[ju - 1] - dri[jr - 1] * upi[ju 
07348                     - 1];
07349             sumbi = sumbi + drr[jr - 1] * upi[ju - 1] + dri[jr - 1] * upr[ju 
07350                     - 1];
07351 /* L190: */
07352         }
07353         *bsumr += sumbr;
07354         *bsumi += sumbi;
07355         test = abs(sumbr) + abs(sumbi);
07356         if (pp < btol && test < btol) {
07357             ibs = 1;
07358         }
07359 L200:
07360         if (ias == 1 && ibs == 1) {
07361             goto L220;
07362         }
07363 /* L210: */
07364     }
07365 L220:
07366     *asumr += coner;
07367     str = -(*bsumr) * rfn13;
07368     sti = -(*bsumi) * rfn13;
07369     zdiv_(&str, &sti, &rtztr, &rtzti, bsumr, bsumi);
07370     goto L120;
07371 } /* zunhj_ */
07372 
07373 /* Subroutine */ int zunk1_(doublereal *zr, doublereal *zi, doublereal *fnu, 
07374         integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *
07375         yi, integer *nz, doublereal *tol, doublereal *elim, doublereal *alim)
07376 {
07377     /* Initialized data */
07378 
07379     static doublereal zeror = 0.;
07380     static doublereal zeroi = 0.;
07381     static doublereal coner = 1.;
07382     static doublereal pi = 3.14159265358979324;
07383 
07384     /* System generated locals */
07385     integer i__1;
07386 
07387     /* Builtin functions */
07388     double log(doublereal), exp(doublereal), cos(doublereal), sin(doublereal),
07389              d_sign(doublereal *, doublereal *);
07390 
07391     /* Local variables */
07392     static integer i__, j, k, m, ib, ic;
07393     static doublereal fn;
07394     static integer il, kk, nw;
07395     static doublereal c1i, c2i, c2m, c1r, c2r, s1i, s2i, rs1, s1r, s2r, ang, 
07396             asc, cki, fnf;
07397     static integer ifn;
07398     static doublereal ckr;
07399     static integer iuf;
07400     static doublereal cyi[2], fmr, csr, sgn;
07401     static integer inu;
07402     static doublereal bry[3], cyr[2], sti, rzi, zri, str, rzr, zrr, aphi, 
07403             cscl, phii[2], crsc;
07404     extern doublereal zabs_(doublereal *, doublereal *);
07405     static doublereal phir[2];
07406     static integer init[2];
07407     static doublereal csrr[3], cssr[3], rast, sumi[2], razr;
07408     extern /* Subroutine */ int zs1s2_(doublereal *, doublereal *, doublereal 
07409             *, doublereal *, doublereal *, doublereal *, integer *, 
07410             doublereal *, doublereal *, integer *);
07411     static doublereal sumr[2];
07412     static integer iflag, kflag;
07413     static doublereal ascle;
07414     static integer kdflg;
07415     static doublereal phidi;
07416     static integer ipard;
07417     static doublereal csgni, phidr;
07418     static integer initd;
07419     static doublereal cspni, cwrki[48]  /* was [16][3] */, sumdi;
07420     extern /* Subroutine */ int zuchk_(doublereal *, doublereal *, integer *, 
07421             doublereal *, doublereal *);
07422     static doublereal cspnr, cwrkr[48]  /* was [16][3] */, sumdr;
07423     extern doublereal d1mach_(integer *);
07424     extern /* Subroutine */ int zunik_(doublereal *, doublereal *, doublereal 
07425             *, integer *, integer *, doublereal *, integer *, doublereal *, 
07426             doublereal *, doublereal *, doublereal *, doublereal *, 
07427             doublereal *, doublereal *, doublereal *, doublereal *, 
07428             doublereal *);
07429     static doublereal zeta1i[2], zeta2i[2], zet1di, zet2di, zeta1r[2], zeta2r[
07430             2], zet1dr, zet2dr;
07431 
07432 /* ***BEGIN PROLOGUE  ZUNK1 */
07433 /* ***REFER TO  ZBESK */
07434 
07435 /*     ZUNK1 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE */
07436 /*     RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE */
07437 /*     UNIFORM ASYMPTOTIC EXPANSION. */
07438 /*     MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. */
07439 /*     NZ=-1 MEANS AN OVERFLOW WILL OCCUR */
07440 
07441 /* ***ROUTINES CALLED  ZKSCL,ZS1S2,ZUCHK,ZUNIK,D1MACH,ZABS */
07442 /* ***END PROLOGUE  ZUNK1 */
07443 /*     COMPLEX CFN,CK,CONE,CRSC,CS,CSCL,CSGN,CSPN,CSR,CSS,CWRK,CY,CZERO, */
07444 /*    *C1,C2,PHI,PHID,RZ,SUM,SUMD,S1,S2,Y,Z,ZETA1,ZETA1D,ZETA2,ZETA2D,ZR */
07445     /* Parameter adjustments */
07446     --yi;
07447     --yr;
07448 
07449     /* Function Body */
07450 
07451     kdflg = 1;
07452     *nz = 0;
07453 /* ----------------------------------------------------------------------- */
07454 /*     EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN */
07455 /*     THE UNDERFLOW LIMIT */
07456 /* ----------------------------------------------------------------------- */
07457     cscl = 1. / *tol;
07458     crsc = *tol;
07459     cssr[0] = cscl;
07460     cssr[1] = coner;
07461     cssr[2] = crsc;
07462     csrr[0] = crsc;
07463     csrr[1] = coner;
07464     csrr[2] = cscl;
07465     bry[0] = d1mach_(&c__1) * 1e3 / *tol;
07466     bry[1] = 1. / bry[0];
07467     bry[2] = d1mach_(&c__2);
07468     zrr = *zr;
07469     zri = *zi;
07470     if (*zr >= 0.) {
07471         goto L10;
07472     }
07473     zrr = -(*zr);
07474     zri = -(*zi);
07475 L10:
07476     j = 2;
07477     i__1 = *n;
07478     for (i__ = 1; i__ <= i__1; ++i__) {
07479 /* ----------------------------------------------------------------------- */
07480 /*     J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J */
07481 /* ----------------------------------------------------------------------- */
07482         j = 3 - j;
07483         fn = *fnu + (doublereal) ((real) (i__ - 1));
07484         init[j - 1] = 0;
07485         zunik_(&zrr, &zri, &fn, &c__2, &c__0, tol, &init[j - 1], &phir[j - 1],
07486                  &phii[j - 1], &zeta1r[j - 1], &zeta1i[j - 1], &zeta2r[j - 1],
07487                  &zeta2i[j - 1], &sumr[j - 1], &sumi[j - 1], &cwrkr[(j << 4) 
07488                 - 16], &cwrki[(j << 4) - 16]);
07489         if (*kode == 1) {
07490             goto L20;
07491         }
07492         str = zrr + zeta2r[j - 1];
07493         sti = zri + zeta2i[j - 1];
07494         rast = fn / zabs_(&str, &sti);
07495         str = str * rast * rast;
07496         sti = -sti * rast * rast;
07497         s1r = zeta1r[j - 1] - str;
07498         s1i = zeta1i[j - 1] - sti;
07499         goto L30;
07500 L20:
07501         s1r = zeta1r[j - 1] - zeta2r[j - 1];
07502         s1i = zeta1i[j - 1] - zeta2i[j - 1];
07503 L30:
07504         rs1 = s1r;
07505 /* ----------------------------------------------------------------------- */
07506 /*     TEST FOR UNDERFLOW AND OVERFLOW */
07507 /* ----------------------------------------------------------------------- */
07508         if (abs(rs1) > *elim) {
07509             goto L60;
07510         }
07511         if (kdflg == 1) {
07512             kflag = 2;
07513         }
07514         if (abs(rs1) < *alim) {
07515             goto L40;
07516         }
07517 /* ----------------------------------------------------------------------- */
07518 /*     REFINE  TEST AND SCALE */
07519 /* ----------------------------------------------------------------------- */
07520         aphi = zabs_(&phir[j - 1], &phii[j - 1]);
07521         rs1 += log(aphi);
07522         if (abs(rs1) > *elim) {
07523             goto L60;
07524         }
07525         if (kdflg == 1) {
07526             kflag = 1;
07527         }
07528         if (rs1 < 0.) {
07529             goto L40;
07530         }
07531         if (kdflg == 1) {
07532             kflag = 3;
07533         }
07534 L40:
07535 /* ----------------------------------------------------------------------- */
07536 /*     SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR */
07537 /*     EXPONENT EXTREMES */
07538 /* ----------------------------------------------------------------------- */
07539         s2r = phir[j - 1] * sumr[j - 1] - phii[j - 1] * sumi[j - 1];
07540         s2i = phir[j - 1] * sumi[j - 1] + phii[j - 1] * sumr[j - 1];
07541         str = exp(s1r) * cssr[kflag - 1];
07542         s1r = str * cos(s1i);
07543         s1i = str * sin(s1i);
07544         str = s2r * s1r - s2i * s1i;
07545         s2i = s1r * s2i + s2r * s1i;
07546         s2r = str;
07547         if (kflag != 1) {
07548             goto L50;
07549         }
07550         zuchk_(&s2r, &s2i, &nw, bry, tol);
07551         if (nw != 0) {
07552             goto L60;
07553         }
07554 L50:
07555         cyr[kdflg - 1] = s2r;
07556         cyi[kdflg - 1] = s2i;
07557         yr[i__] = s2r * csrr[kflag - 1];
07558         yi[i__] = s2i * csrr[kflag - 1];
07559         if (kdflg == 2) {
07560             goto L75;
07561         }
07562         kdflg = 2;
07563         goto L70;
07564 L60:
07565         if (rs1 > 0.) {
07566             goto L300;
07567         }
07568 /* ----------------------------------------------------------------------- */
07569 /*     FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW */
07570 /* ----------------------------------------------------------------------- */
07571         if (*zr < 0.) {
07572             goto L300;
07573         }
07574         kdflg = 1;
07575         yr[i__] = zeror;
07576         yi[i__] = zeroi;
07577         ++(*nz);
07578         if (i__ == 1) {
07579             goto L70;
07580         }
07581         if (yr[i__ - 1] == zeror && yi[i__ - 1] == zeroi) {
07582             goto L70;
07583         }
07584         yr[i__ - 1] = zeror;
07585         yi[i__ - 1] = zeroi;
07586         ++(*nz);
07587 L70:
07588         ;
07589     }
07590     i__ = *n;
07591 L75:
07592     razr = 1. / zabs_(&zrr, &zri);
07593     str = zrr * razr;
07594     sti = -zri * razr;
07595     rzr = (str + str) * razr;
07596     rzi = (sti + sti) * razr;
07597     ckr = fn * rzr;
07598     cki = fn * rzi;
07599     ib = i__ + 1;
07600     if (*n < ib) {
07601         goto L160;
07602     }
07603 /* ----------------------------------------------------------------------- */
07604 /*     TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO */
07605 /*     ON UNDERFLOW. */
07606 /* ----------------------------------------------------------------------- */
07607     fn = *fnu + (doublereal) ((real) (*n - 1));
07608     ipard = 1;
07609     if (*mr != 0) {
07610         ipard = 0;
07611     }
07612     initd = 0;
07613     zunik_(&zrr, &zri, &fn, &c__2, &ipard, tol, &initd, &phidr, &phidi, &
07614             zet1dr, &zet1di, &zet2dr, &zet2di, &sumdr, &sumdi, &cwrkr[32], &
07615             cwrki[32]);
07616     if (*kode == 1) {
07617         goto L80;
07618     }
07619     str = zrr + zet2dr;
07620     sti = zri + zet2di;
07621     rast = fn / zabs_(&str, &sti);
07622     str = str * rast * rast;
07623     sti = -sti * rast * rast;
07624     s1r = zet1dr - str;
07625     s1i = zet1di - sti;
07626     goto L90;
07627 L80:
07628     s1r = zet1dr - zet2dr;
07629     s1i = zet1di - zet2di;
07630 L90:
07631     rs1 = s1r;
07632     if (abs(rs1) > *elim) {
07633         goto L95;
07634     }
07635     if (abs(rs1) < *alim) {
07636         goto L100;
07637     }
07638 /* ---------------------------------------------------------------------------- */
07639 /*     REFINE ESTIMATE AND TEST */
07640 /* ------------------------------------------------------------------------- */
07641     aphi = zabs_(&phidr, &phidi);
07642     rs1 += log(aphi);
07643     if (abs(rs1) < *elim) {
07644         goto L100;
07645     }
07646 L95:
07647     if (abs(rs1) > 0.) {
07648         goto L300;
07649     }
07650 /* ----------------------------------------------------------------------- */
07651 /*     FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW */
07652 /* ----------------------------------------------------------------------- */
07653     if (*zr < 0.) {
07654         goto L300;
07655     }
07656     *nz = *n;
07657     i__1 = *n;
07658     for (i__ = 1; i__ <= i__1; ++i__) {
07659         yr[i__] = zeror;
07660         yi[i__] = zeroi;
07661 /* L96: */
07662     }
07663     return 0;
07664 /* --------------------------------------------------------------------------- */
07665 /*     FORWARD RECUR FOR REMAINDER OF THE SEQUENCE */
07666 /* ---------------------------------------------------------------------------- */
07667 L100:
07668     s1r = cyr[0];
07669     s1i = cyi[0];
07670     s2r = cyr[1];
07671     s2i = cyi[1];
07672     c1r = csrr[kflag - 1];
07673     ascle = bry[kflag - 1];
07674     i__1 = *n;
07675     for (i__ = ib; i__ <= i__1; ++i__) {
07676         c2r = s2r;
07677         c2i = s2i;
07678         s2r = ckr * c2r - cki * c2i + s1r;
07679         s2i = ckr * c2i + cki * c2r + s1i;
07680         s1r = c2r;
07681         s1i = c2i;
07682         ckr += rzr;
07683         cki += rzi;
07684         c2r = s2r * c1r;
07685         c2i = s2i * c1r;
07686         yr[i__] = c2r;
07687         yi[i__] = c2i;
07688         if (kflag >= 3) {
07689             goto L120;
07690         }
07691         str = abs(c2r);
07692         sti = abs(c2i);
07693         c2m = max(str,sti);
07694         if (c2m <= ascle) {
07695             goto L120;
07696         }
07697         ++kflag;
07698         ascle = bry[kflag - 1];
07699         s1r *= c1r;
07700         s1i *= c1r;
07701         s2r = c2r;
07702         s2i = c2i;
07703         s1r *= cssr[kflag - 1];
07704         s1i *= cssr[kflag - 1];
07705         s2r *= cssr[kflag - 1];
07706         s2i *= cssr[kflag - 1];
07707         c1r = csrr[kflag - 1];
07708 L120:
07709         ;
07710     }
07711 L160:
07712     if (*mr == 0) {
07713         return 0;
07714     }
07715 /* ----------------------------------------------------------------------- */
07716 /*     ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0 */
07717 /* ----------------------------------------------------------------------- */
07718     *nz = 0;
07719     fmr = (doublereal) ((real) (*mr));
07720     sgn = -DSIGN(pi, fmr);
07721 /* ----------------------------------------------------------------------- */
07722 /*     CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. */
07723 /* ----------------------------------------------------------------------- */
07724     csgni = sgn;
07725     inu = (integer) ((real) (*fnu));
07726     fnf = *fnu - (doublereal) ((real) inu);
07727     ifn = inu + *n - 1;
07728     ang = fnf * sgn;
07729     cspnr = cos(ang);
07730     cspni = sin(ang);
07731     if (ifn % 2 == 0) {
07732         goto L170;
07733     }
07734     cspnr = -cspnr;
07735     cspni = -cspni;
07736 L170:
07737     asc = bry[0];
07738     iuf = 0;
07739     kk = *n;
07740     kdflg = 1;
07741     --ib;
07742     ic = ib - 1;
07743     i__1 = *n;
07744     for (k = 1; k <= i__1; ++k) {
07745         fn = *fnu + (doublereal) ((real) (kk - 1));
07746 /* ----------------------------------------------------------------------- */
07747 /*     LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K */
07748 /*     FUNCTION ABOVE */
07749 /* ----------------------------------------------------------------------- */
07750         m = 3;
07751         if (*n > 2) {
07752             goto L175;
07753         }
07754 L172:
07755         initd = init[j - 1];
07756         phidr = phir[j - 1];
07757         phidi = phii[j - 1];
07758         zet1dr = zeta1r[j - 1];
07759         zet1di = zeta1i[j - 1];
07760         zet2dr = zeta2r[j - 1];
07761         zet2di = zeta2i[j - 1];
07762         sumdr = sumr[j - 1];
07763         sumdi = sumi[j - 1];
07764         m = j;
07765         j = 3 - j;
07766         goto L180;
07767 L175:
07768         if (kk == *n && ib < *n) {
07769             goto L180;
07770         }
07771         if (kk == ib || kk == ic) {
07772             goto L172;
07773         }
07774         initd = 0;
07775 L180:
07776         zunik_(&zrr, &zri, &fn, &c__1, &c__0, tol, &initd, &phidr, &phidi, &
07777                 zet1dr, &zet1di, &zet2dr, &zet2di, &sumdr, &sumdi, &cwrkr[(m 
07778                 << 4) - 16], &cwrki[(m << 4) - 16]);
07779         if (*kode == 1) {
07780             goto L200;
07781         }
07782         str = zrr + zet2dr;
07783         sti = zri + zet2di;
07784         rast = fn / zabs_(&str, &sti);
07785         str = str * rast * rast;
07786         sti = -sti * rast * rast;
07787         s1r = -zet1dr + str;
07788         s1i = -zet1di + sti;
07789         goto L210;
07790 L200:
07791         s1r = -zet1dr + zet2dr;
07792         s1i = -zet1di + zet2di;
07793 L210:
07794 /* ----------------------------------------------------------------------- */
07795 /*     TEST FOR UNDERFLOW AND OVERFLOW */
07796 /* ----------------------------------------------------------------------- */
07797         rs1 = s1r;
07798         if (abs(rs1) > *elim) {
07799             goto L260;
07800         }
07801         if (kdflg == 1) {
07802             iflag = 2;
07803         }
07804         if (abs(rs1) < *alim) {
07805             goto L220;
07806         }
07807 /* ----------------------------------------------------------------------- */
07808 /*     REFINE  TEST AND SCALE */
07809 /* ----------------------------------------------------------------------- */
07810         aphi = zabs_(&phidr, &phidi);
07811         rs1 += log(aphi);
07812         if (abs(rs1) > *elim) {
07813             goto L260;
07814         }
07815         if (kdflg == 1) {
07816             iflag = 1;
07817         }
07818         if (rs1 < 0.) {
07819             goto L220;
07820         }
07821         if (kdflg == 1) {
07822             iflag = 3;
07823         }
07824 L220:
07825         str = phidr * sumdr - phidi * sumdi;
07826         sti = phidr * sumdi + phidi * sumdr;
07827         s2r = -csgni * sti;
07828         s2i = csgni * str;
07829         str = exp(s1r) * cssr[iflag - 1];
07830         s1r = str * cos(s1i);
07831         s1i = str * sin(s1i);
07832         str = s2r * s1r - s2i * s1i;
07833         s2i = s2r * s1i + s2i * s1r;
07834         s2r = str;
07835         if (iflag != 1) {
07836             goto L230;
07837         }
07838         zuchk_(&s2r, &s2i, &nw, bry, tol);
07839         if (nw == 0) {
07840             goto L230;
07841         }
07842         s2r = zeror;
07843         s2i = zeroi;
07844 L230:
07845         cyr[kdflg - 1] = s2r;
07846         cyi[kdflg - 1] = s2i;
07847         c2r = s2r;
07848         c2i = s2i;
07849         s2r *= csrr[iflag - 1];
07850         s2i *= csrr[iflag - 1];
07851 /* ----------------------------------------------------------------------- */
07852 /*     ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N */
07853 /* ----------------------------------------------------------------------- */
07854         s1r = yr[kk];
07855         s1i = yi[kk];
07856         if (*kode == 1) {
07857             goto L250;
07858         }
07859         zs1s2_(&zrr, &zri, &s1r, &s1i, &s2r, &s2i, &nw, &asc, alim, &iuf);
07860         *nz += nw;
07861 L250:
07862         yr[kk] = s1r * cspnr - s1i * cspni + s2r;
07863         yi[kk] = cspnr * s1i + cspni * s1r + s2i;
07864         --kk;
07865         cspnr = -cspnr;
07866         cspni = -cspni;
07867         if (c2r != 0. || c2i != 0.) {
07868             goto L255;
07869         }
07870         kdflg = 1;
07871         goto L270;
07872 L255:
07873         if (kdflg == 2) {
07874             goto L275;
07875         }
07876         kdflg = 2;
07877         goto L270;
07878 L260:
07879         if (rs1 > 0.) {
07880             goto L300;
07881         }
07882         s2r = zeror;
07883         s2i = zeroi;
07884         goto L230;
07885 L270:
07886         ;
07887     }
07888     k = *n;
07889 L275:
07890     il = *n - k;
07891     if (il == 0) {
07892         return 0;
07893     }
07894 /* ----------------------------------------------------------------------- */
07895 /*     RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE */
07896 /*     K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP */
07897 /*     INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. */
07898 /* ----------------------------------------------------------------------- */
07899     s1r = cyr[0];
07900     s1i = cyi[0];
07901     s2r = cyr[1];
07902     s2i = cyi[1];
07903     csr = csrr[iflag - 1];
07904     ascle = bry[iflag - 1];
07905     fn = (doublereal) ((real) (inu + il));
07906     i__1 = il;
07907     for (i__ = 1; i__ <= i__1; ++i__) {
07908         c2r = s2r;
07909         c2i = s2i;
07910         s2r = s1r + (fn + fnf) * (rzr * c2r - rzi * c2i);
07911         s2i = s1i + (fn + fnf) * (rzr * c2i + rzi * c2r);
07912         s1r = c2r;
07913         s1i = c2i;
07914         fn += -1.;
07915         c2r = s2r * csr;
07916         c2i = s2i * csr;
07917         ckr = c2r;
07918         cki = c2i;
07919         c1r = yr[kk];
07920         c1i = yi[kk];
07921         if (*kode == 1) {
07922             goto L280;
07923         }
07924         zs1s2_(&zrr, &zri, &c1r, &c1i, &c2r, &c2i, &nw, &asc, alim, &iuf);
07925         *nz += nw;
07926 L280:
07927         yr[kk] = c1r * cspnr - c1i * cspni + c2r;
07928         yi[kk] = c1r * cspni + c1i * cspnr + c2i;
07929         --kk;
07930         cspnr = -cspnr;
07931         cspni = -cspni;
07932         if (iflag >= 3) {
07933             goto L290;
07934         }
07935         c2r = abs(ckr);
07936         c2i = abs(cki);
07937         c2m = max(c2r,c2i);
07938         if (c2m <= ascle) {
07939             goto L290;
07940         }
07941         ++iflag;
07942         ascle = bry[iflag - 1];
07943         s1r *= csr;
07944         s1i *= csr;
07945         s2r = ckr;
07946         s2i = cki;
07947         s1r *= cssr[iflag - 1];
07948         s1i *= cssr[iflag - 1];
07949         s2r *= cssr[iflag - 1];
07950         s2i *= cssr[iflag - 1];
07951         csr = csrr[iflag - 1];
07952 L290:
07953         ;
07954     }
07955     return 0;
07956 L300:
07957     *nz = -1;
07958     return 0;
07959 } /* zunk1_ */
07960 
07961 /* Subroutine */ int zunk2_(doublereal *zr, doublereal *zi, doublereal *fnu, 
07962         integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *
07963         yi, integer *nz, doublereal *tol, doublereal *elim, doublereal *alim)
07964 {
07965     /* Initialized data */
07966 
07967     static doublereal zeror = 0.;
07968     static doublereal zeroi = 0.;
07969     static doublereal coner = 1.;
07970     static doublereal cr1r = 1.;
07971     static doublereal cr1i = 1.73205080756887729;
07972     static doublereal cr2r = -.5;
07973     static doublereal cr2i = -.866025403784438647;
07974     static doublereal hpi = 1.57079632679489662;
07975     static doublereal pi = 3.14159265358979324;
07976     static doublereal aic = 1.26551212348464539;
07977     static doublereal cipr[4] = { 1.,0.,-1.,0. };
07978     static doublereal cipi[4] = { 0.,-1.,0.,1. };
07979 
07980     /* System generated locals */
07981     integer i__1;
07982 
07983     /* Builtin functions */
07984     double cos(doublereal), sin(doublereal), log(doublereal), exp(doublereal),
07985              d_sign(doublereal *, doublereal *);
07986 
07987     /* Local variables */
07988     static integer i__, j, k, ib, ic;
07989     static doublereal fn;
07990     static integer il, kk, in, nw;
07991     static doublereal yy, c1i, c2i, c2m, c1r, c2r, s1i, s2i, rs1, s1r, s2r, 
07992             aii, ang, asc, car, cki, fnf;
07993     static integer nai;
07994     static doublereal air;
07995     static integer ifn;
07996     static doublereal csi, ckr;
07997     static integer iuf;
07998     static doublereal cyi[2], fmr, sar, csr, sgn, zbi;
07999     static integer inu;
08000     static doublereal bry[3], cyr[2], pti, sti, zbr, zni, rzi, ptr, zri, str, 
08001             znr, rzr, zrr, daii, aarg;
08002     static integer ndai;
08003     static doublereal dair, aphi, argi[2], cscl, phii[2], crsc, argr[2];
08004     static integer idum;
08005     extern doublereal zabs_(doublereal *, doublereal *);
08006     static doublereal phir[2], csrr[3], cssr[3], rast, razr;
08007     extern /* Subroutine */ int zs1s2_(doublereal *, doublereal *, doublereal 
08008             *, doublereal *, doublereal *, doublereal *, integer *, 
08009             doublereal *, doublereal *, integer *);
08010     static integer iflag, kflag;
08011     static doublereal argdi, ascle;
08012     static integer kdflg;
08013     static doublereal phidi, argdr;
08014     static integer ipard;
08015     static doublereal csgni, phidr, cspni, asumi[2], bsumi[2];
08016     extern /* Subroutine */ int zuchk_(doublereal *, doublereal *, integer *, 
08017             doublereal *, doublereal *);
08018     static doublereal cspnr, asumr[2], bsumr[2];
08019     extern doublereal d1mach_(integer *);
08020     extern /* Subroutine */ int zunhj_(doublereal *, doublereal *, doublereal 
08021             *, integer *, doublereal *, doublereal *, doublereal *, 
08022             doublereal *, doublereal *, doublereal *, doublereal *, 
08023             doublereal *, doublereal *, doublereal *, doublereal *, 
08024             doublereal *, doublereal *), zairy_(doublereal *, doublereal *, 
08025             integer *, integer *, doublereal *, doublereal *, integer *, 
08026             integer *);
08027     static doublereal zeta1i[2], zeta2i[2], zet1di, zet2di, zeta1r[2], zeta2r[
08028             2], zet1dr, zet2dr, asumdi, bsumdi, asumdr, bsumdr;
08029 
08030 /* ***BEGIN PROLOGUE  ZUNK2 */
08031 /* ***REFER TO  ZBESK */
08032 
08033 /*     ZUNK2 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE */
08034 /*     RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE */
08035 /*     UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN) */
08036 /*     WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR */
08037 /*     -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z IF Z IS IN THE RIGHT */
08038 /*     HALF PLANE OR ZR=-Z IF Z IS IN THE LEFT HALF PLANE. MR INDIC- */
08039 /*     ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. */
08040 /*     NZ=-1 MEANS AN OVERFLOW WILL OCCUR */
08041 
08042 /* ***ROUTINES CALLED  ZAIRY,ZKSCL,ZS1S2,ZUCHK,ZUNHJ,D1MACH,ZABS */
08043 /* ***END PROLOGUE  ZUNK2 */
08044 /*     COMPLEX AI,ARG,ARGD,ASUM,ASUMD,BSUM,BSUMD,CFN,CI,CIP,CK,CONE,CRSC, */
08045 /*    *CR1,CR2,CS,CSCL,CSGN,CSPN,CSR,CSS,CY,CZERO,C1,C2,DAI,PHI,PHID,RZ, */
08046 /*    *S1,S2,Y,Z,ZB,ZETA1,ZETA1D,ZETA2,ZETA2D,ZN,ZR */
08047     /* Parameter adjustments */
08048     --yi;
08049     --yr;
08050 
08051     /* Function Body */
08052 
08053     kdflg = 1;
08054     *nz = 0;
08055 /* ----------------------------------------------------------------------- */
08056 /*     EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN */
08057 /*     THE UNDERFLOW LIMIT */
08058 /* ----------------------------------------------------------------------- */
08059     cscl = 1. / *tol;
08060     crsc = *tol;
08061     cssr[0] = cscl;
08062     cssr[1] = coner;
08063     cssr[2] = crsc;
08064     csrr[0] = crsc;
08065     csrr[1] = coner;
08066     csrr[2] = cscl;
08067     bry[0] = d1mach_(&c__1) * 1e3 / *tol;
08068     bry[1] = 1. / bry[0];
08069     bry[2] = d1mach_(&c__2);
08070     zrr = *zr;
08071     zri = *zi;
08072     if (*zr >= 0.) {
08073         goto L10;
08074     }
08075     zrr = -(*zr);
08076     zri = -(*zi);
08077 L10:
08078     yy = zri;
08079     znr = zri;
08080     zni = -zrr;
08081     zbr = zrr;
08082     zbi = zri;
08083     inu = (integer) ((real) (*fnu));
08084     fnf = *fnu - (doublereal) ((real) inu);
08085     ang = -hpi * fnf;
08086     car = cos(ang);
08087     sar = sin(ang);
08088     c2r = hpi * sar;
08089     c2i = -hpi * car;
08090     kk = inu % 4 + 1;
08091     str = c2r * cipr[kk - 1] - c2i * cipi[kk - 1];
08092     sti = c2r * cipi[kk - 1] + c2i * cipr[kk - 1];
08093     csr = cr1r * str - cr1i * sti;
08094     csi = cr1r * sti + cr1i * str;
08095     if (yy > 0.) {
08096         goto L20;
08097     }
08098     znr = -znr;
08099     zbi = -zbi;
08100 L20:
08101 /* ----------------------------------------------------------------------- */
08102 /*     K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST */
08103 /*     QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY */
08104 /*     CONJUGATION SINCE THE K FUNCTION IS REAL ON THE POSITIVE REAL AXIS */
08105 /* ----------------------------------------------------------------------- */
08106     j = 2;
08107     i__1 = *n;
08108     for (i__ = 1; i__ <= i__1; ++i__) {
08109 /* ----------------------------------------------------------------------- */
08110 /*     J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J */
08111 /* ----------------------------------------------------------------------- */
08112         j = 3 - j;
08113         fn = *fnu + (doublereal) ((real) (i__ - 1));
08114         zunhj_(&znr, &zni, &fn, &c__0, tol, &phir[j - 1], &phii[j - 1], &argr[
08115                 j - 1], &argi[j - 1], &zeta1r[j - 1], &zeta1i[j - 1], &zeta2r[
08116                 j - 1], &zeta2i[j - 1], &asumr[j - 1], &asumi[j - 1], &bsumr[
08117                 j - 1], &bsumi[j - 1]);
08118         if (*kode == 1) {
08119             goto L30;
08120         }
08121         str = zbr + zeta2r[j - 1];
08122         sti = zbi + zeta2i[j - 1];
08123         rast = fn / zabs_(&str, &sti);
08124         str = str * rast * rast;
08125         sti = -sti * rast * rast;
08126         s1r = zeta1r[j - 1] - str;
08127         s1i = zeta1i[j - 1] - sti;
08128         goto L40;
08129 L30:
08130         s1r = zeta1r[j - 1] - zeta2r[j - 1];
08131         s1i = zeta1i[j - 1] - zeta2i[j - 1];
08132 L40:
08133 /* ----------------------------------------------------------------------- */
08134 /*     TEST FOR UNDERFLOW AND OVERFLOW */
08135 /* ----------------------------------------------------------------------- */
08136         rs1 = s1r;
08137         if (abs(rs1) > *elim) {
08138             goto L70;
08139         }
08140         if (kdflg == 1) {
08141             kflag = 2;
08142         }
08143         if (abs(rs1) < *alim) {
08144             goto L50;
08145         }
08146 /* ----------------------------------------------------------------------- */
08147 /*     REFINE  TEST AND SCALE */
08148 /* ----------------------------------------------------------------------- */
08149         aphi = zabs_(&phir[j - 1], &phii[j - 1]);
08150         aarg = zabs_(&argr[j - 1], &argi[j - 1]);
08151         rs1 = rs1 + log(aphi) - log(aarg) * .25 - aic;
08152         if (abs(rs1) > *elim) {
08153             goto L70;
08154         }
08155         if (kdflg == 1) {
08156             kflag = 1;
08157         }
08158         if (rs1 < 0.) {
08159             goto L50;
08160         }
08161         if (kdflg == 1) {
08162             kflag = 3;
08163         }
08164 L50:
08165 /* ----------------------------------------------------------------------- */
08166 /*     SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR */
08167 /*     EXPONENT EXTREMES */
08168 /* ----------------------------------------------------------------------- */
08169         c2r = argr[j - 1] * cr2r - argi[j - 1] * cr2i;
08170         c2i = argr[j - 1] * cr2i + argi[j - 1] * cr2r;
08171         zairy_(&c2r, &c2i, &c__0, &c__2, &air, &aii, &nai, &idum);
08172         zairy_(&c2r, &c2i, &c__1, &c__2, &dair, &daii, &ndai, &idum);
08173         str = dair * bsumr[j - 1] - daii * bsumi[j - 1];
08174         sti = dair * bsumi[j - 1] + daii * bsumr[j - 1];
08175         ptr = str * cr2r - sti * cr2i;
08176         pti = str * cr2i + sti * cr2r;
08177         str = ptr + (air * asumr[j - 1] - aii * asumi[j - 1]);
08178         sti = pti + (air * asumi[j - 1] + aii * asumr[j - 1]);
08179         ptr = str * phir[j - 1] - sti * phii[j - 1];
08180         pti = str * phii[j - 1] + sti * phir[j - 1];
08181         s2r = ptr * csr - pti * csi;
08182         s2i = ptr * csi + pti * csr;
08183         str = exp(s1r) * cssr[kflag - 1];
08184         s1r = str * cos(s1i);
08185         s1i = str * sin(s1i);
08186         str = s2r * s1r - s2i * s1i;
08187         s2i = s1r * s2i + s2r * s1i;
08188         s2r = str;
08189         if (kflag != 1) {
08190             goto L60;
08191         }
08192         zuchk_(&s2r, &s2i, &nw, bry, tol);
08193         if (nw != 0) {
08194             goto L70;
08195         }
08196 L60:
08197         if (yy <= 0.) {
08198             s2i = -s2i;
08199         }
08200         cyr[kdflg - 1] = s2r;
08201         cyi[kdflg - 1] = s2i;
08202         yr[i__] = s2r * csrr[kflag - 1];
08203         yi[i__] = s2i * csrr[kflag - 1];
08204         str = csi;
08205         csi = -csr;
08206         csr = str;
08207         if (kdflg == 2) {
08208             goto L85;
08209         }
08210         kdflg = 2;
08211         goto L80;
08212 L70:
08213         if (rs1 > 0.) {
08214             goto L320;
08215         }
08216 /* ----------------------------------------------------------------------- */
08217 /*     FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW */
08218 /* ----------------------------------------------------------------------- */
08219         if (*zr < 0.) {
08220             goto L320;
08221         }
08222         kdflg = 1;
08223         yr[i__] = zeror;
08224         yi[i__] = zeroi;
08225         ++(*nz);
08226         str = csi;
08227         csi = -csr;
08228         csr = str;
08229         if (i__ == 1) {
08230             goto L80;
08231         }
08232         if (yr[i__ - 1] == zeror && yi[i__ - 1] == zeroi) {
08233             goto L80;
08234         }
08235         yr[i__ - 1] = zeror;
08236         yi[i__ - 1] = zeroi;
08237         ++(*nz);
08238 L80:
08239         ;
08240     }
08241     i__ = *n;
08242 L85:
08243     razr = 1. / zabs_(&zrr, &zri);
08244     str = zrr * razr;
08245     sti = -zri * razr;
08246     rzr = (str + str) * razr;
08247     rzi = (sti + sti) * razr;
08248     ckr = fn * rzr;
08249     cki = fn * rzi;
08250     ib = i__ + 1;
08251     if (*n < ib) {
08252         goto L180;
08253     }
08254 /* ----------------------------------------------------------------------- */
08255 /*     TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO */
08256 /*     ON UNDERFLOW. */
08257 /* ----------------------------------------------------------------------- */
08258     fn = *fnu + (doublereal) ((real) (*n - 1));
08259     ipard = 1;
08260     if (*mr != 0) {
08261         ipard = 0;
08262     }
08263     zunhj_(&znr, &zni, &fn, &ipard, tol, &phidr, &phidi, &argdr, &argdi, &
08264             zet1dr, &zet1di, &zet2dr, &zet2di, &asumdr, &asumdi, &bsumdr, &
08265             bsumdi);
08266     if (*kode == 1) {
08267         goto L90;
08268     }
08269     str = zbr + zet2dr;
08270     sti = zbi + zet2di;
08271     rast = fn / zabs_(&str, &sti);
08272     str = str * rast * rast;
08273     sti = -sti * rast * rast;
08274     s1r = zet1dr - str;
08275     s1i = zet1di - sti;
08276     goto L100;
08277 L90:
08278     s1r = zet1dr - zet2dr;
08279     s1i = zet1di - zet2di;
08280 L100:
08281     rs1 = s1r;
08282     if (abs(rs1) > *elim) {
08283         goto L105;
08284     }
08285     if (abs(rs1) < *alim) {
08286         goto L120;
08287     }
08288 /* ---------------------------------------------------------------------------- */
08289 /*     REFINE ESTIMATE AND TEST */
08290 /* ------------------------------------------------------------------------- */
08291     aphi = zabs_(&phidr, &phidi);
08292     rs1 += log(aphi);
08293     if (abs(rs1) < *elim) {
08294         goto L120;
08295     }
08296 L105:
08297     if (rs1 > 0.) {
08298         goto L320;
08299     }
08300 /* ----------------------------------------------------------------------- */
08301 /*     FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW */
08302 /* ----------------------------------------------------------------------- */
08303     if (*zr < 0.) {
08304         goto L320;
08305     }
08306     *nz = *n;
08307     i__1 = *n;
08308     for (i__ = 1; i__ <= i__1; ++i__) {
08309         yr[i__] = zeror;
08310         yi[i__] = zeroi;
08311 /* L106: */
08312     }
08313     return 0;
08314 L120:
08315     s1r = cyr[0];
08316     s1i = cyi[0];
08317     s2r = cyr[1];
08318     s2i = cyi[1];
08319     c1r = csrr[kflag - 1];
08320     ascle = bry[kflag - 1];
08321     i__1 = *n;
08322     for (i__ = ib; i__ <= i__1; ++i__) {
08323         c2r = s2r;
08324         c2i = s2i;
08325         s2r = ckr * c2r - cki * c2i + s1r;
08326         s2i = ckr * c2i + cki * c2r + s1i;
08327         s1r = c2r;
08328         s1i = c2i;
08329         ckr += rzr;
08330         cki += rzi;
08331         c2r = s2r * c1r;
08332         c2i = s2i * c1r;
08333         yr[i__] = c2r;
08334         yi[i__] = c2i;
08335         if (kflag >= 3) {
08336             goto L130;
08337         }
08338         str = abs(c2r);
08339         sti = abs(c2i);
08340         c2m = max(str,sti);
08341         if (c2m <= ascle) {
08342             goto L130;
08343         }
08344         ++kflag;
08345         ascle = bry[kflag - 1];
08346         s1r *= c1r;
08347         s1i *= c1r;
08348         s2r = c2r;
08349         s2i = c2i;
08350         s1r *= cssr[kflag - 1];
08351         s1i *= cssr[kflag - 1];
08352         s2r *= cssr[kflag - 1];
08353         s2i *= cssr[kflag - 1];
08354         c1r = csrr[kflag - 1];
08355 L130:
08356         ;
08357     }
08358 L180:
08359     if (*mr == 0) {
08360         return 0;
08361     }
08362 /* ----------------------------------------------------------------------- */
08363 /*     ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0 */
08364 /* ----------------------------------------------------------------------- */
08365     *nz = 0;
08366     fmr = (doublereal) ((real) (*mr));
08367     sgn = -DSIGN(pi, fmr);
08368 /* ----------------------------------------------------------------------- */
08369 /*     CSPN AND CSGN ARE COEFF OF K AND I FUNCIONS RESP. */
08370 /* ----------------------------------------------------------------------- */
08371     csgni = sgn;
08372     if (yy <= 0.) {
08373         csgni = -csgni;
08374     }
08375     ifn = inu + *n - 1;
08376     ang = fnf * sgn;
08377     cspnr = cos(ang);
08378     cspni = sin(ang);
08379     if (ifn % 2 == 0) {
08380         goto L190;
08381     }
08382     cspnr = -cspnr;
08383     cspni = -cspni;
08384 L190:
08385 /* ----------------------------------------------------------------------- */
08386 /*     CS=COEFF OF THE J FUNCTION TO GET THE I FUNCTION. I(FNU,Z) IS */
08387 /*     COMPUTED FROM EXP(I*FNU*HPI)*J(FNU,-I*Z) WHERE Z IS IN THE FIRST */
08388 /*     QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY */
08389 /*     CONJUGATION SINCE THE I FUNCTION IS REAL ON THE POSITIVE REAL AXIS */
08390 /* ----------------------------------------------------------------------- */
08391     csr = sar * csgni;
08392     csi = car * csgni;
08393     in = ifn % 4 + 1;
08394     c2r = cipr[in - 1];
08395     c2i = cipi[in - 1];
08396     str = csr * c2r + csi * c2i;
08397     csi = -csr * c2i + csi * c2r;
08398     csr = str;
08399     asc = bry[0];
08400     iuf = 0;
08401     kk = *n;
08402     kdflg = 1;
08403     --ib;
08404     ic = ib - 1;
08405     i__1 = *n;
08406     for (k = 1; k <= i__1; ++k) {
08407         fn = *fnu + (doublereal) ((real) (kk - 1));
08408 /* ----------------------------------------------------------------------- */
08409 /*     LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K */
08410 /*     FUNCTION ABOVE */
08411 /* ----------------------------------------------------------------------- */
08412         if (*n > 2) {
08413             goto L175;
08414         }
08415 L172:
08416         phidr = phir[j - 1];
08417         phidi = phii[j - 1];
08418         argdr = argr[j - 1];
08419         argdi = argi[j - 1];
08420         zet1dr = zeta1r[j - 1];
08421         zet1di = zeta1i[j - 1];
08422         zet2dr = zeta2r[j - 1];
08423         zet2di = zeta2i[j - 1];
08424         asumdr = asumr[j - 1];
08425         asumdi = asumi[j - 1];
08426         bsumdr = bsumr[j - 1];
08427         bsumdi = bsumi[j - 1];
08428         j = 3 - j;
08429         goto L210;
08430 L175:
08431         if (kk == *n && ib < *n) {
08432             goto L210;
08433         }
08434         if (kk == ib || kk == ic) {
08435             goto L172;
08436         }
08437         zunhj_(&znr, &zni, &fn, &c__0, tol, &phidr, &phidi, &argdr, &argdi, &
08438                 zet1dr, &zet1di, &zet2dr, &zet2di, &asumdr, &asumdi, &bsumdr, 
08439                 &bsumdi);
08440 L210:
08441         if (*kode == 1) {
08442             goto L220;
08443         }
08444         str = zbr + zet2dr;
08445         sti = zbi + zet2di;
08446         rast = fn / zabs_(&str, &sti);
08447         str = str * rast * rast;
08448         sti = -sti * rast * rast;
08449         s1r = -zet1dr + str;
08450         s1i = -zet1di + sti;
08451         goto L230;
08452 L220:
08453         s1r = -zet1dr + zet2dr;
08454         s1i = -zet1di + zet2di;
08455 L230:
08456 /* ----------------------------------------------------------------------- */
08457 /*     TEST FOR UNDERFLOW AND OVERFLOW */
08458 /* ----------------------------------------------------------------------- */
08459         rs1 = s1r;
08460         if (abs(rs1) > *elim) {
08461             goto L280;
08462         }
08463         if (kdflg == 1) {
08464             iflag = 2;
08465         }
08466         if (abs(rs1) < *alim) {
08467             goto L240;
08468         }
08469 /* ----------------------------------------------------------------------- */
08470 /*     REFINE  TEST AND SCALE */
08471 /* ----------------------------------------------------------------------- */
08472         aphi = zabs_(&phidr, &phidi);
08473         aarg = zabs_(&argdr, &argdi);
08474         rs1 = rs1 + log(aphi) - log(aarg) * .25 - aic;
08475         if (abs(rs1) > *elim) {
08476             goto L280;
08477         }
08478         if (kdflg == 1) {
08479             iflag = 1;
08480         }
08481         if (rs1 < 0.) {
08482             goto L240;
08483         }
08484         if (kdflg == 1) {
08485             iflag = 3;
08486         }
08487 L240:
08488         zairy_(&argdr, &argdi, &c__0, &c__2, &air, &aii, &nai, &idum);
08489         zairy_(&argdr, &argdi, &c__1, &c__2, &dair, &daii, &ndai, &idum);
08490         str = dair * bsumdr - daii * bsumdi;
08491         sti = dair * bsumdi + daii * bsumdr;
08492         str += air * asumdr - aii * asumdi;
08493         sti += air * asumdi + aii * asumdr;
08494         ptr = str * phidr - sti * phidi;
08495         pti = str * phidi + sti * phidr;
08496         s2r = ptr * csr - pti * csi;
08497         s2i = ptr * csi + pti * csr;
08498         str = exp(s1r) * cssr[iflag - 1];
08499         s1r = str * cos(s1i);
08500         s1i = str * sin(s1i);
08501         str = s2r * s1r - s2i * s1i;
08502         s2i = s2r * s1i + s2i * s1r;
08503         s2r = str;
08504         if (iflag != 1) {
08505             goto L250;
08506         }
08507         zuchk_(&s2r, &s2i, &nw, bry, tol);
08508         if (nw == 0) {
08509             goto L250;
08510         }
08511         s2r = zeror;
08512         s2i = zeroi;
08513 L250:
08514         if (yy <= 0.) {
08515             s2i = -s2i;
08516         }
08517         cyr[kdflg - 1] = s2r;
08518         cyi[kdflg - 1] = s2i;
08519         c2r = s2r;
08520         c2i = s2i;
08521         s2r *= csrr[iflag - 1];
08522         s2i *= csrr[iflag - 1];
08523 /* ----------------------------------------------------------------------- */
08524 /*     ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N */
08525 /* ----------------------------------------------------------------------- */
08526         s1r = yr[kk];
08527         s1i = yi[kk];
08528         if (*kode == 1) {
08529             goto L270;
08530         }
08531         zs1s2_(&zrr, &zri, &s1r, &s1i, &s2r, &s2i, &nw, &asc, alim, &iuf);
08532         *nz += nw;
08533 L270:
08534         yr[kk] = s1r * cspnr - s1i * cspni + s2r;
08535         yi[kk] = s1r * cspni + s1i * cspnr + s2i;
08536         --kk;
08537         cspnr = -cspnr;
08538         cspni = -cspni;
08539         str = csi;
08540         csi = -csr;
08541         csr = str;
08542         if (c2r != 0. || c2i != 0.) {
08543             goto L255;
08544         }
08545         kdflg = 1;
08546         goto L290;
08547 L255:
08548         if (kdflg == 2) {
08549             goto L295;
08550         }
08551         kdflg = 2;
08552         goto L290;
08553 L280:
08554         if (rs1 > 0.) {
08555             goto L320;
08556         }
08557         s2r = zeror;
08558         s2i = zeroi;
08559         goto L250;
08560 L290:
08561         ;
08562     }
08563     k = *n;
08564 L295:
08565     il = *n - k;
08566     if (il == 0) {
08567         return 0;
08568     }
08569 /* ----------------------------------------------------------------------- */
08570 /*     RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE */
08571 /*     K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP */
08572 /*     INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. */
08573 /* ----------------------------------------------------------------------- */
08574     s1r = cyr[0];
08575     s1i = cyi[0];
08576     s2r = cyr[1];
08577     s2i = cyi[1];
08578     csr = csrr[iflag - 1];
08579     ascle = bry[iflag - 1];
08580     fn = (doublereal) ((real) (inu + il));
08581     i__1 = il;
08582     for (i__ = 1; i__ <= i__1; ++i__) {
08583         c2r = s2r;
08584         c2i = s2i;
08585         s2r = s1r + (fn + fnf) * (rzr * c2r - rzi * c2i);
08586         s2i = s1i + (fn + fnf) * (rzr * c2i + rzi * c2r);
08587         s1r = c2r;
08588         s1i = c2i;
08589         fn += -1.;
08590         c2r = s2r * csr;
08591         c2i = s2i * csr;
08592         ckr = c2r;
08593         cki = c2i;
08594         c1r = yr[kk];
08595         c1i = yi[kk];
08596         if (*kode == 1) {
08597             goto L300;
08598         }
08599         zs1s2_(&zrr, &zri, &c1r, &c1i, &c2r, &c2i, &nw, &asc, alim, &iuf);
08600         *nz += nw;
08601 L300:
08602         yr[kk] = c1r * cspnr - c1i * cspni + c2r;
08603         yi[kk] = c1r * cspni + c1i * cspnr + c2i;
08604         --kk;
08605         cspnr = -cspnr;
08606         cspni = -cspni;
08607         if (iflag >= 3) {
08608             goto L310;
08609         }
08610         c2r = abs(ckr);
08611         c2i = abs(cki);
08612         c2m = max(c2r,c2i);
08613         if (c2m <= ascle) {
08614             goto L310;
08615         }
08616         ++iflag;
08617         ascle = bry[iflag - 1];
08618         s1r *= csr;
08619         s1i *= csr;
08620         s2r = ckr;
08621         s2i = cki;
08622         s1r *= cssr[iflag - 1];
08623         s1i *= cssr[iflag - 1];
08624         s2r *= cssr[iflag - 1];
08625         s2i *= cssr[iflag - 1];
08626         csr = csrr[iflag - 1];
08627 L310:
08628         ;
08629     }
08630     return 0;
08631 L320:
08632     *nz = -1;
08633     return 0;
08634 } /* zunk2_ */
08635 
08636 /* Subroutine */ int zbuni_(doublereal *zr, doublereal *zi, doublereal *fnu, 
08637         integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
08638         nz, integer *nui, integer *nlast, doublereal *fnul, doublereal *tol, 
08639         doublereal *elim, doublereal *alim)
08640 {
08641     /* System generated locals */
08642     integer i__1;
08643 
08644     /* Local variables */
08645     static integer i__, k;
08646     static doublereal ax, ay;
08647     static integer nl, nw;
08648     static doublereal c1i, c1m, c1r, s1i, s2i, s1r, s2r, cyi[2], gnu, raz, 
08649             cyr[2], sti, bry[3], rzi, str, rzr, dfnu;
08650     extern doublereal zabs_(doublereal *, doublereal *);
08651     static doublereal fnui;
08652     extern /* Subroutine */ int zuni1_(doublereal *, doublereal *, doublereal 
08653             *, integer *, integer *, doublereal *, doublereal *, integer *, 
08654             integer *, doublereal *, doublereal *, doublereal *, doublereal *)
08655             , zuni2_(doublereal *, doublereal *, doublereal *, integer *, 
08656             integer *, doublereal *, doublereal *, integer *, integer *, 
08657             doublereal *, doublereal *, doublereal *, doublereal *);
08658     static integer iflag;
08659     static doublereal ascle, csclr, cscrr;
08660     static integer iform;
08661     extern doublereal d1mach_(integer *);
08662 
08663 /* ***BEGIN PROLOGUE  ZBUNI */
08664 /* ***REFER TO  ZBESI,ZBESK */
08665 
08666 /*     ZBUNI COMPUTES THE I BESSEL FUNCTION FOR LARGE CABS(Z).GT. */
08667 /*     FNUL AND FNU+N-1.LT.FNUL. THE ORDER IS INCREASED FROM */
08668 /*     FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING */
08669 /*     ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z) */
08670 /*     ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2 */
08671 
08672 /* ***ROUTINES CALLED  ZUNI1,ZUNI2,ZABS,D1MACH */
08673 /* ***END PROLOGUE  ZBUNI */
08674 /*     COMPLEX CSCL,CSCR,CY,RZ,ST,S1,S2,Y,Z */
08675     /* Parameter adjustments */
08676     --yi;
08677     --yr;
08678 
08679     /* Function Body */
08680     *nz = 0;
08681     ax = abs(*zr) * 1.7321;
08682     ay = abs(*zi);
08683     iform = 1;
08684     if (ay > ax) {
08685         iform = 2;
08686     }
08687     if (*nui == 0) {
08688         goto L60;
08689     }
08690     fnui = (doublereal) ((real) (*nui));
08691     dfnu = *fnu + (doublereal) ((real) (*n - 1));
08692     gnu = dfnu + fnui;
08693     if (iform == 2) {
08694         goto L10;
08695     }
08696 /* ----------------------------------------------------------------------- */
08697 /*     ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN */
08698 /*     -PI/3.LE.ARG(Z).LE.PI/3 */
08699 /* ----------------------------------------------------------------------- */
08700     zuni1_(zr, zi, &gnu, kode, &c__2, cyr, cyi, &nw, nlast, fnul, tol, elim, 
08701             alim);
08702     goto L20;
08703 L10:
08704 /* ----------------------------------------------------------------------- */
08705 /*     ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU */
08706 /*     APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I */
08707 /*     AND HPI=PI/2 */
08708 /* ----------------------------------------------------------------------- */
08709     zuni2_(zr, zi, &gnu, kode, &c__2, cyr, cyi, &nw, nlast, fnul, tol, elim, 
08710             alim);
08711 L20:
08712     if (nw < 0) {
08713         goto L50;
08714     }
08715     if (nw != 0) {
08716         goto L90;
08717     }
08718     str = zabs_(cyr, cyi);
08719 /* ---------------------------------------------------------------------- */
08720 /*     SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER USED */
08721 /* ---------------------------------------------------------------------- */
08722     bry[0] = d1mach_(&c__1) * 1e3 / *tol;
08723     bry[1] = 1. / bry[0];
08724     bry[2] = bry[1];
08725     iflag = 2;
08726     ascle = bry[1];
08727     csclr = 1.;
08728     if (str > bry[0]) {
08729         goto L21;
08730     }
08731     iflag = 1;
08732     ascle = bry[0];
08733     csclr = 1. / *tol;
08734     goto L25;
08735 L21:
08736     if (str < bry[1]) {
08737         goto L25;
08738     }
08739     iflag = 3;
08740     ascle = bry[2];
08741     csclr = *tol;
08742 L25:
08743     cscrr = 1. / csclr;
08744     s1r = cyr[1] * csclr;
08745     s1i = cyi[1] * csclr;
08746     s2r = cyr[0] * csclr;
08747     s2i = cyi[0] * csclr;
08748     raz = 1. / zabs_(zr, zi);
08749     str = *zr * raz;
08750     sti = -(*zi) * raz;
08751     rzr = (str + str) * raz;
08752     rzi = (sti + sti) * raz;
08753     i__1 = *nui;
08754     for (i__ = 1; i__ <= i__1; ++i__) {
08755         str = s2r;
08756         sti = s2i;
08757         s2r = (dfnu + fnui) * (rzr * str - rzi * sti) + s1r;
08758         s2i = (dfnu + fnui) * (rzr * sti + rzi * str) + s1i;
08759         s1r = str;
08760         s1i = sti;
08761         fnui += -1.;
08762         if (iflag >= 3) {
08763             goto L30;
08764         }
08765         str = s2r * cscrr;
08766         sti = s2i * cscrr;
08767         c1r = abs(str);
08768         c1i = abs(sti);
08769         c1m = max(c1r,c1i);
08770         if (c1m <= ascle) {
08771             goto L30;
08772         }
08773         ++iflag;
08774         ascle = bry[iflag - 1];
08775         s1r *= cscrr;
08776         s1i *= cscrr;
08777         s2r = str;
08778         s2i = sti;
08779         csclr *= *tol;
08780         cscrr = 1. / csclr;
08781         s1r *= csclr;
08782         s1i *= csclr;
08783         s2r *= csclr;
08784         s2i *= csclr;
08785 L30:
08786         ;
08787     }
08788     yr[*n] = s2r * cscrr;
08789     yi[*n] = s2i * cscrr;
08790     if (*n == 1) {
08791         return 0;
08792     }
08793     nl = *n - 1;
08794     fnui = (doublereal) ((real) nl);
08795     k = nl;
08796     i__1 = nl;
08797     for (i__ = 1; i__ <= i__1; ++i__) {
08798         str = s2r;
08799         sti = s2i;
08800         s2r = (*fnu + fnui) * (rzr * str - rzi * sti) + s1r;
08801         s2i = (*fnu + fnui) * (rzr * sti + rzi * str) + s1i;
08802         s1r = str;
08803         s1i = sti;
08804         str = s2r * cscrr;
08805         sti = s2i * cscrr;
08806         yr[k] = str;
08807         yi[k] = sti;
08808         fnui += -1.;
08809         --k;
08810         if (iflag >= 3) {
08811             goto L40;
08812         }
08813         c1r = abs(str);
08814         c1i = abs(sti);
08815         c1m = max(c1r,c1i);
08816         if (c1m <= ascle) {
08817             goto L40;
08818         }
08819         ++iflag;
08820         ascle = bry[iflag - 1];
08821         s1r *= cscrr;
08822         s1i *= cscrr;
08823         s2r = str;
08824         s2i = sti;
08825         csclr *= *tol;
08826         cscrr = 1. / csclr;
08827         s1r *= csclr;
08828         s1i *= csclr;
08829         s2r *= csclr;
08830         s2i *= csclr;
08831 L40:
08832         ;
08833     }
08834     return 0;
08835 L50:
08836     *nz = -1;
08837     if (nw == -2) {
08838         *nz = -2;
08839     }
08840     return 0;
08841 L60:
08842     if (iform == 2) {
08843         goto L70;
08844     }
08845 /* ----------------------------------------------------------------------- */
08846 /*     ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN */
08847 /*     -PI/3.LE.ARG(Z).LE.PI/3 */
08848 /* ----------------------------------------------------------------------- */
08849     zuni1_(zr, zi, fnu, kode, n, &yr[1], &yi[1], &nw, nlast, fnul, tol, elim, 
08850             alim);
08851     goto L80;
08852 L70:
08853 /* ----------------------------------------------------------------------- */
08854 /*     ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU */
08855 /*     APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I */
08856 /*     AND HPI=PI/2 */
08857 /* ----------------------------------------------------------------------- */
08858     zuni2_(zr, zi, fnu, kode, n, &yr[1], &yi[1], &nw, nlast, fnul, tol, elim, 
08859             alim);
08860 L80:
08861     if (nw < 0) {
08862         goto L50;
08863     }
08864     *nz = nw;
08865     return 0;
08866 L90:
08867     *nlast = *n;
08868     return 0;
08869 } /* zbuni_ */
08870 
08871 /* Subroutine */ int zuni1_(doublereal *zr, doublereal *zi, doublereal *fnu, 
08872         integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
08873         nz, integer *nlast, doublereal *fnul, doublereal *tol, doublereal *
08874         elim, doublereal *alim)
08875 {
08876     /* Initialized data */
08877 
08878     static doublereal zeror = 0.;
08879     static doublereal zeroi = 0.;
08880     static doublereal coner = 1.;
08881 
08882     /* System generated locals */
08883     integer i__1;
08884 
08885     /* Builtin functions */
08886     double log(doublereal), exp(doublereal), cos(doublereal), sin(doublereal);
08887 
08888     /* Local variables */
08889     static integer i__, k, m, nd;
08890     static doublereal fn;
08891     static integer nn, nw;
08892     static doublereal c2i, c2m, c1r, c2r, s1i, s2i, rs1, s1r, s2r, cyi[2];
08893     static integer nuf;
08894     static doublereal bry[3], cyr[2], sti, rzi, str, rzr, aphi, cscl, phii, 
08895             crsc;
08896     extern doublereal zabs_(doublereal *, doublereal *);
08897     static doublereal phir;
08898     static integer init;
08899     static doublereal csrr[3], cssr[3], rast, sumi, sumr;
08900     static integer iflag;
08901     static doublereal ascle, cwrki[16];
08902     extern /* Subroutine */ int zuchk_(doublereal *, doublereal *, integer *, 
08903             doublereal *, doublereal *);
08904     static doublereal cwrkr[16];
08905     extern doublereal d1mach_(integer *);
08906     extern /* Subroutine */ int zunik_(doublereal *, doublereal *, doublereal 
08907             *, integer *, integer *, doublereal *, integer *, doublereal *, 
08908             doublereal *, doublereal *, doublereal *, doublereal *, 
08909             doublereal *, doublereal *, doublereal *, doublereal *, 
08910             doublereal *), zuoik_(doublereal *, doublereal *, doublereal *, 
08911             integer *, integer *, integer *, doublereal *, doublereal *, 
08912             integer *, doublereal *, doublereal *, doublereal *);
08913     static doublereal zeta1i, zeta2i, zeta1r, zeta2r;
08914 
08915 /* ***BEGIN PROLOGUE  ZUNI1 */
08916 /* ***REFER TO  ZBESI,ZBESK */
08917 
08918 /*     ZUNI1 COMPUTES I(FNU,Z)  BY MEANS OF THE UNIFORM ASYMPTOTIC */
08919 /*     EXPANSION FOR I(FNU,Z) IN -PI/3.LE.ARG Z.LE.PI/3. */
08920 
08921 /*     FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC */
08922 /*     EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. */
08923 /*     NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER */
08924 /*     FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. */
08925 /*     Y(I)=CZERO FOR I=NLAST+1,N */
08926 
08927 /* ***ROUTINES CALLED  ZUCHK,ZUNIK,ZUOIK,D1MACH,ZABS */
08928 /* ***END PROLOGUE  ZUNI1 */
08929 /*     COMPLEX CFN,CONE,CRSC,CSCL,CSR,CSS,CWRK,CZERO,C1,C2,PHI,RZ,SUM,S1, */
08930 /*    *S2,Y,Z,ZETA1,ZETA2 */
08931     /* Parameter adjustments */
08932     --yi;
08933     --yr;
08934 
08935     /* Function Body */
08936 
08937     *nz = 0;
08938     nd = *n;
08939     *nlast = 0;
08940 /* ----------------------------------------------------------------------- */
08941 /*     COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- */
08942 /*     NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, */
08943 /*     EXP(ALIM)=EXP(ELIM)*TOL */
08944 /* ----------------------------------------------------------------------- */
08945     cscl = 1. / *tol;
08946     crsc = *tol;
08947     cssr[0] = cscl;
08948     cssr[1] = coner;
08949     cssr[2] = crsc;
08950     csrr[0] = crsc;
08951     csrr[1] = coner;
08952     csrr[2] = cscl;
08953     bry[0] = d1mach_(&c__1) * 1e3 / *tol;
08954 /* ----------------------------------------------------------------------- */
08955 /*     CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER */
08956 /* ----------------------------------------------------------------------- */
08957     fn = max(*fnu,1.);
08958     init = 0;
08959     zunik_(zr, zi, &fn, &c__1, &c__1, tol, &init, &phir, &phii, &zeta1r, &
08960             zeta1i, &zeta2r, &zeta2i, &sumr, &sumi, cwrkr, cwrki);
08961     if (*kode == 1) {
08962         goto L10;
08963     }
08964     str = *zr + zeta2r;
08965     sti = *zi + zeta2i;
08966     rast = fn / zabs_(&str, &sti);
08967     str = str * rast * rast;
08968     sti = -sti * rast * rast;
08969     s1r = -zeta1r + str;
08970     s1i = -zeta1i + sti;
08971     goto L20;
08972 L10:
08973     s1r = -zeta1r + zeta2r;
08974     s1i = -zeta1i + zeta2i;
08975 L20:
08976     rs1 = s1r;
08977     if (abs(rs1) > *elim) {
08978         goto L130;
08979     }
08980 L30:
08981     nn = min(2,nd);
08982     i__1 = nn;
08983     for (i__ = 1; i__ <= i__1; ++i__) {
08984         fn = *fnu + (doublereal) ((real) (nd - i__));
08985         init = 0;
08986         zunik_(zr, zi, &fn, &c__1, &c__0, tol, &init, &phir, &phii, &zeta1r, &
08987                 zeta1i, &zeta2r, &zeta2i, &sumr, &sumi, cwrkr, cwrki);
08988         if (*kode == 1) {
08989             goto L40;
08990         }
08991         str = *zr + zeta2r;
08992         sti = *zi + zeta2i;
08993         rast = fn / zabs_(&str, &sti);
08994         str = str * rast * rast;
08995         sti = -sti * rast * rast;
08996         s1r = -zeta1r + str;
08997         s1i = -zeta1i + sti + *zi;
08998         goto L50;
08999 L40:
09000         s1r = -zeta1r + zeta2r;
09001         s1i = -zeta1i + zeta2i;
09002 L50:
09003 /* ----------------------------------------------------------------------- */
09004 /*     TEST FOR UNDERFLOW AND OVERFLOW */
09005 /* ----------------------------------------------------------------------- */
09006         rs1 = s1r;
09007         if (abs(rs1) > *elim) {
09008             goto L110;
09009         }
09010         if (i__ == 1) {
09011             iflag = 2;
09012         }
09013         if (abs(rs1) < *alim) {
09014             goto L60;
09015         }
09016 /* ----------------------------------------------------------------------- */
09017 /*     REFINE  TEST AND SCALE */
09018 /* ----------------------------------------------------------------------- */
09019         aphi = zabs_(&phir, &phii);
09020         rs1 += log(aphi);
09021         if (abs(rs1) > *elim) {
09022             goto L110;
09023         }
09024         if (i__ == 1) {
09025             iflag = 1;
09026         }
09027         if (rs1 < 0.) {
09028             goto L60;
09029         }
09030         if (i__ == 1) {
09031             iflag = 3;
09032         }
09033 L60:
09034 /* ----------------------------------------------------------------------- */
09035 /*     SCALE S1 IF CABS(S1).LT.ASCLE */
09036 /* ----------------------------------------------------------------------- */
09037         s2r = phir * sumr - phii * sumi;
09038         s2i = phir * sumi + phii * sumr;
09039         str = exp(s1r) * cssr[iflag - 1];
09040         s1r = str * cos(s1i);
09041         s1i = str * sin(s1i);
09042         str = s2r * s1r - s2i * s1i;
09043         s2i = s2r * s1i + s2i * s1r;
09044         s2r = str;
09045         if (iflag != 1) {
09046             goto L70;
09047         }
09048         zuchk_(&s2r, &s2i, &nw, bry, tol);
09049         if (nw != 0) {
09050             goto L110;
09051         }
09052 L70:
09053         cyr[i__ - 1] = s2r;
09054         cyi[i__ - 1] = s2i;
09055         m = nd - i__ + 1;
09056         yr[m] = s2r * csrr[iflag - 1];
09057         yi[m] = s2i * csrr[iflag - 1];
09058 /* L80: */
09059     }
09060     if (nd <= 2) {
09061         goto L100;
09062     }
09063     rast = 1. / zabs_(zr, zi);
09064     str = *zr * rast;
09065     sti = -(*zi) * rast;
09066     rzr = (str + str) * rast;
09067     rzi = (sti + sti) * rast;
09068     bry[1] = 1. / bry[0];
09069     bry[2] = d1mach_(&c__2);
09070     s1r = cyr[0];
09071     s1i = cyi[0];
09072     s2r = cyr[1];
09073     s2i = cyi[1];
09074     c1r = csrr[iflag - 1];
09075     ascle = bry[iflag - 1];
09076     k = nd - 2;
09077     fn = (doublereal) ((real) k);
09078     i__1 = nd;
09079     for (i__ = 3; i__ <= i__1; ++i__) {
09080         c2r = s2r;
09081         c2i = s2i;
09082         s2r = s1r + (*fnu + fn) * (rzr * c2r - rzi * c2i);
09083         s2i = s1i + (*fnu + fn) * (rzr * c2i + rzi * c2r);
09084         s1r = c2r;
09085         s1i = c2i;
09086         c2r = s2r * c1r;
09087         c2i = s2i * c1r;
09088         yr[k] = c2r;
09089         yi[k] = c2i;
09090         --k;
09091         fn += -1.;
09092         if (iflag >= 3) {
09093             goto L90;
09094         }
09095         str = abs(c2r);
09096         sti = abs(c2i);
09097         c2m = max(str,sti);
09098         if (c2m <= ascle) {
09099             goto L90;
09100         }
09101         ++iflag;
09102         ascle = bry[iflag - 1];
09103         s1r *= c1r;
09104         s1i *= c1r;
09105         s2r = c2r;
09106         s2i = c2i;
09107         s1r *= cssr[iflag - 1];
09108         s1i *= cssr[iflag - 1];
09109         s2r *= cssr[iflag - 1];
09110         s2i *= cssr[iflag - 1];
09111         c1r = csrr[iflag - 1];
09112 L90:
09113         ;
09114     }
09115 L100:
09116     return 0;
09117 /* ----------------------------------------------------------------------- */
09118 /*     SET UNDERFLOW AND UPDATE PARAMETERS */
09119 /* ----------------------------------------------------------------------- */
09120 L110:
09121     if (rs1 > 0.) {
09122         goto L120;
09123     }
09124     yr[nd] = zeror;
09125     yi[nd] = zeroi;
09126     ++(*nz);
09127     --nd;
09128     if (nd == 0) {
09129         goto L100;
09130     }
09131     zuoik_(zr, zi, fnu, kode, &c__1, &nd, &yr[1], &yi[1], &nuf, tol, elim, 
09132             alim);
09133     if (nuf < 0) {
09134         goto L120;
09135     }
09136     nd -= nuf;
09137     *nz += nuf;
09138     if (nd == 0) {
09139         goto L100;
09140     }
09141     fn = *fnu + (doublereal) ((real) (nd - 1));
09142     if (fn >= *fnul) {
09143         goto L30;
09144     }
09145     *nlast = nd;
09146     return 0;
09147 L120:
09148     *nz = -1;
09149     return 0;
09150 L130:
09151     if (rs1 > 0.) {
09152         goto L120;
09153     }
09154     *nz = *n;
09155     i__1 = *n;
09156     for (i__ = 1; i__ <= i__1; ++i__) {
09157         yr[i__] = zeror;
09158         yi[i__] = zeroi;
09159 /* L140: */
09160     }
09161     return 0;
09162 } /* zuni1_ */
09163 
09164 /* Subroutine */ int zuni2_(doublereal *zr, doublereal *zi, doublereal *fnu, 
09165         integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
09166         nz, integer *nlast, doublereal *fnul, doublereal *tol, doublereal *
09167         elim, doublereal *alim)
09168 {
09169     /* Initialized data */
09170 
09171     static doublereal zeror = 0.;
09172     static doublereal zeroi = 0.;
09173     static doublereal coner = 1.;
09174     static doublereal cipr[4] = { 1.,0.,-1.,0. };
09175     static doublereal cipi[4] = { 0.,1.,0.,-1. };
09176     static doublereal hpi = 1.57079632679489662;
09177     static doublereal aic = 1.265512123484645396;
09178 
09179     /* System generated locals */
09180     integer i__1;
09181 
09182     /* Builtin functions */
09183     double cos(doublereal), sin(doublereal), log(doublereal), exp(doublereal);
09184 
09185     /* Local variables */
09186     static integer i__, j, k, nd;
09187     static doublereal fn;
09188     static integer in, nn, nw;
09189     static doublereal c2i, c2m, c1r, c2r, s1i, s2i, rs1, s1r, s2r, aii, ang, 
09190             car;
09191     static integer nai;
09192     static doublereal air, zbi, cyi[2], sar;
09193     static integer nuf, inu;
09194     static doublereal bry[3], raz, sti, zbr, zni, cyr[2], rzi, str, znr, rzr, 
09195             daii, cidi, aarg;
09196     static integer ndai;
09197     static doublereal dair, aphi, argi, cscl, phii, crsc, argr;
09198     static integer idum;
09199     extern doublereal zabs_(doublereal *, doublereal *);
09200     static doublereal phir, csrr[3], cssr[3], rast;
09201     static integer iflag;
09202     static doublereal ascle, asumi, bsumi;
09203     extern /* Subroutine */ int zuchk_(doublereal *, doublereal *, integer *, 
09204             doublereal *, doublereal *);
09205     static doublereal asumr, bsumr;
09206     extern doublereal d1mach_(integer *);
09207     extern /* Subroutine */ int zunhj_(doublereal *, doublereal *, doublereal 
09208             *, integer *, doublereal *, doublereal *, doublereal *, 
09209             doublereal *, doublereal *, doublereal *, doublereal *, 
09210             doublereal *, doublereal *, doublereal *, doublereal *, 
09211             doublereal *, doublereal *), zairy_(doublereal *, doublereal *, 
09212             integer *, integer *, doublereal *, doublereal *, integer *, 
09213             integer *), zuoik_(doublereal *, doublereal *, doublereal *, 
09214             integer *, integer *, integer *, doublereal *, doublereal *, 
09215             integer *, doublereal *, doublereal *, doublereal *);
09216     static doublereal zeta1i, zeta2i, zeta1r, zeta2r;
09217 
09218 /* ***BEGIN PROLOGUE  ZUNI2 */
09219 /* ***REFER TO  ZBESI,ZBESK */
09220 
09221 /*     ZUNI2 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF */
09222 /*     UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I */
09223 /*     OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO. */
09224 
09225 /*     FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC */
09226 /*     EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. */
09227 /*     NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER */
09228 /*     FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. */
09229 /*     Y(I)=CZERO FOR I=NLAST+1,N */
09230 
09231 /* ***ROUTINES CALLED  ZAIRY,ZUCHK,ZUNHJ,ZUOIK,D1MACH,ZABS */
09232 /* ***END PROLOGUE  ZUNI2 */
09233 /*     COMPLEX AI,ARG,ASUM,BSUM,CFN,CI,CID,CIP,CONE,CRSC,CSCL,CSR,CSS, */
09234 /*    *CZERO,C1,C2,DAI,PHI,RZ,S1,S2,Y,Z,ZB,ZETA1,ZETA2,ZN */
09235     /* Parameter adjustments */
09236     --yi;
09237     --yr;
09238 
09239     /* Function Body */
09240 
09241     *nz = 0;
09242     nd = *n;
09243     *nlast = 0;
09244 /* ----------------------------------------------------------------------- */
09245 /*     COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- */
09246 /*     NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, */
09247 /*     EXP(ALIM)=EXP(ELIM)*TOL */
09248 /* ----------------------------------------------------------------------- */
09249     cscl = 1. / *tol;
09250     crsc = *tol;
09251     cssr[0] = cscl;
09252     cssr[1] = coner;
09253     cssr[2] = crsc;
09254     csrr[0] = crsc;
09255     csrr[1] = coner;
09256     csrr[2] = cscl;
09257     bry[0] = d1mach_(&c__1) * 1e3 / *tol;
09258 /* ----------------------------------------------------------------------- */
09259 /*     ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI */
09260 /* ----------------------------------------------------------------------- */
09261     znr = *zi;
09262     zni = -(*zr);
09263     zbr = *zr;
09264     zbi = *zi;
09265     cidi = -coner;
09266     inu = (integer) ((real) (*fnu));
09267     ang = hpi * (*fnu - (doublereal) ((real) inu));
09268     c2r = cos(ang);
09269     c2i = sin(ang);
09270     car = c2r;
09271     sar = c2i;
09272     in = inu + *n - 1;
09273     in = in % 4 + 1;
09274     str = c2r * cipr[in - 1] - c2i * cipi[in - 1];
09275     c2i = c2r * cipi[in - 1] + c2i * cipr[in - 1];
09276     c2r = str;
09277     if (*zi > 0.) {
09278         goto L10;
09279     }
09280     znr = -znr;
09281     zbi = -zbi;
09282     cidi = -cidi;
09283     c2i = -c2i;
09284 L10:
09285 /* ----------------------------------------------------------------------- */
09286 /*     CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER */
09287 /* ----------------------------------------------------------------------- */
09288     fn = max(*fnu,1.);
09289     zunhj_(&znr, &zni, &fn, &c__1, tol, &phir, &phii, &argr, &argi, &zeta1r, &
09290             zeta1i, &zeta2r, &zeta2i, &asumr, &asumi, &bsumr, &bsumi);
09291     if (*kode == 1) {
09292         goto L20;
09293     }
09294     str = zbr + zeta2r;
09295     sti = zbi + zeta2i;
09296     rast = fn / zabs_(&str, &sti);
09297     str = str * rast * rast;
09298     sti = -sti * rast * rast;
09299     s1r = -zeta1r + str;
09300     s1i = -zeta1i + sti;
09301     goto L30;
09302 L20:
09303     s1r = -zeta1r + zeta2r;
09304     s1i = -zeta1i + zeta2i;
09305 L30:
09306     rs1 = s1r;
09307     if (abs(rs1) > *elim) {
09308         goto L150;
09309     }
09310 L40:
09311     nn = min(2,nd);
09312     i__1 = nn;
09313     for (i__ = 1; i__ <= i__1; ++i__) {
09314         fn = *fnu + (doublereal) ((real) (nd - i__));
09315         zunhj_(&znr, &zni, &fn, &c__0, tol, &phir, &phii, &argr, &argi, &
09316                 zeta1r, &zeta1i, &zeta2r, &zeta2i, &asumr, &asumi, &bsumr, &
09317                 bsumi);
09318         if (*kode == 1) {
09319             goto L50;
09320         }
09321         str = zbr + zeta2r;
09322         sti = zbi + zeta2i;
09323         rast = fn / zabs_(&str, &sti);
09324         str = str * rast * rast;
09325         sti = -sti * rast * rast;
09326         s1r = -zeta1r + str;
09327         s1i = -zeta1i + sti + abs(*zi);
09328         goto L60;
09329 L50:
09330         s1r = -zeta1r + zeta2r;
09331         s1i = -zeta1i + zeta2i;
09332 L60:
09333 /* ----------------------------------------------------------------------- */
09334 /*     TEST FOR UNDERFLOW AND OVERFLOW */
09335 /* ----------------------------------------------------------------------- */
09336         rs1 = s1r;
09337         if (abs(rs1) > *elim) {
09338             goto L120;
09339         }
09340         if (i__ == 1) {
09341             iflag = 2;
09342         }
09343         if (abs(rs1) < *alim) {
09344             goto L70;
09345         }
09346 /* ----------------------------------------------------------------------- */
09347 /*     REFINE  TEST AND SCALE */
09348 /* ----------------------------------------------------------------------- */
09349 /* ----------------------------------------------------------------------- */
09350         aphi = zabs_(&phir, &phii);
09351         aarg = zabs_(&argr, &argi);
09352         rs1 = rs1 + log(aphi) - log(aarg) * .25 - aic;
09353         if (abs(rs1) > *elim) {
09354             goto L120;
09355         }
09356         if (i__ == 1) {
09357             iflag = 1;
09358         }
09359         if (rs1 < 0.) {
09360             goto L70;
09361         }
09362         if (i__ == 1) {
09363             iflag = 3;
09364         }
09365 L70:
09366 /* ----------------------------------------------------------------------- */
09367 /*     SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR */
09368 /*     EXPONENT EXTREMES */
09369 /* ----------------------------------------------------------------------- */
09370         zairy_(&argr, &argi, &c__0, &c__2, &air, &aii, &nai, &idum);
09371         zairy_(&argr, &argi, &c__1, &c__2, &dair, &daii, &ndai, &idum);
09372         str = dair * bsumr - daii * bsumi;
09373         sti = dair * bsumi + daii * bsumr;
09374         str += air * asumr - aii * asumi;
09375         sti += air * asumi + aii * asumr;
09376         s2r = phir * str - phii * sti;
09377         s2i = phir * sti + phii * str;
09378         str = exp(s1r) * cssr[iflag - 1];
09379         s1r = str * cos(s1i);
09380         s1i = str * sin(s1i);
09381         str = s2r * s1r - s2i * s1i;
09382         s2i = s2r * s1i + s2i * s1r;
09383         s2r = str;
09384         if (iflag != 1) {
09385             goto L80;
09386         }
09387         zuchk_(&s2r, &s2i, &nw, bry, tol);
09388         if (nw != 0) {
09389             goto L120;
09390         }
09391 L80:
09392         if (*zi <= 0.) {
09393             s2i = -s2i;
09394         }
09395         str = s2r * c2r - s2i * c2i;
09396         s2i = s2r * c2i + s2i * c2r;
09397         s2r = str;
09398         cyr[i__ - 1] = s2r;
09399         cyi[i__ - 1] = s2i;
09400         j = nd - i__ + 1;
09401         yr[j] = s2r * csrr[iflag - 1];
09402         yi[j] = s2i * csrr[iflag - 1];
09403         str = -c2i * cidi;
09404         c2i = c2r * cidi;
09405         c2r = str;
09406 /* L90: */
09407     }
09408     if (nd <= 2) {
09409         goto L110;
09410     }
09411     raz = 1. / zabs_(zr, zi);
09412     str = *zr * raz;
09413     sti = -(*zi) * raz;
09414     rzr = (str + str) * raz;
09415     rzi = (sti + sti) * raz;
09416     bry[1] = 1. / bry[0];
09417     bry[2] = d1mach_(&c__2);
09418     s1r = cyr[0];
09419     s1i = cyi[0];
09420     s2r = cyr[1];
09421     s2i = cyi[1];
09422     c1r = csrr[iflag - 1];
09423     ascle = bry[iflag - 1];
09424     k = nd - 2;
09425     fn = (doublereal) ((real) k);
09426     i__1 = nd;
09427     for (i__ = 3; i__ <= i__1; ++i__) {
09428         c2r = s2r;
09429         c2i = s2i;
09430         s2r = s1r + (*fnu + fn) * (rzr * c2r - rzi * c2i);
09431         s2i = s1i + (*fnu + fn) * (rzr * c2i + rzi * c2r);
09432         s1r = c2r;
09433         s1i = c2i;
09434         c2r = s2r * c1r;
09435         c2i = s2i * c1r;
09436         yr[k] = c2r;
09437         yi[k] = c2i;
09438         --k;
09439         fn += -1.;
09440         if (iflag >= 3) {
09441             goto L100;
09442         }
09443         str = abs(c2r);
09444         sti = abs(c2i);
09445         c2m = max(str,sti);
09446         if (c2m <= ascle) {
09447             goto L100;
09448         }
09449         ++iflag;
09450         ascle = bry[iflag - 1];
09451         s1r *= c1r;
09452         s1i *= c1r;
09453         s2r = c2r;
09454         s2i = c2i;
09455         s1r *= cssr[iflag - 1];
09456         s1i *= cssr[iflag - 1];
09457         s2r *= cssr[iflag - 1];
09458         s2i *= cssr[iflag - 1];
09459         c1r = csrr[iflag - 1];
09460 L100:
09461         ;
09462     }
09463 L110:
09464     return 0;
09465 L120:
09466     if (rs1 > 0.) {
09467         goto L140;
09468     }
09469 /* ----------------------------------------------------------------------- */
09470 /*     SET UNDERFLOW AND UPDATE PARAMETERS */
09471 /* ----------------------------------------------------------------------- */
09472     yr[nd] = zeror;
09473     yi[nd] = zeroi;
09474     ++(*nz);
09475     --nd;
09476     if (nd == 0) {
09477         goto L110;
09478     }
09479     zuoik_(zr, zi, fnu, kode, &c__1, &nd, &yr[1], &yi[1], &nuf, tol, elim, 
09480             alim);
09481     if (nuf < 0) {
09482         goto L140;
09483     }
09484     nd -= nuf;
09485     *nz += nuf;
09486     if (nd == 0) {
09487         goto L110;
09488     }
09489     fn = *fnu + (doublereal) ((real) (nd - 1));
09490     if (fn < *fnul) {
09491         goto L130;
09492     }
09493 /*      FN = CIDI */
09494 /*      J = NUF + 1 */
09495 /*      K = MOD(J,4) + 1 */
09496 /*      S1R = CIPR(K) */
09497 /*      S1I = CIPI(K) */
09498 /*      IF (FN.LT.0.0D0) S1I = -S1I */
09499 /*      STR = C2R*S1R - C2I*S1I */
09500 /*      C2I = C2R*S1I + C2I*S1R */
09501 /*      C2R = STR */
09502     in = inu + nd - 1;
09503     in = in % 4 + 1;
09504     c2r = car * cipr[in - 1] - sar * cipi[in - 1];
09505     c2i = car * cipi[in - 1] + sar * cipr[in - 1];
09506     if (*zi <= 0.) {
09507         c2i = -c2i;
09508     }
09509     goto L40;
09510 L130:
09511     *nlast = nd;
09512     return 0;
09513 L140:
09514     *nz = -1;
09515     return 0;
09516 L150:
09517     if (rs1 > 0.) {
09518         goto L140;
09519     }
09520     *nz = *n;
09521     i__1 = *n;
09522     for (i__ = 1; i__ <= i__1; ++i__) {
09523         yr[i__] = zeror;
09524         yi[i__] = zeroi;
09525 /* L160: */
09526     }
09527     return 0;
09528 } /* zuni2_ */
09529 
09530 /* Subroutine */ int xerror_(char *mess, integer *nmess, integer *l1, integer 
09531         *l2, ftnlen mess_len)
09532 {
09533     /* Format strings */
09534 //    static char fmt_900[] = "(/)";
09535 
09536     /* System generated locals */
09537     integer i__1, i__2;
09538 
09539     /* Builtin functions */
09540     integer s_wsfe(cilist *), e_wsfe(void), s_wsle(cilist *), do_lio(integer *
09541             , integer *, char *, ftnlen), e_wsle(void);
09542 
09543     /* Local variables */
09544     static integer i__, k, nn, nr, kmin;
09545 
09546     /* Fortran I/O blocks */
09547 /* These are unused
09548     static cilist io___1271 = { 0, 6, 0, fmt_900, 0 };
09549     static cilist io___1274 = { 0, 6, 0, 0, 0 };
09550     static cilist io___1275 = { 0, 6, 0, fmt_900, 0 };
09551 */
09552 
09553 
09554 /*     THIS IS A DUMMY XERROR ROUTINE TO PRINT ERROR MESSAGES WITH NMESS */
09555 /*     CHARACTERS. L1 AND L2 ARE DUMMY PARAMETERS TO MAKE THIS CALL */
09556 /*     COMPATIBLE WITH THE SLATEC XERROR ROUTINE. THIS IS A FORTRAN 77 */
09557 /*     ROUTINE. */
09558 
09559     nn = *nmess / 70;
09560     nr = *nmess - nn * 70;
09561     if (nr != 0) {
09562         ++nn;
09563     }
09564     k = 1;
09565 /*
09566     s_wsfe(&io___1271);
09567     e_wsfe();
09568 */
09569     i__1 = nn;
09570     for (i__ = 1; i__ <= i__1; ++i__) {
09571 /* Computing MIN */
09572         i__2 = k + 69;
09573         kmin = min(i__2,*nmess);
09574 /*
09575         s_wsle(&io___1274);
09576         do_lio(&c__9, &c__1, mess + (k - 1), kmin - (k - 1));
09577         e_wsle();
09578 */
09579         k += 70;
09580 /* L10: */
09581     }
09582 /*
09583     s_wsfe(&io___1275);
09584     e_wsfe();
09585 */
09586     return 0;
09587 } /* xerror_ */
09588 

Generated on Fri Jan 4 18:04:16 2008 for sedflux by  doxygen 1.5.2