home *** CD-ROM | disk | FTP | other *** search
/ Hot Shareware 32 / hot34.iso / ficheros / WGRAF / MATHLIB.ZIP / TOMS.C < prev    next >
C/C++ Source or Header  |  1997-07-06  |  333KB  |  10,674 lines
  1. /* funz1.f -- translated by f2c (version of 16 May 1991  13:06:06).
  2.    You must link the resulting object file with the libraries:
  3.         -link <S|C|M|L>f2c.lib   (in that order)
  4. */
  5.  
  6. #include "f2c.h"
  7. #include "math.h"
  8. extern void cdiv( doublecomplex *a, doublecomplex *b, doublecomplex *c );
  9.  
  10. /* Table of constant values */
  11.  
  12. static integer c__4 = 4;
  13. static integer c__14 = 14;
  14. static integer c__5 = 5;
  15. static integer c__9 = 9;
  16. static integer c__1 = 1;
  17. static integer c__2 = 2;
  18. static integer c__15 = 15;
  19. static integer c__16 = 16;
  20.  
  21. /* C    D1MACH.FOR - Double Precision Machine Constants */
  22. /* C */
  23. doublereal d1mach_(integer *i)
  24. {
  25.     /* Initialized data */
  26.  
  27.     static struct {
  28.         integer e_1[10];
  29.         doublereal e_2;
  30.         } equiv_4 = { 0, 1048576, -1, 2146435071, 0, 1017118720, 0, 
  31.                 1018167296, 1352628735, 1070810131, 0. };
  32.  
  33.  
  34.     /* System generated locals */
  35.     doublereal ret_val;
  36.  
  37.     /* Local variables */
  38. #define log10 ((integer *)&equiv_4 + 8)
  39. #define dmach ((doublereal *)&equiv_4)
  40. #define large ((integer *)&equiv_4 + 2)
  41. #define small ((integer *)&equiv_4)
  42. #define diver ((integer *)&equiv_4 + 6)
  43. #define right ((integer *)&equiv_4 + 4)
  44.  
  45.     if (*i < 1 || *i > 5) {
  46.         goto L999;
  47.     }
  48.     ret_val = dmach[*i - 1];
  49. L999:
  50.     return ret_val;
  51. } /* d1mach_ */
  52.  
  53. #undef right
  54. #undef diver
  55. #undef small
  56. #undef large
  57. #undef dmach
  58. #undef log10
  59.  
  60.  
  61. /* C    I1MACH.FOR - Integer Machine Constants */
  62. /* C */
  63. integer i1mach_(integer *i)
  64. {
  65.     /* Initialized data */
  66.  
  67.     static struct {
  68.         integer e_1[16];
  69.         } equiv_0 = { 5, 6, 7, 0, 32, 4, 2, 31, 2147483647, 2, 24, -125, 128, 
  70.                 53, -1021, 1024 };
  71.  
  72.  
  73.     /* System generated locals */
  74.     integer ret_val;
  75.  
  76.     /* Local variables */
  77. #define imach ((integer *)&equiv_0)
  78. #define output ((integer *)&equiv_0 + 3)
  79.  
  80.     if (*i < 1 || *i > 16) {
  81.         goto L10;
  82.     }
  83.  
  84.     ret_val = imach[*i - 1];
  85. /* /6S */
  86. /* /7S */
  87.     if (*i == 6) {
  88.         ret_val = 1;
  89.     }
  90. /* / */
  91. L10:
  92.     return ret_val;
  93. } /* i1mach_ */
  94.  
  95. #undef output
  96. #undef imach
  97.  
  98.  
  99. /* C    R1MACH.FOR - Real Machine Constants */
  100. /* C */
  101. doublereal r1mach_(integer *i)
  102. {
  103.     /* Initialized data */
  104.  
  105.     static struct {
  106.         integer e_1[5];
  107.         integer fill_2[1];
  108.         real e_3;
  109.         } equiv_4 = { 8388608, 2139095039, 864026624, 872415232, 1050288283, {
  110.                 0}, 0.f };
  111.  
  112.  
  113.     /* System generated locals */
  114.     real ret_val;
  115.  
  116.     /* Local variables */
  117. #define log10 ((integer *)&equiv_4 + 4)
  118. #define large ((integer *)&equiv_4 + 1)
  119. #define rmach ((real *)&equiv_4)
  120. #define small ((integer *)&equiv_4)
  121. #define diver ((integer *)&equiv_4 + 3)
  122. #define right ((integer *)&equiv_4 + 2)
  123.  
  124.     if (*i < 1 || *i > 5) {
  125.         goto L999;
  126.     }
  127.     ret_val = rmach[*i - 1];
  128. L999:
  129.     return ret_val;
  130. } /* r1mach_ */
  131.  
  132. #undef right
  133. #undef diver
  134. #undef small
  135. #undef rmach
  136. #undef large
  137. #undef log10
  138.  
  139. /*--------------------------*/
  140. double d_sign(doublereal *a, doublereal *b)
  141. {
  142.         double fabs( double );
  143.  
  144.         if (*b >= 0.0) return( fabs( *a ) );
  145.         else return( - fabs( *a ) );
  146. }
  147.  
  148. double pow_dd(doublereal *a, doublereal *b)
  149. {
  150.         double pow( double , double );
  151.  
  152.         return( pow( *a , *b ) );
  153. }
  154.  
  155. double pow_di(doublereal *a, integer *b)
  156. {
  157.         double powi( double , int );
  158.  
  159.         return( powi( *a , (int)*b ) );
  160. }
  161.  
  162. double d_int(doublereal *x)
  163. {
  164.         double modf( double , double * );
  165.         double n;
  166.  
  167.         modf( (double)*x , &n );
  168.         return( n );
  169. }
  170.  
  171. doublereal cdabs_(doublecomplex *z)
  172. {
  173.         double cabs();
  174.  
  175.         return( cabs( *z ) );
  176. }
  177.  
  178. double d_imag(doublecomplex *z)
  179. {
  180.         return( z->i );
  181. }
  182.  
  183. void z_div(doublecomplex *a, doublecomplex *b, doublecomplex *c)
  184. {
  185.         void cdiv();
  186.  
  187.         cdiv( c, b, a );
  188. }
  189.  
  190.  
  191. doublereal dgamln_(doublereal *z, integer *ierr)
  192. {
  193.     /* Initialized data */
  194.  
  195.     static doublereal gln[100] = { 0.,0.,.693147180559945309,
  196.             1.791759469228055,3.17805383034794562,4.78749174278204599,
  197.             6.579251212010101,8.5251613610654143,10.6046029027452502,
  198.             12.8018274800814696,15.1044125730755153,17.5023078458738858,
  199.             19.9872144956618861,22.5521638531234229,25.1912211827386815,
  200.             27.8992713838408916,30.6718601060806728,33.5050734501368889,
  201.             36.3954452080330536,39.339884187199494,42.335616460753485,
  202.             45.380138898476908,48.4711813518352239,51.6066755677643736,
  203.             54.7847293981123192,58.0036052229805199,61.261701761002002,
  204.             64.5575386270063311,67.889743137181535,71.257038967168009,
  205.             74.6582363488301644,78.0922235533153106,81.5579594561150372,
  206.             85.0544670175815174,88.5808275421976788,92.1361756036870925,
  207.             95.7196945421432025,99.3306124547874269,102.968198614513813,
  208.             106.631760260643459,110.320639714757395,114.034211781461703,
  209.             117.771881399745072,121.533081515438634,125.317271149356895,
  210.             129.123933639127215,132.95257503561631,136.802722637326368,
  211.             140.673923648234259,144.565743946344886,148.477766951773032,
  212.             152.409592584497358,156.360836303078785,160.331128216630907,
  213.             164.320112263195181,168.327445448427652,172.352797139162802,
  214.             176.395848406997352,180.456291417543771,184.533828861449491,
  215.             188.628173423671591,192.739047287844902,196.866181672889994,
  216.             201.009316399281527,205.168199482641199,209.342586752536836,
  217.             213.532241494563261,217.736934113954227,221.956441819130334,
  218.             226.190548323727593,230.439043565776952,234.701723442818268,
  219.             238.978389561834323,243.268849002982714,247.572914096186884,
  220.             251.890402209723194,256.221135550009525,260.564940971863209,
  221.             264.921649798552801,269.291097651019823,273.673124285693704,
  222.             278.067573440366143,282.474292687630396,286.893133295426994,
  223.             291.323950094270308,295.766601350760624,300.220948647014132,
  224.             304.686856765668715,309.164193580146922,313.652829949879062,
  225.             318.152639620209327,322.663499126726177,327.185287703775217,
  226.             331.717887196928473,336.261181979198477,340.815058870799018,
  227.             345.379407062266854,349.954118040770237,354.539085519440809,
  228.             359.134205369575399 };
  229.     static doublereal cf[22] = { .0833333333333333333,-.00277777777777777778,
  230.             7.93650793650793651e-4,-5.95238095238095238e-4,
  231.             8.41750841750841751e-4,-.00191752691752691753,
  232.             .00641025641025641026,-.0295506535947712418,.179644372368830573,
  233.             -1.39243221690590112,13.402864044168392,-156.848284626002017,
  234.             2193.10333333333333,-36108.7712537249894,691472.268851313067,
  235.             -15238221.5394074162,382900751.391414141,-10882266035.7843911,
  236.             347320283765.002252,-12369602142269.2745,488788064793079.335,
  237.             -21320333960919373.9 };
  238.     static doublereal con = 1.83787706640934548;
  239.  
  240.     /* System generated locals */
  241.     integer i__1;
  242.     doublereal ret_val;
  243.  
  244.     /* Builtin functions */
  245.     double log(doublereal);
  246.  
  247.     /* Local variables */
  248.     static doublereal zinc, zmin, zdmy;
  249.     static integer i, k;
  250.     static doublereal s, wdtol;
  251.     extern doublereal d1mach_(integer *);
  252.     extern integer i1mach_(integer *);
  253.     static doublereal t1, fz, zm;
  254.     static integer mz, nz;
  255.     static doublereal zp;
  256.     static integer i1m;
  257.     static doublereal fln, tlg, rln, trm, tst, zsq;
  258.  
  259. /* ***BEGIN PROLOGUE  DGAMLN */
  260. /* ***DATE WRITTEN   830501   (YYMMDD) */
  261. /* ***REVISION DATE  830501   (YYMMDD) */
  262. /* ***CATEGORY NO.  B5F */
  263. /* ***KEYWORDS  GAMMA FUNCTION,LOGARITHM OF GAMMA FUNCTION */
  264. /* ***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES */
  265. /* ***PURPOSE  TO COMPUTE THE LOGARITHM OF THE GAMMA FUNCTION */
  266. /* ***DESCRIPTION */
  267.  
  268. /*               **** A DOUBLE PRECISION ROUTINE **** */
  269. /*         DGAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR */
  270. /*         Z.GT.0.  THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES */
  271.  
  272. /*         GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION */
  273. /*         G(Z+1)=Z*G(Z) FOR Z.LE.ZMIN.  THE FUNCTION WAS MADE AS */
  274. /*         PORTABLE AS POSSIBLE BY COMPUTIMG ZMIN FROM THE NUMBER OF BASE 
  275. */
  276. /*         10 DIGITS IN A WORD, RLN=AMAX1(-ALOG10(R1MACH(4)),0.5E-18) */
  277. /*         LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY. */
  278.  
  279. /*         SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100 */
  280. /*         VALUES IS USED FOR SPEED OF EXECUTION. */
  281.  
  282. /*     DESCRIPTION OF ARGUMENTS */
  283.  
  284. /*         INPUT      Z IS D0UBLE PRECISION */
  285. /*           Z      - ARGUMENT, Z.GT.0.0D0 */
  286.  
  287. /*         OUTPUT      DGAMLN IS DOUBLE PRECISION */
  288. /*           DGAMLN  - NATURAL LOG OF THE GAMMA FUNCTION AT Z.NE.0.0D0 */
  289. /*           IERR    - ERROR FLAG */
  290. /*                     IERR=0, NORMAL RETURN, COMPUTATION COMPLETED */
  291. /*                     IERR=1, Z.LE.0.0D0,    NO COMPUTATION */
  292.  
  293.  
  294. /* ***REFERENCES  COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
  295. /*                 BY D. E. AMOS, SAND83-0083, MAY, 1983. */
  296. /* ***ROUTINES CALLED  I1MACH,D1MACH */
  297. /* ***END PROLOGUE  DGAMLN */
  298. /*           LNGAMMA(N), N=1,100 */
  299. /*             COEFFICIENTS OF ASYMPTOTIC EXPANSION */
  300.  
  301. /*             LN(2*PI) */
  302.  
  303. /* ***FIRST EXECUTABLE STATEMENT  DGAMLN */
  304.     *ierr = 0;
  305.     if (*z <= 0.) {
  306.         goto L70;
  307.     }
  308.     if (*z > 101.) {
  309.         goto L10;
  310.     }
  311.     nz = (integer) (*z);
  312.     fz = *z - (real) nz;
  313.     if (fz > 0.) {
  314.         goto L10;
  315.     }
  316.     if (nz > 100) {
  317.         goto L10;
  318.     }
  319.     ret_val = gln[nz - 1];
  320.     return ret_val;
  321. L10:
  322.     wdtol = d1mach_(&c__4);
  323.     wdtol = max(wdtol,5e-19);
  324.     i1m = i1mach_(&c__14);
  325.     rln = d1mach_(&c__5) * (real) i1m;
  326.     fln = min(rln,20.);
  327.     fln = max(fln,3.);
  328.     fln += -3.;
  329.     zm = fln * .3875 + 1.8;
  330.     mz = (integer) zm + 1;
  331.     zmin = (real) mz;
  332.     zdmy = *z;
  333.     zinc = 0.;
  334.     if (*z >= zmin) {
  335.         goto L20;
  336.     }
  337.     zinc = zmin - (real) nz;
  338.     zdmy = *z + zinc;
  339. L20:
  340.     zp = 1. / zdmy;
  341.     t1 = cf[0] * zp;
  342.     s = t1;
  343.     if (zp < wdtol) {
  344.         goto L40;
  345.     }
  346.     zsq = zp * zp;
  347.     tst = t1 * wdtol;
  348.     for (k = 2; k <= 22; ++k) {
  349.         zp *= zsq;
  350.         trm = cf[k - 1] * zp;
  351.         if (abs(trm) < tst) {
  352.             goto L40;
  353.         }
  354.         s += trm;
  355. /* L30: */
  356.     }
  357. L40:
  358.     if (zinc != 0.) {
  359.         goto L50;
  360.     }
  361.     tlg = log(*z);
  362.     ret_val = *z * (tlg - 1.) + (con - tlg) * .5 + s;
  363.     return ret_val;
  364. L50:
  365.     zp = 1.;
  366.     nz = (integer) zinc;
  367.     i__1 = nz;
  368.     for (i = 1; i <= i__1; ++i) {
  369.         zp *= *z + (real) (i - 1);
  370. /* L60: */
  371.     }
  372.     tlg = log(zdmy);
  373.     ret_val = zdmy * (tlg - 1.) - log(zp) + (con - tlg) * .5 + s;
  374.     return ret_val;
  375.  
  376.  
  377. L70:
  378.     *ierr = 1;
  379.     return ret_val;
  380. } /* dgamln_ */
  381.  
  382. doublereal z1abs_(doublereal *zr, doublereal *zi)
  383. {
  384.     /* System generated locals */
  385.     doublereal ret_val;
  386.  
  387.     /* Builtin functions */
  388.     double sqrt(doublereal);
  389.  
  390.     /* Local variables */
  391.     static doublereal q, s, u, v;
  392.  
  393. /* ***BEGIN PROLOGUE  Z1ABS */
  394. /* ***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY */
  395.  
  396. /*     Z1ABS COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE */
  397. /*     PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI) */
  398.  
  399. /* ***ROUTINES CALLED  (NONE) */
  400. /* ***END PROLOGUE  Z1ABS */
  401.     u = abs(*zr);
  402.     v = abs(*zi);
  403.     s = u + v;
  404. /* -----------------------------------------------------------------------
  405.  */
  406. /*     S*1.0D0 MAKES AN UNNORMALIZED UNDERFLOW ON CDC MACHINES INTO A */
  407. /*     TRUE FLOATING ZERO */
  408. /* -----------------------------------------------------------------------
  409.  */
  410.     s *= 1.;
  411.     if (s == 0.) {
  412.         goto L20;
  413.     }
  414.     if (u > v) {
  415.         goto L10;
  416.     }
  417.     q = u / v;
  418.     ret_val = v * sqrt(q * q + 1.);
  419.     return ret_val;
  420. L10:
  421.     q = v / u;
  422.     ret_val = u * sqrt(q * q + 1.);
  423.     return ret_val;
  424. L20:
  425.     ret_val = 0.;
  426.     return ret_val;
  427. } /* z1abs_ */
  428.  
  429. /* Subroutine */ int zacai_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  430.         integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *
  431.         yi, integer *nz, doublereal *rl, doublereal *tol, doublereal *elim, 
  432.         doublereal *alim)
  433. {
  434.     /* Initialized data */
  435.  
  436.     static doublereal pi = 3.14159265358979324;
  437.  
  438.     /* Builtin functions */
  439.     double d_sign(doublereal *, doublereal *), sin(doublereal), cos(
  440.             doublereal);
  441.  
  442.     /* Local variables */
  443.     static doublereal dfnu;
  444.     extern /* Subroutine */ int zs1s2_(doublereal *, doublereal *, doublereal 
  445.             *, doublereal *, doublereal *, doublereal *, integer *, 
  446.             doublereal *, doublereal *, integer *);
  447.     extern doublereal z1abs_(doublereal *, doublereal *);
  448.     static doublereal ascle, csgni, csgnr, cspni, cspnr;
  449.     extern /* Subroutine */ int zbknu_(doublereal *, doublereal *, doublereal 
  450.             *, integer *, integer *, doublereal *, doublereal *, integer *, 
  451.             doublereal *, doublereal *, doublereal *), zseri_(doublereal *, 
  452.             doublereal *, doublereal *, integer *, integer *, doublereal *, 
  453.             doublereal *, integer *, doublereal *, doublereal *, doublereal *)
  454.             ;
  455.     extern doublereal d1mach_(integer *);
  456.     extern /* Subroutine */ int zmlri_(doublereal *, doublereal *, doublereal 
  457.             *, integer *, integer *, doublereal *, doublereal *, integer *, 
  458.             doublereal *), zasyi_(doublereal *, doublereal *, doublereal *, 
  459.             integer *, integer *, doublereal *, doublereal *, integer *, 
  460.             doublereal *, doublereal *, doublereal *, doublereal *);
  461.     static doublereal az;
  462.     static integer nn, nw;
  463.     static doublereal yy, c1i, c2i, c1r, c2r, arg;
  464.     static integer iuf;
  465.     static doublereal cyi[2], fmr, sgn;
  466.     static integer inu;
  467.     static doublereal cyr[2], zni, znr;
  468.  
  469. /* ***BEGIN PROLOGUE  ZACAI */
  470. /* ***REFER TO  ZAIRY */
  471.  
  472. /*     ZACAI APPLIES THE ANALYTIC CONTINUATION FORMULA */
  473.  
  474. /*         K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) */
  475. /*                 MP=PI*MR*CMPLX(0.0,1.0) */
  476.  
  477. /*     TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT */
  478. /*     HALF Z PLANE FOR USE WITH ZAIRY WHERE FNU=1/3 OR 2/3 AND N=1. */
  479. /*     ZACAI IS THE SAME AS ZACON WITH THE PARTS FOR LARGER ORDERS AND */
  480. /*     RECURRENCE REMOVED. A RECURSIVE CALL TO ZACON CAN RESULT IF ZACON 
  481. */
  482. /*     IS CALLED FROM ZAIRY. */
  483.  
  484. /* ***ROUTINES CALLED  ZASYI,ZBKNU,ZMLRI,ZSERI,ZS1S2,D1MACH,Z1ABS */
  485. /* ***END PROLOGUE  ZACAI */
  486. /*     COMPLEX CSGN,CSPN,C1,C2,Y,Z,ZN,CY */
  487.     /* Parameter adjustments */
  488.     --yi;
  489.     --yr;
  490.  
  491.     /* Function Body */
  492.     *nz = 0;
  493.     znr = -(*zr);
  494.     zni = -(*zi);
  495.     az = z1abs_(zr, zi);
  496.     nn = *n;
  497.     dfnu = *fnu + (doublereal) ((real) (*n - 1));
  498.     if (az <= 2.) {
  499.         goto L10;
  500.     }
  501.     if (az * az * .25 > dfnu + 1.) {
  502.         goto L20;
  503.     }
  504. L10:
  505. /* -----------------------------------------------------------------------
  506.  */
  507. /*     POWER SERIES FOR THE I FUNCTION */
  508. /* -----------------------------------------------------------------------
  509.  */
  510.     zseri_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, tol, elim, alim);
  511.     goto L40;
  512. L20:
  513.     if (az < *rl) {
  514.         goto L30;
  515.     }
  516. /* -----------------------------------------------------------------------
  517.  */
  518. /*     ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I FUNCTION */
  519. /* -----------------------------------------------------------------------
  520.  */
  521.     zasyi_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, rl, tol, elim, 
  522.             alim);
  523.     if (nw < 0) {
  524.         goto L80;
  525.     }
  526.     goto L40;
  527. L30:
  528. /* -----------------------------------------------------------------------
  529.  */
  530. /*     MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION */
  531. /* -----------------------------------------------------------------------
  532.  */
  533.     zmlri_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, tol);
  534.     if (nw < 0) {
  535.         goto L80;
  536.     }
  537. L40:
  538. /* -----------------------------------------------------------------------
  539.  */
  540. /*     ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION */
  541. /* -----------------------------------------------------------------------
  542.  */
  543.     zbknu_(&znr, &zni, fnu, kode, &c__1, cyr, cyi, &nw, tol, elim, alim);
  544.     if (nw != 0) {
  545.         goto L80;
  546.     }
  547.     fmr = (doublereal) ((real) (*mr));
  548.     sgn = -d_sign(&pi, &fmr);
  549.     csgnr = 0.;
  550.     csgni = sgn;
  551.     if (*kode == 1) {
  552.         goto L50;
  553.     }
  554.     yy = -zni;
  555.     csgnr = -csgni * sin(yy);
  556.     csgni *= cos(yy);
  557. L50:
  558. /* -----------------------------------------------------------------------
  559.  */
  560. /*     CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE */
  561. /*     WHEN FNU IS LARGE */
  562. /* -----------------------------------------------------------------------
  563.  */
  564.     inu = (integer) (*fnu);
  565.     arg = (*fnu - (doublereal) ((real) inu)) * sgn;
  566.     cspnr = cos(arg);
  567.     cspni = sin(arg);
  568.     if (inu % 2 == 0) {
  569.         goto L60;
  570.     }
  571.     cspnr = -cspnr;
  572.     cspni = -cspni;
  573. L60:
  574.     c1r = cyr[0];
  575.     c1i = cyi[0];
  576.     c2r = yr[1];
  577.     c2i = yi[1];
  578.     if (*kode == 1) {
  579.         goto L70;
  580.     }
  581.     iuf = 0;
  582.     ascle = d1mach_(&c__1) * 1e3 / *tol;
  583.     zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
  584.     *nz += nw;
  585. L70:
  586.     yr[1] = cspnr * c1r - cspni * c1i + csgnr * c2r - csgni * c2i;
  587.     yi[1] = cspnr * c1i + cspni * c1r + csgnr * c2i + csgni * c2r;
  588.     return 0;
  589. L80:
  590.     *nz = -1;
  591.     if (nw == -2) {
  592.         *nz = -2;
  593.     }
  594.     return 0;
  595. } /* zacai_ */
  596.  
  597. /* Subroutine */ int zacon_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  598.         integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *
  599.         yi, integer *nz, doublereal *rl, doublereal *fnul, doublereal *tol, 
  600.         doublereal *elim, doublereal *alim)
  601. {
  602.     /* Initialized data */
  603.  
  604.     static doublereal pi = 3.14159265358979324;
  605.     static doublereal zeror = 0.;
  606.     static doublereal coner = 1.;
  607.  
  608.     /* System generated locals */
  609.     integer i__1;
  610.  
  611.     /* Builtin functions */
  612.     double d_sign(doublereal *, doublereal *), cos(doublereal), sin(
  613.             doublereal);
  614.  
  615.     /* Local variables */
  616.     static doublereal cscl, cscr, csrr[3], cssr[3], razn;
  617.     extern /* Subroutine */ int zs1s2_(doublereal *, doublereal *, doublereal 
  618.             *, doublereal *, doublereal *, doublereal *, integer *, 
  619.             doublereal *, doublereal *, integer *), zmlt_(doublereal *, 
  620.             doublereal *, doublereal *, doublereal *, doublereal *, 
  621.             doublereal *);
  622.     extern doublereal z1abs_(doublereal *, doublereal *);
  623.     static integer i, kflag;
  624.     static doublereal ascle, bscle, csgni, csgnr, cspni, cspnr;
  625.     extern /* Subroutine */ int zbinu_(doublereal *, doublereal *, doublereal 
  626.             *, integer *, integer *, doublereal *, doublereal *, integer *, 
  627.             doublereal *, doublereal *, doublereal *, doublereal *, 
  628.             doublereal *), zbknu_(doublereal *, doublereal *, doublereal *, 
  629.             integer *, integer *, doublereal *, doublereal *, integer *, 
  630.             doublereal *, doublereal *, doublereal *);
  631.     extern doublereal d1mach_(integer *);
  632.     static doublereal fn;
  633.     static integer nn, nw;
  634.     static doublereal yy, c1i, c2i, c1m, as2, c1r, c2r, s1i, s2i, s1r, s2r, 
  635.             cki, arg, ckr, cpn;
  636.     static integer iuf;
  637.     static doublereal cyi[2], fmr, csr, azn, sgn;
  638.     static integer inu;
  639.     static doublereal bry[3], cyr[2], pti, spn, sti, zni, rzi, ptr, str, znr, 
  640.             rzr, sc1i, sc2i, sc1r, sc2r;
  641.  
  642. /* ***BEGIN PROLOGUE  ZACON */
  643. /* ***REFER TO  ZBESK,ZBESH */
  644.  
  645. /*     ZACON APPLIES THE ANALYTIC CONTINUATION FORMULA */
  646.  
  647. /*         K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) */
  648. /*                 MP=PI*MR*CMPLX(0.0,1.0) */
  649.  
  650. /*     TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT */
  651. /*     HALF Z PLANE */
  652.  
  653. /* ***ROUTINES CALLED  ZBINU,ZBKNU,ZS1S2,D1MACH,Z1ABS,ZMLT */
  654. /* ***END PROLOGUE  ZACON */
  655. /*     COMPLEX CK,CONE,CSCL,CSCR,CSGN,CSPN,CY,CZERO,C1,C2,RZ,SC1,SC2,ST, 
  656. */
  657. /*    *S1,S2,Y,Z,ZN */
  658.     /* Parameter adjustments */
  659.     --yi;
  660.     --yr;
  661.  
  662.     /* Function Body */
  663.     *nz = 0;
  664.     znr = -(*zr);
  665.     zni = -(*zi);
  666.     nn = *n;
  667.     zbinu_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, rl, fnul, tol, 
  668.             elim, alim);
  669.     if (nw < 0) {
  670.         goto L90;
  671.     }
  672. /* -----------------------------------------------------------------------
  673.  */
  674. /*     ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION */
  675. /* -----------------------------------------------------------------------
  676.  */
  677.     nn = min(2,*n);
  678.     zbknu_(&znr, &zni, fnu, kode, &nn, cyr, cyi, &nw, tol, elim, alim);
  679.     if (nw != 0) {
  680.         goto L90;
  681.     }
  682.     s1r = cyr[0];
  683.     s1i = cyi[0];
  684.     fmr = (doublereal) ((real) (*mr));
  685.     sgn = -d_sign(&pi, &fmr);
  686.     csgnr = zeror;
  687.     csgni = sgn;
  688.     if (*kode == 1) {
  689.         goto L10;
  690.     }
  691.     yy = -zni;
  692.     cpn = cos(yy);
  693.     spn = sin(yy);
  694.     zmlt_(&csgnr, &csgni, &cpn, &spn, &csgnr, &csgni);
  695. L10:
  696. /* -----------------------------------------------------------------------
  697.  */
  698. /*     CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE */
  699. /*     WHEN FNU IS LARGE */
  700. /* -----------------------------------------------------------------------
  701.  */
  702.     inu = (integer) (*fnu);
  703.     arg = (*fnu - (doublereal) ((real) inu)) * sgn;
  704.     cpn = cos(arg);
  705.     spn = sin(arg);
  706.     cspnr = cpn;
  707.     cspni = spn;
  708.     if (inu % 2 == 0) {
  709.         goto L20;
  710.     }
  711.     cspnr = -cspnr;
  712.     cspni = -cspni;
  713. L20:
  714.     iuf = 0;
  715.     c1r = s1r;
  716.     c1i = s1i;
  717.     c2r = yr[1];
  718.     c2i = yi[1];
  719.     ascle = d1mach_(&c__1) * 1e3 / *tol;
  720.     if (*kode == 1) {
  721.         goto L30;
  722.     }
  723.     zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
  724.     *nz += nw;
  725.     sc1r = c1r;
  726.     sc1i = c1i;
  727. L30:
  728.     zmlt_(&cspnr, &cspni, &c1r, &c1i, &str, &sti);
  729.     zmlt_(&csgnr, &csgni, &c2r, &c2i, &ptr, &pti);
  730.     yr[1] = str + ptr;
  731.     yi[1] = sti + pti;
  732.     if (*n == 1) {
  733.         return 0;
  734.     }
  735.     cspnr = -cspnr;
  736.     cspni = -cspni;
  737.     s2r = cyr[1];
  738.     s2i = cyi[1];
  739.     c1r = s2r;
  740.     c1i = s2i;
  741.     c2r = yr[2];
  742.     c2i = yi[2];
  743.     if (*kode == 1) {
  744.         goto L40;
  745.     }
  746.     zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
  747.     *nz += nw;
  748.     sc2r = c1r;
  749.     sc2i = c1i;
  750. L40:
  751.     zmlt_(&cspnr, &cspni, &c1r, &c1i, &str, &sti);
  752.     zmlt_(&csgnr, &csgni, &c2r, &c2i, &ptr, &pti);
  753.     yr[2] = str + ptr;
  754.     yi[2] = sti + pti;
  755.     if (*n == 2) {
  756.         return 0;
  757.     }
  758.     cspnr = -cspnr;
  759.     cspni = -cspni;
  760.     azn = z1abs_(&znr, &zni);
  761.     razn = 1. / azn;
  762.     str = znr * razn;
  763.     sti = -zni * razn;
  764.     rzr = (str + str) * razn;
  765.     rzi = (sti + sti) * razn;
  766.     fn = *fnu + 1.;
  767.     ckr = fn * rzr;
  768.     cki = fn * rzi;
  769. /* -----------------------------------------------------------------------
  770.  */
  771. /*     SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS */
  772. /* -----------------------------------------------------------------------
  773.  */
  774.     cscl = 1. / *tol;
  775.     cscr = *tol;
  776.     cssr[0] = cscl;
  777.     cssr[1] = coner;
  778.     cssr[2] = cscr;
  779.     csrr[0] = cscr;
  780.     csrr[1] = coner;
  781.     csrr[2] = cscl;
  782.     bry[0] = ascle;
  783.     bry[1] = 1. / ascle;
  784.     bry[2] = d1mach_(&c__2);
  785.     as2 = z1abs_(&s2r, &s2i);
  786.     kflag = 2;
  787.     if (as2 > bry[0]) {
  788.         goto L50;
  789.     }
  790.     kflag = 1;
  791.     goto L60;
  792. L50:
  793.     if (as2 < bry[1]) {
  794.         goto L60;
  795.     }
  796.     kflag = 3;
  797. L60:
  798.     bscle = bry[kflag - 1];
  799.     s1r *= cssr[kflag - 1];
  800.     s1i *= cssr[kflag - 1];
  801.     s2r *= cssr[kflag - 1];
  802.     s2i *= cssr[kflag - 1];
  803.     csr = csrr[kflag - 1];
  804.     i__1 = *n;
  805.     for (i = 3; i <= i__1; ++i) {
  806.         str = s2r;
  807.         sti = s2i;
  808.         s2r = ckr * str - cki * sti + s1r;
  809.         s2i = ckr * sti + cki * str + s1i;
  810.         s1r = str;
  811.         s1i = sti;
  812.         c1r = s2r * csr;
  813.         c1i = s2i * csr;
  814.         str = c1r;
  815.         sti = c1i;
  816.         c2r = yr[i];
  817.         c2i = yi[i];
  818.         if (*kode == 1) {
  819.             goto L70;
  820.         }
  821.         if (iuf < 0) {
  822.             goto L70;
  823.         }
  824.         zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
  825.         *nz += nw;
  826.         sc1r = sc2r;
  827.         sc1i = sc2i;
  828.         sc2r = c1r;
  829.         sc2i = c1i;
  830.         if (iuf != 3) {
  831.             goto L70;
  832.         }
  833.         iuf = -4;
  834.         s1r = sc1r * cssr[kflag - 1];
  835.         s1i = sc1i * cssr[kflag - 1];
  836.         s2r = sc2r * cssr[kflag - 1];
  837.         s2i = sc2i * cssr[kflag - 1];
  838.         str = sc2r;
  839.         sti = sc2i;
  840. L70:
  841.         ptr = cspnr * c1r - cspni * c1i;
  842.         pti = cspnr * c1i + cspni * c1r;
  843.         yr[i] = ptr + csgnr * c2r - csgni * c2i;
  844.         yi[i] = pti + csgnr * c2i + csgni * c2r;
  845.         ckr += rzr;
  846.         cki += rzi;
  847.         cspnr = -cspnr;
  848.         cspni = -cspni;
  849.         if (kflag >= 3) {
  850.             goto L80;
  851.         }
  852.         ptr = abs(c1r);
  853.         pti = abs(c1i);
  854.         c1m = max(ptr,pti);
  855.         if (c1m <= bscle) {
  856.             goto L80;
  857.         }
  858.         ++kflag;
  859.         bscle = bry[kflag - 1];
  860.         s1r *= csr;
  861.         s1i *= csr;
  862.         s2r = str;
  863.         s2i = sti;
  864.         s1r *= cssr[kflag - 1];
  865.         s1i *= cssr[kflag - 1];
  866.         s2r *= cssr[kflag - 1];
  867.         s2i *= cssr[kflag - 1];
  868.         csr = csrr[kflag - 1];
  869. L80:
  870.         ;
  871.     }
  872.     return 0;
  873. L90:
  874.     *nz = -1;
  875.     if (nw == -2) {
  876.         *nz = -2;
  877.     }
  878.     return 0;
  879. } /* zacon_ */
  880.  
  881. /* Subroutine */ int zairy_(doublereal *zr, doublereal *zi, integer *id, 
  882.         integer *kode, doublereal *air, doublereal *aii, integer *nz, integer 
  883.         *ierr)
  884. {
  885.     /* Initialized data */
  886.  
  887.     static doublereal tth = .666666666666666667;
  888.     static doublereal c1 = .35502805388781724;
  889.     static doublereal c2 = .258819403792806799;
  890.     static doublereal coef = .183776298473930683;
  891.     static doublereal zeror = 0.;
  892.     static doublereal zeroi = 0.;
  893.     static doublereal coner = 1.;
  894.     static doublereal conei = 0.;
  895.  
  896.     /* System generated locals */
  897.     integer i__1, i__2;
  898.     doublereal d__1;
  899.  
  900.     /* Builtin functions */
  901.     double log(doublereal), pow_dd(doublereal *, doublereal *), sqrt(
  902.             doublereal);
  903.  
  904.     /* Local variables */
  905.     static doublereal sfac, alim, elim, alaz, csqi, atrm, ztai, csqr, ztar;
  906.     extern /* Subroutine */ int zexp_(doublereal *, doublereal *, doublereal *
  907.             , doublereal *);
  908.     extern doublereal z1abs_(doublereal *, doublereal *);
  909.     static doublereal trm1i, trm2i, trm1r, trm2r;
  910.     static integer k, iflag;
  911.     extern /* Subroutine */ int zacai_(doublereal *, doublereal *, doublereal 
  912.             *, integer *, integer *, integer *, doublereal *, doublereal *, 
  913.             integer *, doublereal *, doublereal *, doublereal *, doublereal *)
  914.             ;
  915.     static doublereal d1, d2;
  916.     extern /* Subroutine */ int zbknu_(doublereal *, doublereal *, doublereal 
  917.             *, integer *, integer *, doublereal *, doublereal *, integer *, 
  918.             doublereal *, doublereal *, doublereal *);
  919.     static integer k1;
  920.     extern doublereal d1mach_(integer *);
  921.     static integer k2;
  922.     extern integer i1mach_(integer *);
  923.     extern /* Subroutine */ int zsqrt_(doublereal *, doublereal *, doublereal 
  924.             *, doublereal *);
  925.     static doublereal aa, bb, ad, cc, ak, bk, ck, dk, az;
  926.     static integer nn;
  927.     static doublereal rl;
  928.     static integer mr;
  929.     static doublereal s1i, az3, s2i, s1r, s2r, z3i, z3r, dig, fid, cyi[1], 
  930.             r1m5, fnu, cyr[1], tol, sti, ptr, str;
  931.  
  932. /* ***BEGIN PROLOGUE  ZAIRY */
  933. /* ***DATE WRITTEN   830501   (YYMMDD) */
  934. /* ***REVISION DATE  890801   (YYMMDD) */
  935. /* ***CATEGORY NO.  B5K */
  936. /* ***KEYWORDS  AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD */
  937. /* ***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES */
  938. /* ***PURPOSE  TO COMPUTE AIRY FUNCTIONS AI(Z) AND DAI(Z) FOR COMPLEX Z */
  939.  
  940. /* ***DESCRIPTION */
  941.  
  942. /*                      ***A DOUBLE PRECISION ROUTINE*** */
  943. /*         ON KODE=1, ZAIRY COMPUTES THE COMPLEX AIRY FUNCTION AI(Z) OR */
  944.  
  945. /*         ITS DERIVATIVE DAI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON */
  946. /*         KODE=2, A SCALING OPTION CEXP(ZTA)*AI(Z) OR CEXP(ZTA)* */
  947. /*         DAI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL DECAY IN */
  948. /*         -PI/3.LT.ARG(Z).LT.PI/3 AND THE EXPONENTIAL GROWTH IN */
  949. /*         PI/3.LT.ABS(ARG(Z)).LT.PI WHERE ZTA=(2/3)*Z*CSQRT(Z). */
  950.  
  951. /*         WHILE THE AIRY FUNCTIONS AI(Z) AND DAI(Z)/DZ ARE ANALYTIC IN */
  952.  
  953. /*         THE WHOLE Z PLANE, THE CORRESPONDING SCALED FUNCTIONS DEFINED 
  954. */
  955. /*         FOR KODE=2 HAVE A CUT ALONG THE NEGATIVE REAL AXIS. */
  956. /*         DEFINTIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF */
  957. /*         MATHEMATICAL FUNCTIONS (REF. 1). */
  958.  
  959. /*         INPUT      ZR,ZI ARE DOUBLE PRECISION */
  960. /*           ZR,ZI  - Z=CMPLX(ZR,ZI) */
  961. /*           ID     - ORDER OF DERIVATIVE, ID=0 OR ID=1 */
  962. /*           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION */
  963. /*                    KODE= 1  RETURNS */
  964. /*                             AI=AI(Z)                ON ID=0 OR */
  965. /*                             AI=DAI(Z)/DZ            ON ID=1 */
  966. /*                        = 2  RETURNS */
  967. /*                             AI=CEXP(ZTA)*AI(Z)       ON ID=0 OR */
  968. /*                             AI=CEXP(ZTA)*DAI(Z)/DZ   ON ID=1 WHERE */
  969. /*                             ZTA=(2/3)*Z*CSQRT(Z) */
  970.  
  971. /*         OUTPUT     AIR,AII ARE DOUBLE PRECISION */
  972. /*           AIR,AII- COMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND 
  973. */
  974. /*                    KODE */
  975. /*           NZ     - UNDERFLOW INDICATOR */
  976. /*                    NZ= 0   , NORMAL RETURN */
  977. /*                    NZ= 1   , AI=CMPLX(0.0D0,0.0D0) DUE TO UNDERFLOW IN 
  978. */
  979. /*                              -PI/3.LT.ARG(Z).LT.PI/3 ON KODE=1 */
  980. /*           IERR   - ERROR FLAG */
  981. /*                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED */
  982. /*                    IERR=1, INPUT ERROR   - NO COMPUTATION */
  983. /*                    IERR=2, OVERFLOW      - NO COMPUTATION, REAL(ZTA) */
  984.  
  985. /*                            TOO LARGE ON KODE=1 */
  986. /*                    IERR=3, CABS(Z) LARGE      - COMPUTATION COMPLETED 
  987. */
  988. /*                            LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION 
  989. */
  990. /*                            PRODUCE LESS THAN HALF OF MACHINE ACCURACY 
  991. */
  992. /*                    IERR=4, CABS(Z) TOO LARGE  - NO COMPUTATION */
  993. /*                            COMPLETE LOSS OF ACCURACY BY ARGUMENT */
  994. /*                            REDUCTION */
  995. /*                    IERR=5, ERROR              - NO COMPUTATION, */
  996. /*                            ALGORITHM TERMINATION CONDITION NOT MET */
  997.  
  998. /* ***LONG DESCRIPTION */
  999.  
  1000. /*         AI AND DAI ARE COMPUTED FOR CABS(Z).GT.1.0 FROM THE K BESSEL */
  1001.  
  1002. /*         FUNCTIONS BY */
  1003.  
  1004. /*            AI(Z)=C*SQRT(Z)*K(1/3,ZTA) , DAI(Z)=-C*Z*K(2/3,ZTA) */
  1005. /*                           C=1.0/(PI*SQRT(3.0)) */
  1006. /*                            ZTA=(2/3)*Z**(3/2) */
  1007.  
  1008. /*         WITH THE POWER SERIES FOR CABS(Z).LE.1.0. */
  1009.  
  1010. /*         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- */
  1011.  
  1012. /*         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES */
  1013. /*         OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF 
  1014. */
  1015. /*         THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR), */
  1016. /*         THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR */
  1017.  
  1018. /*         FLAG IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS 
  1019. */
  1020. /*         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. 
  1021. */
  1022. /*         ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN 
  1023. */
  1024. /*         ALL SIGNIFICANCE IS LOST AND IERR=4. IN ORDER TO USE THE INT */
  1025.  
  1026. /*         FUNCTION, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE */
  1027. /*         LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA */
  1028. /*         MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, */
  1029.  
  1030. /*         AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE */
  1031. /*         PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE */
  1032. /*         PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT- 
  1033. */
  1034. /*         ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG- 
  1035. */
  1036. /*         NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN */
  1037. /*         DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN */
  1038. /*         EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, */
  1039. /*         NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE */
  1040. /*         PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER */
  1041. /*         MACHINES. */
  1042.  
  1043. /*         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX */
  1044.  
  1045. /*         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT */
  1046.  
  1047. /*         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- */
  1048. /*         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE */
  1049.  
  1050. /*         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), */
  1051. /*         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF */
  1052.  
  1053. /*         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY 
  1054. */
  1055. /*         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN 
  1056. */
  1057. /*         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY 
  1058. */
  1059. /*         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER 
  1060. */
  1061. /*         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, 
  1062. */
  1063. /*         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS 
  1064. */
  1065. /*         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER 
  1066. */
  1067. /*         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY 
  1068. */
  1069. /*         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER */
  1070.  
  1071. /*         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE */
  1072. /*         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, */
  1073. /*         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, */
  1074.  
  1075. /*         OR -PI/2+P. */
  1076.  
  1077. /* ***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ */
  1078. /*                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF */
  1079. /*                 COMMERCE, 1955. */
  1080.  
  1081. /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
  1082. /*                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 
  1083. */
  1084.  
  1085. /*               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
  1086.  
  1087. /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- 
  1088. */
  1089. /*                 1018, MAY, 1985 */
  1090.  
  1091. /*               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
  1092. /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. */
  1093.  
  1094. /*                 MATH. SOFTWARE, 1986 */
  1095.  
  1096. /* ***ROUTINES CALLED  ZACAI,ZBKNU,ZEXP,ZSQRT,I1MACH,D1MACH */
  1097. /* ***END PROLOGUE  ZAIRY */
  1098. /*     COMPLEX AI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3 */
  1099. /* ***FIRST EXECUTABLE STATEMENT  ZAIRY */
  1100.     *ierr = 0;
  1101.     *nz = 0;
  1102.     if (*id < 0 || *id > 1) {
  1103.         *ierr = 1;
  1104.     }
  1105.     if (*kode < 1 || *kode > 2) {
  1106.         *ierr = 1;
  1107.     }
  1108.     if (*ierr != 0) {
  1109.         return 0;
  1110.     }
  1111.     az = z1abs_(zr, zi);
  1112. /* Computing MAX */
  1113.     d__1 = d1mach_(&c__4);
  1114.     tol = max(d__1,1e-18);
  1115.     fid = (doublereal) ((real) (*id));
  1116.     if (az > 1.) {
  1117.         goto L70;
  1118.     }
  1119. /* -----------------------------------------------------------------------
  1120.  */
  1121. /*     POWER SERIES FOR CABS(Z).LE.1. */
  1122. /* -----------------------------------------------------------------------
  1123.  */
  1124.     s1r = coner;
  1125.     s1i = conei;
  1126.     s2r = coner;
  1127.     s2i = conei;
  1128.     if (az < tol) {
  1129.         goto L170;
  1130.     }
  1131.     aa = az * az;
  1132.     if (aa < tol / az) {
  1133.         goto L40;
  1134.     }
  1135.     trm1r = coner;
  1136.     trm1i = conei;
  1137.     trm2r = coner;
  1138.     trm2i = conei;
  1139.     atrm = 1.;
  1140.     str = *zr * *zr - *zi * *zi;
  1141.     sti = *zr * *zi + *zi * *zr;
  1142.     z3r = str * *zr - sti * *zi;
  1143.     z3i = str * *zi + sti * *zr;
  1144.     az3 = az * aa;
  1145.     ak = fid + 2.;
  1146.     bk = 3. - fid - fid;
  1147.     ck = 4. - fid;
  1148.     dk = fid + 3. + fid;
  1149.     d1 = ak * dk;
  1150.     d2 = bk * ck;
  1151.     ad = min(d1,d2);
  1152.     ak = fid * 9. + 24.;
  1153.     bk = 30. - fid * 9.;
  1154.     for (k = 1; k <= 25; ++k) {
  1155.         str = (trm1r * z3r - trm1i * z3i) / d1;
  1156.         trm1i = (trm1r * z3i + trm1i * z3r) / d1;
  1157.         trm1r = str;
  1158.         s1r += trm1r;
  1159.         s1i += trm1i;
  1160.         str = (trm2r * z3r - trm2i * z3i) / d2;
  1161.         trm2i = (trm2r * z3i + trm2i * z3r) / d2;
  1162.         trm2r = str;
  1163.         s2r += trm2r;
  1164.         s2i += trm2i;
  1165.         atrm = atrm * az3 / ad;
  1166.         d1 += ak;
  1167.         d2 += bk;
  1168.         ad = min(d1,d2);
  1169.         if (atrm < tol * ad) {
  1170.             goto L40;
  1171.         }
  1172.         ak += 18.;
  1173.         bk += 18.;
  1174. /* L30: */
  1175.     }
  1176. L40:
  1177.     if (*id == 1) {
  1178.         goto L50;
  1179.     }
  1180.     *air = s1r * c1 - c2 * (*zr * s2r - *zi * s2i);
  1181.     *aii = s1i * c1 - c2 * (*zr * s2i + *zi * s2r);
  1182.     if (*kode == 1) {
  1183.         return 0;
  1184.     }
  1185.     zsqrt_(zr, zi, &str, &sti);
  1186.     ztar = tth * (*zr * str - *zi * sti);
  1187.     ztai = tth * (*zr * sti + *zi * str);
  1188.     zexp_(&ztar, &ztai, &str, &sti);
  1189.     ptr = *air * str - *aii * sti;
  1190.     *aii = *air * sti + *aii * str;
  1191.     *air = ptr;
  1192.     return 0;
  1193. L50:
  1194.     *air = -s2r * c2;
  1195.     *aii = -s2i * c2;
  1196.     if (az <= tol) {
  1197.         goto L60;
  1198.     }
  1199.     str = *zr * s1r - *zi * s1i;
  1200.     sti = *zr * s1i + *zi * s1r;
  1201.     cc = c1 / (fid + 1.);
  1202.     *air += cc * (str * *zr - sti * *zi);
  1203.     *aii += cc * (str * *zi + sti * *zr);
  1204. L60:
  1205.     if (*kode == 1) {
  1206.         return 0;
  1207.     }
  1208.     zsqrt_(zr, zi, &str, &sti);
  1209.     ztar = tth * (*zr * str - *zi * sti);
  1210.     ztai = tth * (*zr * sti + *zi * str);
  1211.     zexp_(&ztar, &ztai, &str, &sti);
  1212.     ptr = str * *air - sti * *aii;
  1213.     *aii = str * *aii + sti * *air;
  1214.     *air = ptr;
  1215.     return 0;
  1216. /* -----------------------------------------------------------------------
  1217.  */
  1218. /*     CASE FOR CABS(Z).GT.1.0 */
  1219. /* -----------------------------------------------------------------------
  1220.  */
  1221. L70:
  1222.     fnu = (fid + 1.) / 3.;
  1223. /* -----------------------------------------------------------------------
  1224.  */
  1225. /*     SET PARAMETERS RELATED TO MACHINE CONSTANTS. */
  1226. /*     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0D-18. */
  1227. /*     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. */
  1228. /*     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND */
  1229. /*     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR */
  1230. /*     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. */
  1231. /*     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. 
  1232. */
  1233. /*     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). */
  1234. /* -----------------------------------------------------------------------
  1235.  */
  1236.     k1 = i1mach_(&c__15);
  1237.     k2 = i1mach_(&c__16);
  1238.     r1m5 = d1mach_(&c__5);
  1239. /* Computing MIN */
  1240.     i__1 = abs(k1), i__2 = abs(k2);
  1241.     k = min(i__1,i__2);
  1242.     elim = ((doublereal) ((real) k) * r1m5 - 3.) * 2.303;
  1243.     k1 = i1mach_(&c__14) - 1;
  1244.     aa = r1m5 * (doublereal) ((real) k1);
  1245.     dig = min(aa,18.);
  1246.     aa *= 2.303;
  1247. /* Computing MAX */
  1248.     d__1 = -aa;
  1249.     alim = elim + max(d__1,-41.45);
  1250.     rl = dig * 1.2 + 3.;
  1251.     alaz = log(az);
  1252. /*-----------------------------------------------------------------------
  1253. ---*/
  1254. /*     TEST FOR PROPER RANGE */
  1255. /* -----------------------------------------------------------------------
  1256.  */
  1257.     aa = .5 / tol;
  1258.     bb = (doublereal) ((real) i1mach_(&c__9)) * .5;
  1259.     aa = min(aa,bb);
  1260.     aa = pow_dd(&aa, &tth);
  1261.     if (az > aa) {
  1262.         goto L260;
  1263.     }
  1264.     aa = sqrt(aa);
  1265.     if (az > aa) {
  1266.         *ierr = 3;
  1267.     }
  1268.     zsqrt_(zr, zi, &csqr, &csqi);
  1269.     ztar = tth * (*zr * csqr - *zi * csqi);
  1270.     ztai = tth * (*zr * csqi + *zi * csqr);
  1271. /* -----------------------------------------------------------------------
  1272.  */
  1273. /*     RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL */
  1274. /* -----------------------------------------------------------------------
  1275.  */
  1276.     iflag = 0;
  1277.     sfac = 1.;
  1278.     ak = ztai;
  1279.     if (*zr >= 0.) {
  1280.         goto L80;
  1281.     }
  1282.     bk = ztar;
  1283.     ck = -abs(bk);
  1284.     ztar = ck;
  1285.     ztai = ak;
  1286. L80:
  1287.     if (*zi != 0.) {
  1288.         goto L90;
  1289.     }
  1290.     if (*zr > 0.) {
  1291.         goto L90;
  1292.     }
  1293.     ztar = 0.;
  1294.     ztai = ak;
  1295. L90:
  1296.     aa = ztar;
  1297.     if (aa >= 0. && *zr > 0.) {
  1298.         goto L110;
  1299.     }
  1300.     if (*kode == 2) {
  1301.         goto L100;
  1302.     }
  1303. /* -----------------------------------------------------------------------
  1304.  */
  1305. /*     OVERFLOW TEST */
  1306. /* -----------------------------------------------------------------------
  1307.  */
  1308.     if (aa > -alim) {
  1309.         goto L100;
  1310.     }
  1311.     aa = -aa + alaz * .25;
  1312.     iflag = 1;
  1313.     sfac = tol;
  1314.     if (aa > elim) {
  1315.         goto L270;
  1316.     }
  1317. L100:
  1318. /* -----------------------------------------------------------------------
  1319.  */
  1320. /*     CBKNU AND CACON RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2 */
  1321. /* -----------------------------------------------------------------------
  1322.  */
  1323.     mr = 1;
  1324.     if (*zi < 0.) {
  1325.         mr = -1;
  1326.     }
  1327.     zacai_(&ztar, &ztai, &fnu, kode, &mr, &c__1, cyr, cyi, &nn, &rl, &tol, &
  1328.             elim, &alim);
  1329.     if (nn < 0) {
  1330.         goto L280;
  1331.     }
  1332.     *nz += nn;
  1333.     goto L130;
  1334. L110:
  1335.     if (*kode == 2) {
  1336.         goto L120;
  1337.     }
  1338. /* -----------------------------------------------------------------------
  1339.  */
  1340. /*     UNDERFLOW TEST */
  1341. /* -----------------------------------------------------------------------
  1342.  */
  1343.     if (aa < alim) {
  1344.         goto L120;
  1345.     }
  1346.     aa = -aa - alaz * .25;
  1347.     iflag = 2;
  1348.     sfac = 1. / tol;
  1349.     if (aa < -elim) {
  1350.         goto L210;
  1351.     }
  1352. L120:
  1353.     zbknu_(&ztar, &ztai, &fnu, kode, &c__1, cyr, cyi, nz, &tol, &elim, &alim);
  1354.  
  1355. L130:
  1356.     s1r = cyr[0] * coef;
  1357.     s1i = cyi[0] * coef;
  1358.     if (iflag != 0) {
  1359.         goto L150;
  1360.     }
  1361.     if (*id == 1) {
  1362.         goto L140;
  1363.     }
  1364.     *air = csqr * s1r - csqi * s1i;
  1365.     *aii = csqr * s1i + csqi * s1r;
  1366.     return 0;
  1367. L140:
  1368.     *air = -(*zr * s1r - *zi * s1i);
  1369.     *aii = -(*zr * s1i + *zi * s1r);
  1370.     return 0;
  1371. L150:
  1372.     s1r *= sfac;
  1373.     s1i *= sfac;
  1374.     if (*id == 1) {
  1375.         goto L160;
  1376.     }
  1377.     str = s1r * csqr - s1i * csqi;
  1378.     s1i = s1r * csqi + s1i * csqr;
  1379.     s1r = str;
  1380.     *air = s1r / sfac;
  1381.     *aii = s1i / sfac;
  1382.     return 0;
  1383. L160:
  1384.     str = -(s1r * *zr - s1i * *zi);
  1385.     s1i = -(s1r * *zi + s1i * *zr);
  1386.     s1r = str;
  1387.     *air = s1r / sfac;
  1388.     *aii = s1i / sfac;
  1389.     return 0;
  1390. L170:
  1391.     aa = d1mach_(&c__1) * 1e3;
  1392.     s1r = zeror;
  1393.     s1i = zeroi;
  1394.     if (*id == 1) {
  1395.         goto L190;
  1396.     }
  1397.     if (az <= aa) {
  1398.         goto L180;
  1399.     }
  1400.     s1r = c2 * *zr;
  1401.     s1i = c2 * *zi;
  1402. L180:
  1403.     *air = c1 - s1r;
  1404.     *aii = -s1i;
  1405.     return 0;
  1406. L190:
  1407.     *air = -c2;
  1408.     *aii = 0.;
  1409.     aa = sqrt(aa);
  1410.     if (az <= aa) {
  1411.         goto L200;
  1412.     }
  1413.     s1r = (*zr * *zr - *zi * *zi) * .5;
  1414.     s1i = *zr * *zi;
  1415. L200:
  1416.     *air += c1 * s1r;
  1417.     *aii += c1 * s1i;
  1418.     return 0;
  1419. L210:
  1420.     *nz = 1;
  1421.     *air = zeror;
  1422.     *aii = zeroi;
  1423.     return 0;
  1424. L270:
  1425.     *nz = 0;
  1426.     *ierr = 2;
  1427.     return 0;
  1428. L280:
  1429.     if (nn == -1) {
  1430.         goto L270;
  1431.     }
  1432.     *nz = 0;
  1433.     *ierr = 5;
  1434.     return 0;
  1435. L260:
  1436.     *ierr = 4;
  1437.     *nz = 0;
  1438.     return 0;
  1439. } /* zairy_ */
  1440.  
  1441. /* Subroutine */ int zasyi_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  1442.         integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
  1443.         nz, doublereal *rl, doublereal *tol, doublereal *elim, doublereal *
  1444.         alim)
  1445. {
  1446.     /* Initialized data */
  1447.  
  1448.     static doublereal pi = 3.14159265358979324;
  1449.     static doublereal rtpi = .159154943091895336;
  1450.     static doublereal zeror = 0.;
  1451.     static doublereal zeroi = 0.;
  1452.     static doublereal coner = 1.;
  1453.     static doublereal conei = 0.;
  1454.  
  1455.     /* System generated locals */
  1456.     integer i__1, i__2;
  1457.     doublereal d__1, d__2;
  1458.  
  1459.     /* Builtin functions */
  1460.     double sqrt(doublereal), sin(doublereal), cos(doublereal);
  1461.  
  1462.     /* Local variables */
  1463.     static doublereal dfnu, atol;
  1464.     extern /* Subroutine */ int zdiv_(doublereal *, doublereal *, doublereal *
  1465.             , doublereal *, doublereal *, doublereal *), zexp_(doublereal *, 
  1466.             doublereal *, doublereal *, doublereal *), zmlt_(doublereal *, 
  1467.             doublereal *, doublereal *, doublereal *, doublereal *, 
  1468.             doublereal *);
  1469.     extern doublereal z1abs_(doublereal *, doublereal *);
  1470.     static integer i, j, k, m;
  1471.     static doublereal s;
  1472.     static integer koded;
  1473.     extern doublereal d1mach_(integer *);
  1474.     extern /* Subroutine */ int zsqrt_(doublereal *, doublereal *, doublereal 
  1475.             *, doublereal *);
  1476.     static doublereal aa, bb;
  1477.     static integer ib;
  1478.     static doublereal ak, bk;
  1479.     static integer il, jl;
  1480.     static doublereal az;
  1481.     static integer nn;
  1482.     static doublereal p1i, s2i, p1r, s2r, cki, dki, fdn, arg, aez, arm, ckr, 
  1483.             dkr, czi, ezi, sgn;
  1484.     static integer inu;
  1485.     static doublereal raz, czr, ezr, sqk, sti, rzi, tzi, str, rzr, tzr, ak1i, 
  1486.             ak1r, cs1i, cs2i, cs1r, cs2r, dnu2, rtr1;
  1487.  
  1488. /* ***BEGIN PROLOGUE  ZASYI */
  1489. /* ***REFER TO  ZBESI,ZBESK */
  1490.  
  1491. /*     ZASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY */
  1492. /*     MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z) IN THE */
  1493. /*     REGION CABS(Z).GT.MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL RETURN. */
  1494. /*     NZ.LT.0 INDICATES AN OVERFLOW ON KODE=1. */
  1495.  
  1496. /* ***ROUTINES CALLED  D1MACH,Z1ABS,ZDIV,ZEXP,ZMLT,ZSQRT */
  1497. /* ***END PROLOGUE  ZASYI */
  1498. /*     COMPLEX AK1,CK,CONE,CS1,CS2,CZ,CZERO,DK,EZ,P1,RZ,S2,Y,Z */
  1499.     /* Parameter adjustments */
  1500.     --yi;
  1501.     --yr;
  1502.  
  1503.     /* Function Body */
  1504.  
  1505.     *nz = 0;
  1506.     az = z1abs_(zr, zi);
  1507.     arm = d1mach_(&c__1) * 1e3;
  1508.     rtr1 = sqrt(arm);
  1509.     il = min(2,*n);
  1510.     dfnu = *fnu + (doublereal) ((real) (*n - il));
  1511. /* -----------------------------------------------------------------------
  1512.  */
  1513. /*     OVERFLOW TEST */
  1514. /* -----------------------------------------------------------------------
  1515.  */
  1516.     raz = 1. / az;
  1517.     str = *zr * raz;
  1518.     sti = -(*zi) * raz;
  1519.     ak1r = rtpi * str * raz;
  1520.     ak1i = rtpi * sti * raz;
  1521.     zsqrt_(&ak1r, &ak1i, &ak1r, &ak1i);
  1522.     czr = *zr;
  1523.     czi = *zi;
  1524.     if (*kode != 2) {
  1525.         goto L10;
  1526.     }
  1527.     czr = zeror;
  1528.     czi = *zi;
  1529. L10:
  1530.     if (abs(czr) > *elim) {
  1531.         goto L100;
  1532.     }
  1533.     dnu2 = dfnu + dfnu;
  1534.     koded = 1;
  1535.     if (abs(czr) > *alim && *n > 2) {
  1536.         goto L20;
  1537.     }
  1538.     koded = 0;
  1539.     zexp_(&czr, &czi, &str, &sti);
  1540.     zmlt_(&ak1r, &ak1i, &str, &sti, &ak1r, &ak1i);
  1541. L20:
  1542.     fdn = 0.;
  1543.     if (dnu2 > rtr1) {
  1544.         fdn = dnu2 * dnu2;
  1545.     }
  1546.     ezr = *zr * 8.;
  1547.     ezi = *zi * 8.;
  1548. /* -----------------------------------------------------------------------
  1549.  */
  1550. /*     WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO THE */
  1551.  
  1552. /*     FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF THE */
  1553. /*     EXPANSION FOR THE IMAGINARY PART. */
  1554. /* -----------------------------------------------------------------------
  1555.  */
  1556.     aez = az * 8.;
  1557.     s = *tol / aez;
  1558.     jl = (integer) (*rl + *rl) + 2;
  1559.     p1r = zeror;
  1560.     p1i = zeroi;
  1561.     if (*zi == 0.) {
  1562.         goto L30;
  1563.     }
  1564. /* -----------------------------------------------------------------------
  1565.  */
  1566. /*     CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF */
  1567. /*     SIGNIFICANCE WHEN FNU OR N IS LARGE */
  1568. /* -----------------------------------------------------------------------
  1569.  */
  1570.     inu = (integer) (*fnu);
  1571.     arg = (*fnu - (doublereal) ((real) inu)) * pi;
  1572.     inu = inu + *n - il;
  1573.     ak = -sin(arg);
  1574.     bk = cos(arg);
  1575.     if (*zi < 0.) {
  1576.         bk = -bk;
  1577.     }
  1578.     p1r = ak;
  1579.     p1i = bk;
  1580.     if (inu % 2 == 0) {
  1581.         goto L30;
  1582.     }
  1583.     p1r = -p1r;
  1584.     p1i = -p1i;
  1585. L30:
  1586.     i__1 = il;
  1587.     for (k = 1; k <= i__1; ++k) {
  1588.         sqk = fdn - 1.;
  1589.         atol = s * abs(sqk);
  1590.         sgn = 1.;
  1591.         cs1r = coner;
  1592.         cs1i = conei;
  1593.         cs2r = coner;
  1594.         cs2i = conei;
  1595.         ckr = coner;
  1596.         cki = conei;
  1597.         ak = 0.;
  1598.         aa = 1.;
  1599.         bb = aez;
  1600.         dkr = ezr;
  1601.         dki = ezi;
  1602.         i__2 = jl;
  1603.         for (j = 1; j <= i__2; ++j) {
  1604.             zdiv_(&ckr, &cki, &dkr, &dki, &str, &sti);
  1605.             ckr = str * sqk;
  1606.             cki = sti * sqk;
  1607.             cs2r += ckr;
  1608.             cs2i += cki;
  1609.             sgn = -sgn;
  1610.             cs1r += ckr * sgn;
  1611.             cs1i += cki * sgn;
  1612.             dkr += ezr;
  1613.             dki += ezi;
  1614.             aa = aa * abs(sqk) / bb;
  1615.             bb += aez;
  1616.             ak += 8.;
  1617.             sqk -= ak;
  1618.             if (aa <= atol) {
  1619.                 goto L50;
  1620.             }
  1621. /* L40: */
  1622.         }
  1623.         goto L110;
  1624. L50:
  1625.         s2r = cs1r;
  1626.         s2i = cs1i;
  1627.         if (*zr + *zr >= *elim) {
  1628.             goto L60;
  1629.         }
  1630.         tzr = *zr + *zr;
  1631.         tzi = *zi + *zi;
  1632.         d__1 = -tzr;
  1633.         d__2 = -tzi;
  1634.         zexp_(&d__1, &d__2, &str, &sti);
  1635.         zmlt_(&str, &sti, &p1r, &p1i, &str, &sti);
  1636.         zmlt_(&str, &sti, &cs2r, &cs2i, &str, &sti);
  1637.         s2r += str;
  1638.         s2i += sti;
  1639. L60:
  1640.         fdn = fdn + dfnu * 8. + 4.;
  1641.         p1r = -p1r;
  1642.         p1i = -p1i;
  1643.         m = *n - il + k;
  1644.         yr[m] = s2r * ak1r - s2i * ak1i;
  1645.         yi[m] = s2r * ak1i + s2i * ak1r;
  1646. /* L70: */
  1647.     }
  1648.     if (*n <= 2) {
  1649.         return 0;
  1650.     }
  1651.     nn = *n;
  1652.     k = nn - 2;
  1653.     ak = (doublereal) ((real) k);
  1654.     str = *zr * raz;
  1655.     sti = -(*zi) * raz;
  1656.     rzr = (str + str) * raz;
  1657.     rzi = (sti + sti) * raz;
  1658.     ib = 3;
  1659.     i__1 = nn;
  1660.     for (i = ib; i <= i__1; ++i) {
  1661.         yr[k] = (ak + *fnu) * (rzr * yr[k + 1] - rzi * yi[k + 1]) + yr[k + 2];
  1662.  
  1663.         yi[k] = (ak + *fnu) * (rzr * yi[k + 1] + rzi * yr[k + 1]) + yi[k + 2];
  1664.  
  1665.         ak += -1.;
  1666.         --k;
  1667. /* L80: */
  1668.     }
  1669.     if (koded == 0) {
  1670.         return 0;
  1671.     }
  1672.     zexp_(&czr, &czi, &ckr, &cki);
  1673.     i__1 = nn;
  1674.     for (i = 1; i <= i__1; ++i) {
  1675.         str = yr[i] * ckr - yi[i] * cki;
  1676.         yi[i] = yr[i] * cki + yi[i] * ckr;
  1677.         yr[i] = str;
  1678. /* L90: */
  1679.     }
  1680.     return 0;
  1681. L100:
  1682.     *nz = -1;
  1683.     return 0;
  1684. L110:
  1685.     *nz = -2;
  1686.     return 0;
  1687. } /* zasyi_ */
  1688.  
  1689. /* funz2.f -- translated by f2c (version of 16 May 1991  13:06:06).
  1690.    You must link the resulting object file with the libraries:
  1691.         -link <S|C|M|L>f2c.lib   (in that order)
  1692. */
  1693.  
  1694.  
  1695.  
  1696. /* Table of constant values */
  1697. /*
  1698. static integer c__4 = 4;
  1699. static integer c__15 = 15;
  1700. static integer c__16 = 16;
  1701. static integer c__5 = 5;
  1702. static integer c__14 = 14;
  1703. static integer c__9 = 9;
  1704. static integer c__1 = 1;
  1705. static integer c__2 = 2;
  1706. */
  1707. /* Subroutine */ int zbesh_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  1708.         integer *kode, integer *m, integer *n, doublereal *cyr, doublereal *
  1709.         cyi, integer *nz, integer *ierr)
  1710. {
  1711.     /* Initialized data */
  1712.  
  1713.     static doublereal hpi = 1.57079632679489662;
  1714.  
  1715.     /* System generated locals */
  1716.     integer i__1, i__2;
  1717.     doublereal d__1, d__2;
  1718.  
  1719.     /* Builtin functions */
  1720.     double sqrt(doublereal), log(doublereal), d_sign(doublereal *, doublereal 
  1721.             *), cos(doublereal), sin(doublereal);
  1722.  
  1723.     /* Local variables */
  1724.     static doublereal alim, elim, atol, rhpi;
  1725.     static integer inuh;
  1726.     static doublereal fnul, rtol;
  1727.     extern doublereal z1abs_(doublereal *, doublereal *);
  1728.     static integer i, k;
  1729.     static doublereal ascle, csgni;
  1730.     extern /* Subroutine */ int zacon_(doublereal *, doublereal *, doublereal 
  1731.             *, integer *, integer *, integer *, doublereal *, doublereal *, 
  1732.             integer *, doublereal *, doublereal *, doublereal *, doublereal *,
  1733.              doublereal *);
  1734.     static doublereal csgnr;
  1735.     extern /* Subroutine */ int zbknu_(doublereal *, doublereal *, doublereal 
  1736.             *, integer *, integer *, doublereal *, doublereal *, integer *, 
  1737.             doublereal *, doublereal *, doublereal *), zbunk_(doublereal *, 
  1738.             doublereal *, doublereal *, integer *, integer *, integer *, 
  1739.             doublereal *, doublereal *, integer *, doublereal *, doublereal *,
  1740.              doublereal *);
  1741.     static integer k1;
  1742.     extern doublereal d1mach_(integer *);
  1743.     static integer k2;
  1744.     extern /* Subroutine */ int zuoik_(doublereal *, doublereal *, doublereal 
  1745.             *, integer *, integer *, integer *, doublereal *, doublereal *, 
  1746.             integer *, doublereal *, doublereal *, doublereal *);
  1747.     extern integer i1mach_(integer *);
  1748.     static doublereal aa, bb, fn;
  1749.     static integer mm;
  1750.     static doublereal az;
  1751.     static integer ir, nn;
  1752.     static doublereal rl;
  1753.     static integer mr, nw;
  1754.     static doublereal dig, arg, aln, fmm, r1m5, ufl, sgn;
  1755.     static integer nuf, inu;
  1756.     static doublereal tol, sti, zni, zti, str, znr;
  1757.  
  1758. /* ***BEGIN PROLOGUE  ZBESH */
  1759. /* ***DATE WRITTEN   830501   (YYMMDD) */
  1760. /* ***REVISION DATE  890801   (YYMMDD) */
  1761. /* ***CATEGORY NO.  B5K */
  1762. /* ***KEYWORDS  H-BESSEL FUNCTIONS,BESSEL FUNCTIONS OF COMPLEX ARGUMENT, 
  1763. */
  1764. /*             BESSEL FUNCTIONS OF THIRD KIND,HANKEL FUNCTIONS */
  1765. /* ***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES */
  1766. /* ***PURPOSE  TO COMPUTE THE H-BESSEL FUNCTIONS OF A COMPLEX ARGUMENT */
  1767. /* ***DESCRIPTION */
  1768.  
  1769. /*                      ***A DOUBLE PRECISION ROUTINE*** */
  1770. /*         ON KODE=1, ZBESH COMPUTES AN N MEMBER SEQUENCE OF COMPLEX */
  1771. /*         HANKEL (BESSEL) FUNCTIONS CY(J)=H(M,FNU+J-1,Z) FOR KINDS M=1 */
  1772.  
  1773. /*         OR 2, REAL, NONNEGATIVE ORDERS FNU+J-1, J=1,...,N, AND COMPLEX 
  1774. */
  1775. /*         Z.NE.CMPLX(0.0,0.0) IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI. */
  1776. /*         ON KODE=2, ZBESH RETURNS THE SCALED HANKEL FUNCTIONS */
  1777.  
  1778. /*         CY(I)=EXP(-MM*Z*I)*H(M,FNU+J-1,Z)       MM=3-2*M,   I**2=-1. */
  1779.  
  1780.  
  1781. /*         WHICH REMOVES THE EXPONENTIAL BEHAVIOR IN BOTH THE UPPER AND */
  1782.  
  1783. /*         LOWER HALF PLANES. DEFINITIONS AND NOTATION ARE FOUND IN THE */
  1784.  
  1785. /*         NBS HANDBOOK OF MATHEMATICAL FUNCTIONS (REF. 1). */
  1786.  
  1787. /*         INPUT      ZR,ZI,FNU ARE DOUBLE PRECISION */
  1788. /*           ZR,ZI  - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0), */
  1789. /*                    -PT.LT.ARG(Z).LE.PI */
  1790. /*           FNU    - ORDER OF INITIAL H FUNCTION, FNU.GE.0.0D0 */
  1791. /*           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION */
  1792. /*                    KODE= 1  RETURNS */
  1793. /*                             CY(J)=H(M,FNU+J-1,Z),   J=1,...,N */
  1794. /*                        = 2  RETURNS */
  1795. /*                             CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) */
  1796. /*                                  J=1,...,N  ,  I**2=-1 */
  1797. /*           M      - KIND OF HANKEL FUNCTION, M=1 OR 2 */
  1798. /*           N      - NUMBER OF MEMBERS IN THE SEQUENCE, N.GE.1 */
  1799.  
  1800. /*         OUTPUT     CYR,CYI ARE DOUBLE PRECISION */
  1801. /*           CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS */
  1802.  
  1803. /*                    CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE */
  1804.  
  1805. /*                    CY(J)=H(M,FNU+J-1,Z)  OR */
  1806. /*                    CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M))  J=1,...,N */
  1807. /*                    DEPENDING ON KODE, I**2=-1. */
  1808. /*           NZ     - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW, 
  1809. */
  1810. /*                    NZ= 0   , NORMAL RETURN */
  1811. /*                    NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO DUE 
  1812. */
  1813. /*                              TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0) */
  1814. /*                              J=1,...,NZ WHEN Y.GT.0.0 AND M=1 OR */
  1815. /*                              Y.LT.0.0 AND M=2. FOR THE COMPLMENTARY */
  1816. /*                              HALF PLANES, NZ STATES ONLY THE NUMBER */
  1817. /*                              OF UNDERFLOWS. */
  1818. /*           IERR   - ERROR FLAG */
  1819. /*                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED */
  1820. /*                    IERR=1, INPUT ERROR   - NO COMPUTATION */
  1821. /*                    IERR=2, OVERFLOW      - NO COMPUTATION, FNU TOO */
  1822. /*                            LARGE OR CABS(Z) TOO SMALL OR BOTH */
  1823. /*                    IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE 
  1824. */
  1825. /*                            BUT LOSSES OF SIGNIFCANCE BY ARGUMENT */
  1826. /*                            REDUCTION PRODUCE LESS THAN HALF OF MACHINE 
  1827. */
  1828. /*                            ACCURACY */
  1829. /*                    IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- 
  1830. */
  1831. /*                            TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- 
  1832. */
  1833. /*                            CANCE BY ARGUMENT REDUCTION */
  1834. /*                    IERR=5, ERROR              - NO COMPUTATION, */
  1835. /*                            ALGORITHM TERMINATION CONDITION NOT MET */
  1836.  
  1837. /* ***LONG DESCRIPTION */
  1838.  
  1839. /*         THE COMPUTATION IS CARRIED OUT BY THE RELATION */
  1840.  
  1841. /*         H(M,FNU,Z)=(1/MP)*EXP(-MP*FNU)*K(FNU,Z*EXP(-MP)) */
  1842. /*             MP=MM*HPI*I,  MM=3-2*M,  HPI=PI/2,  I**2=-1 */
  1843.  
  1844. /*         FOR M=1 OR 2 WHERE THE K BESSEL FUNCTION IS COMPUTED FOR THE */
  1845.  
  1846. /*         RIGHT HALF PLANE RE(Z).GE.0.0. THE K FUNCTION IS CONTINUED */
  1847. /*         TO THE LEFT HALF PLANE BY THE RELATION */
  1848.  
  1849. /*         K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z) */
  1850. /*         MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1 */
  1851.  
  1852. /*         WHERE I(FNU,Z) IS THE I BESSEL FUNCTION. */
  1853.  
  1854. /*         EXPONENTIAL DECAY OF H(M,FNU,Z) OCCURS IN THE UPPER HALF Z */
  1855. /*         PLANE FOR M=1 AND THE LOWER HALF Z PLANE FOR M=2.  EXPONENTIAL 
  1856. */
  1857. /*         GROWTH OCCURS IN THE COMPLEMENTARY HALF PLANES.  SCALING */
  1858. /*         BY EXP(-MM*Z*I) REMOVES THE EXPONENTIAL BEHAVIOR IN THE */
  1859. /*         WHOLE Z PLANE FOR Z TO INFINITY. */
  1860.  
  1861. /*         FOR NEGATIVE ORDERS,THE FORMULAE */
  1862.  
  1863. /*               H(1,-FNU,Z) = H(1,FNU,Z)*CEXP( PI*FNU*I) */
  1864. /*               H(2,-FNU,Z) = H(2,FNU,Z)*CEXP(-PI*FNU*I) */
  1865. /*                         I**2=-1 */
  1866.  
  1867. /*         CAN BE USED. */
  1868.  
  1869. /*         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- */
  1870.  
  1871. /*         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS */
  1872. /*         LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. */
  1873. /*         CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN */
  1874. /*         LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG */
  1875.  
  1876. /*         IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS */
  1877. /*         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. 
  1878. */
  1879. /*         IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS */
  1880.  
  1881. /*         LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS */
  1882.  
  1883. /*         MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE */
  1884.  
  1885. /*         INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS 
  1886. */
  1887. /*         RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 */
  1888. /*         ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION */
  1889.  
  1890. /*         ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION */
  1891. /*         ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN */
  1892. /*         THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT */
  1893.  
  1894. /*         TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS */
  1895. /*         IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. */
  1896. /*         SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. */
  1897.  
  1898. /*         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX */
  1899.  
  1900. /*         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT */
  1901.  
  1902. /*         ROUNDOFF,1.0D-18) IS THE NOMINAL PRECISION AND 10**S REPRE- */
  1903. /*         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE */
  1904.  
  1905. /*         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), */
  1906. /*         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF */
  1907.  
  1908. /*         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY 
  1909. */
  1910. /*         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN 
  1911. */
  1912. /*         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY 
  1913. */
  1914. /*         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER 
  1915. */
  1916. /*         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, 
  1917. */
  1918. /*         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS 
  1919. */
  1920. /*         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER 
  1921. */
  1922. /*         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY 
  1923. */
  1924. /*         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER */
  1925.  
  1926. /*         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE */
  1927. /*         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, */
  1928. /*         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, */
  1929.  
  1930. /*         OR -PI/2+P. */
  1931.  
  1932. /* ***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ */
  1933. /*                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF */
  1934. /*                 COMMERCE, 1955. */
  1935.  
  1936. /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
  1937. /*                 BY D. E. AMOS, SAND83-0083, MAY, 1983. */
  1938.  
  1939. /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
  1940. /*                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 
  1941. */
  1942.  
  1943. /*               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
  1944.  
  1945. /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- 
  1946. */
  1947. /*                 1018, MAY, 1985 */
  1948.  
  1949. /*               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
  1950. /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. */
  1951.  
  1952. /*                 MATH. SOFTWARE, 1986 */
  1953.  
  1954. /* ***ROUTINES CALLED  ZACON,ZBKNU,ZBUNK,ZUOIK,Z1ABS,I1MACH,D1MACH */
  1955. /* ***END PROLOGUE  ZBESH */
  1956.  
  1957. /*     COMPLEX CY,Z,ZN,ZT,CSGN */
  1958.  
  1959.     /* Parameter adjustments */
  1960.     --cyi;
  1961.     --cyr;
  1962.  
  1963.     /* Function Body */
  1964.  
  1965. /* ***FIRST EXECUTABLE STATEMENT  ZBESH */
  1966.     *ierr = 0;
  1967.     *nz = 0;
  1968.     if (*zr == 0. && *zi == 0.) {
  1969.         *ierr = 1;
  1970.     }
  1971.     if (*fnu < 0.) {
  1972.         *ierr = 1;
  1973.     }
  1974.     if (*m < 1 || *m > 2) {
  1975.         *ierr = 1;
  1976.     }
  1977.     if (*kode < 1 || *kode > 2) {
  1978.         *ierr = 1;
  1979.     }
  1980.     if (*n < 1) {
  1981.         *ierr = 1;
  1982.     }
  1983.     if (*ierr != 0) {
  1984.         return 0;
  1985.     }
  1986.     nn = *n;
  1987. /* -----------------------------------------------------------------------
  1988.  */
  1989. /*     SET PARAMETERS RELATED TO MACHINE CONSTANTS. */
  1990. /*     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. */
  1991. /*     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. */
  1992. /*     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND */
  1993. /*     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR */
  1994. /*     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. */
  1995. /*     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. 
  1996. */
  1997. /*     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). */
  1998. /*     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU 
  1999. */
  2000. /* -----------------------------------------------------------------------
  2001.  */
  2002. /* Computing MAX */
  2003.     d__1 = d1mach_(&c__4);
  2004.     tol = max(d__1,1e-18);
  2005.     k1 = i1mach_(&c__15);
  2006.     k2 = i1mach_(&c__16);
  2007.     r1m5 = d1mach_(&c__5);
  2008. /* Computing MIN */
  2009.     i__1 = abs(k1), i__2 = abs(k2);
  2010.     k = min(i__1,i__2);
  2011.     elim = ((doublereal) ((real) k) * r1m5 - 3.) * 2.303;
  2012.     k1 = i1mach_(&c__14) - 1;
  2013.     aa = r1m5 * (doublereal) ((real) k1);
  2014.     dig = min(aa,18.);
  2015.     aa *= 2.303;
  2016. /* Computing MAX */
  2017.     d__1 = -aa;
  2018.     alim = elim + max(d__1,-41.45);
  2019.     fnul = (dig - 3.) * 6. + 10.;
  2020.     rl = dig * 1.2 + 3.;
  2021.     fn = *fnu + (doublereal) ((real) (nn - 1));
  2022.     mm = 3 - *m - *m;
  2023.     fmm = (doublereal) ((real) mm);
  2024.     znr = fmm * *zi;
  2025.     zni = -fmm * *zr;
  2026. /* -----------------------------------------------------------------------
  2027.  */
  2028. /*     TEST FOR PROPER RANGE */
  2029. /* -----------------------------------------------------------------------
  2030.  */
  2031.     az = z1abs_(zr, zi);
  2032.     aa = .5 / tol;
  2033.     bb = (doublereal) ((real) i1mach_(&c__9)) * .5;
  2034.     aa = min(aa,bb);
  2035.     if (az > aa) {
  2036.         goto L260;
  2037.     }
  2038.     if (fn > aa) {
  2039.         goto L260;
  2040.     }
  2041.     aa = sqrt(aa);
  2042.     if (az > aa) {
  2043.         *ierr = 3;
  2044.     }
  2045.     if (fn > aa) {
  2046.         *ierr = 3;
  2047.     }
  2048. /* -----------------------------------------------------------------------
  2049.  */
  2050. /*     OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE */
  2051. /* -----------------------------------------------------------------------
  2052.  */
  2053.     ufl = d1mach_(&c__1) * 1e3;
  2054.     if (az < ufl) {
  2055.         goto L230;
  2056.     }
  2057.     if (*fnu > fnul) {
  2058.         goto L90;
  2059.     }
  2060.     if (fn <= 1.) {
  2061.         goto L70;
  2062.     }
  2063.     if (fn > 2.) {
  2064.         goto L60;
  2065.     }
  2066.     if (az > tol) {
  2067.         goto L70;
  2068.     }
  2069.     arg = az * .5;
  2070.     aln = -fn * log(arg);
  2071.     if (aln > elim) {
  2072.         goto L230;
  2073.     }
  2074.     goto L70;
  2075. L60:
  2076.     zuoik_(&znr, &zni, fnu, kode, &c__2, &nn, &cyr[1], &cyi[1], &nuf, &tol, &
  2077.             elim, &alim);
  2078.     if (nuf < 0) {
  2079.         goto L230;
  2080.     }
  2081.     *nz += nuf;
  2082.     nn -= nuf;
  2083. /* -----------------------------------------------------------------------
  2084.  */
  2085. /*     HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK */
  2086. /*     IF NUF=NN, THEN CY(I)=CZERO FOR ALL I */
  2087. /* -----------------------------------------------------------------------
  2088.  */
  2089.     if (nn == 0) {
  2090.         goto L140;
  2091.     }
  2092. L70:
  2093.     if (znr < 0. || znr == 0. && zni < 0. && *m == 2) {
  2094.         goto L80;
  2095.     }
  2096. /* -----------------------------------------------------------------------
  2097.  */
  2098. /*     RIGHT HALF PLANE COMPUTATION, XN.GE.0. .AND. (XN.NE.0. .OR. */
  2099. /*     YN.GE.0. .OR. M=1) */
  2100. /* -----------------------------------------------------------------------
  2101.  */
  2102.     zbknu_(&znr, &zni, fnu, kode, &nn, &cyr[1], &cyi[1], nz, &tol, &elim, &
  2103.             alim);
  2104.     goto L110;
  2105. /* -----------------------------------------------------------------------
  2106.  */
  2107. /*     LEFT HALF PLANE COMPUTATION */
  2108. /* -----------------------------------------------------------------------
  2109.  */
  2110. L80:
  2111.     mr = -mm;
  2112.     zacon_(&znr, &zni, fnu, kode, &mr, &nn, &cyr[1], &cyi[1], &nw, &rl, &fnul,
  2113.              &tol, &elim, &alim);
  2114.     if (nw < 0) {
  2115.         goto L240;
  2116.     }
  2117.     *nz = nw;
  2118.     goto L110;
  2119. L90:
  2120. /* -----------------------------------------------------------------------
  2121.  */
  2122. /*     UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL */
  2123. /* -----------------------------------------------------------------------
  2124.  */
  2125.     mr = 0;
  2126.     if (znr >= 0. && (znr != 0. || zni >= 0. || *m != 2)) {
  2127.         goto L100;
  2128.     }
  2129.     mr = -mm;
  2130.     if (znr != 0. || zni >= 0.) {
  2131.         goto L100;
  2132.     }
  2133.     znr = -znr;
  2134.     zni = -zni;
  2135. L100:
  2136.     zbunk_(&znr, &zni, fnu, kode, &mr, &nn, &cyr[1], &cyi[1], &nw, &tol, &
  2137.             elim, &alim);
  2138.     if (nw < 0) {
  2139.         goto L240;
  2140.     }
  2141.     *nz += nw;
  2142. L110:
  2143. /* -----------------------------------------------------------------------
  2144.  */
  2145. /*     H(M,FNU,Z) = -FMM*(I/HPI)*(ZT**FNU)*K(FNU,-Z*ZT) */
  2146.  
  2147. /*     ZT=EXP(-FMM*HPI*I) = CMPLX(0.0,-FMM), FMM=3-2*M, M=1,2 */
  2148. /* -----------------------------------------------------------------------
  2149.  */
  2150.     d__1 = -fmm;
  2151.     sgn = d_sign(&hpi, &d__1);
  2152. /* -----------------------------------------------------------------------
  2153.  */
  2154. /*     CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE */
  2155. /*     WHEN FNU IS LARGE */
  2156. /* -----------------------------------------------------------------------
  2157.  */
  2158.     inu = (integer) (*fnu);
  2159.     inuh = inu / 2;
  2160.     ir = inu - (inuh << 1);
  2161.     arg = (*fnu - (doublereal) ((real) (inu - ir))) * sgn;
  2162.     rhpi = 1. / sgn;
  2163. /*     ZNI = RHPI*DCOS(ARG) */
  2164. /*     ZNR = -RHPI*DSIN(ARG) */
  2165.     csgni = rhpi * cos(arg);
  2166.     csgnr = -rhpi * sin(arg);
  2167.     if (inuh % 2 == 0) {
  2168.         goto L120;
  2169.     }
  2170. /*     ZNR = -ZNR */
  2171. /*     ZNI = -ZNI */
  2172.     csgnr = -csgnr;
  2173.     csgni = -csgni;
  2174. L120:
  2175.     zti = -fmm;
  2176.     rtol = 1. / tol;
  2177.     ascle = ufl * rtol;
  2178.     i__1 = nn;
  2179.     for (i = 1; i <= i__1; ++i) {
  2180. /*       STR = CYR(I)*ZNR - CYI(I)*ZNI */
  2181. /*       CYI(I) = CYR(I)*ZNI + CYI(I)*ZNR */
  2182. /*       CYR(I) = STR */
  2183. /*       STR = -ZNI*ZTI */
  2184. /*       ZNI = ZNR*ZTI */
  2185. /*       ZNR = STR */
  2186.         aa = cyr[i];
  2187.         bb = cyi[i];
  2188.         atol = 1.;
  2189. /* Computing MAX */
  2190.         d__1 = abs(aa), d__2 = abs(bb);
  2191.         if (max(d__1,d__2) > ascle) {
  2192.             goto L135;
  2193.         }
  2194.         aa *= rtol;
  2195.         bb *= rtol;
  2196.         atol = tol;
  2197. L135:
  2198.         str = aa * csgnr - bb * csgni;
  2199.         sti = aa * csgni + bb * csgnr;
  2200.         cyr[i] = str * atol;
  2201.         cyi[i] = sti * atol;
  2202.         str = -csgni * zti;
  2203.         csgni = csgnr * zti;
  2204.         csgnr = str;
  2205. /* L130: */
  2206.     }
  2207.     return 0;
  2208. L140:
  2209.     if (znr < 0.) {
  2210.         goto L230;
  2211.     }
  2212.     return 0;
  2213. L230:
  2214.     *nz = 0;
  2215.     *ierr = 2;
  2216.     return 0;
  2217. L240:
  2218.     if (nw == -1) {
  2219.         goto L230;
  2220.     }
  2221.     *nz = 0;
  2222.     *ierr = 5;
  2223.     return 0;
  2224. L260:
  2225.     *nz = 0;
  2226.     *ierr = 4;
  2227.     return 0;
  2228. } /* zbesh_ */
  2229.  
  2230. /* Subroutine */ int zbesi_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  2231.         integer *kode, integer *n, doublereal *cyr, doublereal *cyi, integer *
  2232.         nz, integer *ierr)
  2233. {
  2234.     /* Initialized data */
  2235.  
  2236.     static doublereal pi = 3.14159265358979324;
  2237.     static doublereal coner = 1.;
  2238.     static doublereal conei = 0.;
  2239.  
  2240.     /* System generated locals */
  2241.     integer i__1, i__2;
  2242.     doublereal d__1, d__2;
  2243.  
  2244.     /* Builtin functions */
  2245.     double sqrt(doublereal), cos(doublereal), sin(doublereal);
  2246.  
  2247.     /* Local variables */
  2248.     static doublereal alim, elim, atol, fnul, rtol;
  2249.     extern doublereal z1abs_(doublereal *, doublereal *);
  2250.     static integer i, k;
  2251.     static doublereal ascle, csgni, csgnr;
  2252.     extern /* Subroutine */ int zbinu_(doublereal *, doublereal *, doublereal 
  2253.             *, integer *, integer *, doublereal *, doublereal *, integer *, 
  2254.             doublereal *, doublereal *, doublereal *, doublereal *, 
  2255.             doublereal *);
  2256.     static integer k1;
  2257.     extern doublereal d1mach_(integer *);
  2258.     static integer k2;
  2259.     extern integer i1mach_(integer *);
  2260.     static doublereal aa, bb, fn, az;
  2261.     static integer nn;
  2262.     static doublereal rl, dig, arg, r1m5;
  2263.     static integer inu;
  2264.     static doublereal tol, sti, zni, str, znr;
  2265.  
  2266. /* ***BEGIN PROLOGUE  ZBESI */
  2267. /* ***DATE WRITTEN   830501   (YYMMDD) */
  2268. /* ***REVISION DATE  890801   (YYMMDD) */
  2269. /* ***CATEGORY NO.  B5K */
  2270. /* ***KEYWORDS  I-BESSEL FUNCTION,COMPLEX BESSEL FUNCTION, */
  2271. /*         K(FNU,Z) DOMINATES IN MAGNITUDE WITH A LARGE POSITIVE POWER OF 
  2272. */
  2273. /*         TEN AND THE MOST THAT THE SECOND TERM CAN BE REDUCED IS BY */
  2274. /*         UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, WIDE CHANGES CAN */
  2275. /*         OCCUR WITHIN UNIT ROUNDOFF OF A LARGE INTEGER FOR FNU. HERE, */
  2276.  
  2277. /*         LARGE MEANS FNU.GT.CABS(Z). */
  2278.  
  2279. /*         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- */
  2280.  
  2281. /*         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS */
  2282. /*         LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. */
  2283. /*         CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN */
  2284. /*         LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG */
  2285.  
  2286. /*         IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS */
  2287. /*         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. 
  2288. */
  2289. /*         IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS */
  2290.  
  2291. /*         LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS */
  2292.  
  2293. /*         MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE */
  2294.  
  2295. /*         INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS 
  2296. */
  2297. /*         RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 */
  2298. /*         ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION */
  2299.  
  2300. /*         ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION */
  2301. /*         ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN */
  2302. /*         THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT */
  2303.  
  2304. /*         TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS */
  2305. /*         IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. */
  2306. /*         SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. */
  2307.  
  2308. /*         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX */
  2309.  
  2310. /*         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT */
  2311.  
  2312. /*         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- */
  2313. /*         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE */
  2314.  
  2315. /*         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), */
  2316. /*         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF */
  2317.  
  2318. /*         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY 
  2319. */
  2320. /*         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN 
  2321. */
  2322. /*         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY 
  2323. */
  2324. /*         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER 
  2325. */
  2326. /*         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, 
  2327. */
  2328. /*         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS 
  2329. */
  2330. /*         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER 
  2331. */
  2332. /*         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY 
  2333. */
  2334. /*         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER */
  2335.  
  2336. /*         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE */
  2337. /*         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, */
  2338. /*         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, */
  2339.  
  2340. /*         OR -PI/2+P. */
  2341.  
  2342. /* ***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ */
  2343. /*                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF */
  2344. /*                 COMMERCE, 1955. */
  2345.  
  2346. /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
  2347. /*                 BY D. E. AMOS, SAND83-0083, MAY, 1983. */
  2348.  
  2349. /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
  2350. /*                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 
  2351. */
  2352.  
  2353. /*               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
  2354.  
  2355. /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- 
  2356. */
  2357. /*                 1018, MAY, 1985 */
  2358.  
  2359. /*               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
  2360. /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. */
  2361.  
  2362. /*                 MATH. SOFTWARE, 1986 */
  2363.  
  2364. /* ***ROUTINES CALLED  ZBINU,I1MACH,D1MACH */
  2365. /* ***END PROLOGUE  ZBESI */
  2366. /*     COMPLEX CONE,CSGN,CW,CY,CZERO,Z,ZN */
  2367.     /* Parameter adjustments */
  2368.     --cyi;
  2369.     --cyr;
  2370.  
  2371.     /* Function Body */
  2372.  
  2373. /* ***FIRST EXECUTABLE STATEMENT  ZBESI */
  2374.     *ierr = 0;
  2375.     *nz = 0;
  2376.     if (*fnu < 0.) {
  2377.         *ierr = 1;
  2378.     }
  2379.     if (*kode < 1 || *kode > 2) {
  2380.         *ierr = 1;
  2381.     }
  2382.     if (*n < 1) {
  2383.         *ierr = 1;
  2384.     }
  2385.     if (*ierr != 0) {
  2386.         return 0;
  2387.     }
  2388. /* -----------------------------------------------------------------------
  2389.  */
  2390. /*     SET PARAMETERS RELATED TO MACHINE CONSTANTS. */
  2391. /*     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. */
  2392. /*     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. */
  2393. /*     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND */
  2394. /*     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR */
  2395. /*     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. */
  2396. /*     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. 
  2397. */
  2398. /*     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). */
  2399. /*     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. 
  2400. */
  2401. /* -----------------------------------------------------------------------
  2402.  */
  2403. /* Computing MAX */
  2404.     d__1 = d1mach_(&c__4);
  2405.     tol = max(d__1,1e-18);
  2406.     k1 = i1mach_(&c__15);
  2407.     k2 = i1mach_(&c__16);
  2408.     r1m5 = d1mach_(&c__5);
  2409. /* Computing MIN */
  2410.     i__1 = abs(k1), i__2 = abs(k2);
  2411.     k = min(i__1,i__2);
  2412.     elim = ((doublereal) ((real) k) * r1m5 - 3.) * 2.303;
  2413.     k1 = i1mach_(&c__14) - 1;
  2414.     aa = r1m5 * (doublereal) ((real) k1);
  2415.     dig = min(aa,18.);
  2416.     aa *= 2.303;
  2417. /* Computing MAX */
  2418.     d__1 = -aa;
  2419.     alim = elim + max(d__1,-41.45);
  2420.     rl = dig * 1.2 + 3.;
  2421.     fnul = (dig - 3.) * 6. + 10.;
  2422. /*-----------------------------------------------------------------------
  2423. ------*/
  2424. /*     TEST FOR PROPER RANGE */
  2425. /* -----------------------------------------------------------------------
  2426.  */
  2427.     az = z1abs_(zr, zi);
  2428.     fn = *fnu + (doublereal) ((real) (*n - 1));
  2429.     aa = .5 / tol;
  2430.     bb = (doublereal) ((real) i1mach_(&c__9)) * .5;
  2431.     aa = min(aa,bb);
  2432.     if (az > aa) {
  2433.         goto L260;
  2434.     }
  2435.     if (fn > aa) {
  2436.         goto L260;
  2437.     }
  2438.     aa = sqrt(aa);
  2439.     if (az > aa) {
  2440.         *ierr = 3;
  2441.     }
  2442.     if (fn > aa) {
  2443.         *ierr = 3;
  2444.     }
  2445.     znr = *zr;
  2446.     zni = *zi;
  2447.     csgnr = coner;
  2448.     csgni = conei;
  2449.     if (*zr >= 0.) {
  2450.         goto L40;
  2451.     }
  2452.     znr = -(*zr);
  2453.     zni = -(*zi);
  2454. /* -----------------------------------------------------------------------
  2455.  */
  2456. /*     CALCULATE CSGN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE */
  2457. /*     WHEN FNU IS LARGE */
  2458. /* -----------------------------------------------------------------------
  2459.  */
  2460.     inu = (integer) (*fnu);
  2461.     arg = (*fnu - (doublereal) ((real) inu)) * pi;
  2462.     if (*zi < 0.) {
  2463.         arg = -arg;
  2464.     }
  2465.     csgnr = cos(arg);
  2466.     csgni = sin(arg);
  2467.     if (inu % 2 == 0) {
  2468.         goto L40;
  2469.     }
  2470.     csgnr = -csgnr;
  2471.     csgni = -csgni;
  2472. L40:
  2473.     zbinu_(&znr, &zni, fnu, kode, n, &cyr[1], &cyi[1], nz, &rl, &fnul, &tol, &
  2474.             elim, &alim);
  2475.     if (*nz < 0) {
  2476.         goto L120;
  2477.     }
  2478.     if (*zr >= 0.) {
  2479.         return 0;
  2480.     }
  2481. /* -----------------------------------------------------------------------
  2482.  */
  2483. /*     ANALYTIC CONTINUATION TO THE LEFT HALF PLANE */
  2484. /* -----------------------------------------------------------------------
  2485.  */
  2486.     nn = *n - *nz;
  2487.     if (nn == 0) {
  2488.         return 0;
  2489.     }
  2490.     rtol = 1. / tol;
  2491.     ascle = d1mach_(&c__1) * rtol * 1e3;
  2492.     i__1 = nn;
  2493.     for (i = 1; i <= i__1; ++i) {
  2494. /*       STR = CYR(I)*CSGNR - CYI(I)*CSGNI */
  2495. /*       CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR */
  2496. /*       CYR(I) = STR */
  2497.         aa = cyr[i];
  2498.         bb = cyi[i];
  2499.         atol = 1.;
  2500. /* Computing MAX */
  2501.         d__1 = abs(aa), d__2 = abs(bb);
  2502.         if (max(d__1,d__2) > ascle) {
  2503.             goto L55;
  2504.         }
  2505.         aa *= rtol;
  2506.         bb *= rtol;
  2507.         atol = tol;
  2508. L55:
  2509.         str = aa * csgnr - bb * csgni;
  2510.         sti = aa * csgni + bb * csgnr;
  2511.         cyr[i] = str * atol;
  2512.         cyi[i] = sti * atol;
  2513.         csgnr = -csgnr;
  2514.         csgni = -csgni;
  2515. /* L50: */
  2516.     }
  2517.     return 0;
  2518. L120:
  2519.     if (*nz == -2) {
  2520.         goto L130;
  2521.     }
  2522.     *nz = 0;
  2523.     *ierr = 2;
  2524.     return 0;
  2525. L130:
  2526.     *nz = 0;
  2527.     *ierr = 5;
  2528.     return 0;
  2529. L260:
  2530.     *nz = 0;
  2531.     *ierr = 4;
  2532.     return 0;
  2533. } /* zbesi_ */
  2534.  
  2535. /* Subroutine */ int zbesj_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  2536.         integer *kode, integer *n, doublereal *cyr, doublereal *cyi, integer *
  2537.         nz, integer *ierr)
  2538. {
  2539.     /* Initialized data */
  2540.  
  2541.     static doublereal hpi = 1.57079632679489662;
  2542.  
  2543.     /* System generated locals */
  2544.     integer i__1, i__2;
  2545.     doublereal d__1, d__2;
  2546.  
  2547.     /* Builtin functions */
  2548.     double sqrt(doublereal), cos(doublereal), sin(doublereal);
  2549.  
  2550.     /* Local variables */
  2551.     static doublereal alim, elim, atol;
  2552.     static integer inuh;
  2553.     static doublereal fnul, rtol;
  2554.     extern doublereal z1abs_(doublereal *, doublereal *);
  2555.     static integer i, k;
  2556.     static doublereal ascle, csgni, csgnr;
  2557.     extern /* Subroutine */ int zbinu_(doublereal *, doublereal *, doublereal 
  2558.             *, integer *, integer *, doublereal *, doublereal *, integer *, 
  2559.             doublereal *, doublereal *, doublereal *, doublereal *, 
  2560.             doublereal *);
  2561.     static integer k1;
  2562.     extern doublereal d1mach_(integer *);
  2563.     static integer k2;
  2564.     extern integer i1mach_(integer *);
  2565.     static doublereal aa, bb, fn;
  2566.     static integer nl;
  2567.     static doublereal az;
  2568.     static integer ir;
  2569.     static doublereal rl, dig, cii, arg, r1m5;
  2570.     static integer inu;
  2571.     static doublereal tol, sti, zni, str, znr;
  2572.  
  2573. /* ***BEGIN PROLOGUE  ZBESJ */
  2574. /* ***DATE WRITTEN   830501   (YYMMDD) */
  2575. /* ***REVISION DATE  890801   (YYMMDD) */
  2576. /* ***CATEGORY NO.  B5K */
  2577. /*         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS */
  2578. /*         LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. */
  2579. /*         CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN */
  2580. /*         LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG */
  2581.  
  2582. /*         IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS */
  2583. /*         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. 
  2584. */
  2585. /*         IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS */
  2586.  
  2587. /*         LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS */
  2588.  
  2589. /*         MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE */
  2590.  
  2591. /*         INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS 
  2592. */
  2593. /*         RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 */
  2594. /*         ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION */
  2595.  
  2596. /*         ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION */
  2597. /*         ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN */
  2598. /*         THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT */
  2599.  
  2600. /*         TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS */
  2601. /*         IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. */
  2602. /*         SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. */
  2603.  
  2604. /*         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX */
  2605.  
  2606. /*         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT */
  2607.  
  2608. /*         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- */
  2609. /*         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE */
  2610.  
  2611. /*         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), */
  2612. /*         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF */
  2613.  
  2614. /*         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY 
  2615. */
  2616. /*         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN 
  2617. */
  2618. /*         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY 
  2619. */
  2620. /*         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER 
  2621. */
  2622. /*         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, 
  2623. */
  2624. /*         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS 
  2625. */
  2626. /*         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER 
  2627. */
  2628. /*         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY 
  2629. */
  2630. /*         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER */
  2631.  
  2632. /*         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE */
  2633. /*         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, */
  2634. /*         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, */
  2635.  
  2636. /*         OR -PI/2+P. */
  2637.  
  2638. /* ***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ */
  2639. /*                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF */
  2640. /*                 COMMERCE, 1955. */
  2641.  
  2642. /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
  2643. /*                 BY D. E. AMOS, SAND83-0083, MAY, 1983. */
  2644.  
  2645. /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
  2646. /*                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 
  2647. */
  2648.  
  2649. /*               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
  2650.  
  2651. /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- 
  2652. */
  2653. /*                 1018, MAY, 1985 */
  2654.  
  2655. /*               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
  2656. /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. */
  2657.  
  2658. /*                 MATH. SOFTWARE, 1986 */
  2659.  
  2660. /* ***ROUTINES CALLED  ZBINU,I1MACH,D1MACH */
  2661. /* ***END PROLOGUE  ZBESJ */
  2662.  
  2663. /*     COMPLEX CI,CSGN,CY,Z,ZN */
  2664.     /* Parameter adjustments */
  2665.     --cyi;
  2666.     --cyr;
  2667.  
  2668.     /* Function Body */
  2669.  
  2670. /* ***FIRST EXECUTABLE STATEMENT  ZBESJ */
  2671.     *ierr = 0;
  2672.     *nz = 0;
  2673.     if (*fnu < 0.) {
  2674.         *ierr = 1;
  2675.     }
  2676.     if (*kode < 1 || *kode > 2) {
  2677.         *ierr = 1;
  2678.     }
  2679.     if (*n < 1) {
  2680.         *ierr = 1;
  2681.     }
  2682.     if (*ierr != 0) {
  2683.         return 0;
  2684.     }
  2685. /* -----------------------------------------------------------------------
  2686.  */
  2687. /*     SET PARAMETERS RELATED TO MACHINE CONSTANTS. */
  2688. /*     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. */
  2689. /*     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. */
  2690. /*     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND */
  2691. /*     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR */
  2692. /*     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. */
  2693. /*     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. 
  2694. */
  2695. /*     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). */
  2696. /*     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. 
  2697. */
  2698. /* -----------------------------------------------------------------------
  2699.  */
  2700. /* Computing MAX */
  2701.     d__1 = d1mach_(&c__4);
  2702.     tol = max(d__1,1e-18);
  2703.     k1 = i1mach_(&c__15);
  2704.     k2 = i1mach_(&c__16);
  2705.     r1m5 = d1mach_(&c__5);
  2706. /* Computing MIN */
  2707.     i__1 = abs(k1), i__2 = abs(k2);
  2708.     k = min(i__1,i__2);
  2709.     elim = ((doublereal) ((real) k) * r1m5 - 3.) * 2.303;
  2710.     k1 = i1mach_(&c__14) - 1;
  2711.     aa = r1m5 * (doublereal) ((real) k1);
  2712.     dig = min(aa,18.);
  2713.     aa *= 2.303;
  2714. /* Computing MAX */
  2715.     d__1 = -aa;
  2716.     alim = elim + max(d__1,-41.45);
  2717.     rl = dig * 1.2 + 3.;
  2718.     fnul = (dig - 3.) * 6. + 10.;
  2719. /* -----------------------------------------------------------------------
  2720.  */
  2721. /*     TEST FOR PROPER RANGE */
  2722. /* -----------------------------------------------------------------------
  2723.  */
  2724.     az = z1abs_(zr, zi);
  2725.     fn = *fnu + (doublereal) ((real) (*n - 1));
  2726.     aa = .5 / tol;
  2727.     bb = (doublereal) ((real) i1mach_(&c__9)) * .5;
  2728.     aa = min(aa,bb);
  2729.     if (az > aa) {
  2730.         goto L260;
  2731.     }
  2732.     if (fn > aa) {
  2733.         goto L260;
  2734.     }
  2735.     aa = sqrt(aa);
  2736.     if (az > aa) {
  2737.         *ierr = 3;
  2738.     }
  2739.     if (fn > aa) {
  2740.         *ierr = 3;
  2741.     }
  2742. /* -----------------------------------------------------------------------
  2743.  */
  2744. /*     CALCULATE CSGN=EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE */
  2745.  
  2746. /*     WHEN FNU IS LARGE */
  2747. /* -----------------------------------------------------------------------
  2748.  */
  2749.     cii = 1.;
  2750.     inu = (integer) (*fnu);
  2751.     inuh = inu / 2;
  2752.     ir = inu - (inuh << 1);
  2753.     arg = (*fnu - (doublereal) ((real) (inu - ir))) * hpi;
  2754.     csgnr = cos(arg);
  2755.     csgni = sin(arg);
  2756.     if (inuh % 2 == 0) {
  2757.         goto L40;
  2758.     }
  2759.     csgnr = -csgnr;
  2760.     csgni = -csgni;
  2761. L40:
  2762. /* -----------------------------------------------------------------------
  2763.  */
  2764. /*     ZN IS IN THE RIGHT HALF PLANE */
  2765. /* -----------------------------------------------------------------------
  2766.  */
  2767.     znr = *zi;
  2768.     zni = -(*zr);
  2769.     if (*zi >= 0.) {
  2770.         goto L50;
  2771.     }
  2772.     znr = -znr;
  2773.     zni = -zni;
  2774.     csgni = -csgni;
  2775.     cii = -cii;
  2776. L50:
  2777.     zbinu_(&znr, &zni, fnu, kode, n, &cyr[1], &cyi[1], nz, &rl, &fnul, &tol, &
  2778.             elim, &alim);
  2779.     if (*nz < 0) {
  2780.         goto L130;
  2781.     }
  2782.     nl = *n - *nz;
  2783.     if (nl == 0) {
  2784.         return 0;
  2785.     }
  2786.     rtol = 1. / tol;
  2787.     ascle = d1mach_(&c__1) * rtol * 1e3;
  2788.     i__1 = nl;
  2789.     for (i = 1; i <= i__1; ++i) {
  2790. /*       STR = CYR(I)*CSGNR - CYI(I)*CSGNI */
  2791. /*       CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR */
  2792. /*       CYR(I) = STR */
  2793.         aa = cyr[i];
  2794.         bb = cyi[i];
  2795.         atol = 1.;
  2796. /* Computing MAX */
  2797.         d__1 = abs(aa), d__2 = abs(bb);
  2798.         if (max(d__1,d__2) > ascle) {
  2799.             goto L55;
  2800.         }
  2801.         aa *= rtol;
  2802.         bb *= rtol;
  2803.         atol = tol;
  2804. L55:
  2805.         str = aa * csgnr - bb * csgni;
  2806.         sti = aa * csgni + bb * csgnr;
  2807.         cyr[i] = str * atol;
  2808.         cyi[i] = sti * atol;
  2809.         str = -csgni * cii;
  2810.         csgni = csgnr * cii;
  2811.         csgnr = str;
  2812. /* L60: */
  2813.     }
  2814.     return 0;
  2815. L130:
  2816.     if (*nz == -2) {
  2817.         goto L140;
  2818.     }
  2819.     *nz = 0;
  2820.     *ierr = 2;
  2821.     return 0;
  2822. L140:
  2823.     *nz = 0;
  2824.     *ierr = 5;
  2825.     return 0;
  2826. L260:
  2827.     *nz = 0;
  2828.     *ierr = 4;
  2829.     return 0;
  2830. } /* zbesj_ */
  2831.  
  2832. /* Subroutine */ int zbesk_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  2833.         integer *kode, integer *n, doublereal *cyr, doublereal *cyi, integer *
  2834.         nz, integer *ierr)
  2835. {
  2836.     /* System generated locals */
  2837.     integer i__1, i__2;
  2838.     doublereal d__1;
  2839.  
  2840.     /* Builtin functions */
  2841.     double sqrt(doublereal), log(doublereal);
  2842.  
  2843.     /* Local variables */
  2844.     static doublereal alim, elim, fnul;
  2845.     extern doublereal z1abs_(doublereal *, doublereal *);
  2846.     static integer k;
  2847.     extern /* Subroutine */ int zacon_(doublereal *, doublereal *, doublereal 
  2848.             *, integer *, integer *, integer *, doublereal *, doublereal *, 
  2849.             integer *, doublereal *, doublereal *, doublereal *, doublereal *,
  2850.              doublereal *), zbknu_(doublereal *, doublereal *, doublereal *, 
  2851.             integer *, integer *, doublereal *, doublereal *, integer *, 
  2852.             doublereal *, doublereal *, doublereal *), zbunk_(doublereal *, 
  2853.             doublereal *, doublereal *, integer *, integer *, integer *, 
  2854.             doublereal *, doublereal *, integer *, doublereal *, doublereal *,
  2855.              doublereal *);
  2856.     static integer k1;
  2857.     extern doublereal d1mach_(integer *);
  2858.     static integer k2;
  2859.     extern /* Subroutine */ int zuoik_(doublereal *, doublereal *, doublereal 
  2860.             *, integer *, integer *, integer *, doublereal *, doublereal *, 
  2861.             integer *, doublereal *, doublereal *, doublereal *);
  2862.     extern integer i1mach_(integer *);
  2863.     static doublereal aa, bb, fn, az;
  2864.     static integer nn;
  2865.     static doublereal rl;
  2866.     static integer mr, nw;
  2867.     static doublereal dig, arg, aln, r1m5, ufl;
  2868.     static integer nuf;
  2869.     static doublereal tol;
  2870.  
  2871. /* ***BEGIN PROLOGUE  ZBESK */
  2872. /* ***DATE WRITTEN   830501   (YYMMDD) */
  2873. /* ***REVISION DATE  890801   (YYMMDD) */
  2874. /* ***CATEGORY NO.  B5K */
  2875. /*         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS */
  2876. /*         LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. */
  2877. /*         CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN */
  2878. /*         LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG */
  2879.  
  2880. /*         IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS */
  2881. /*         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. 
  2882. */
  2883. /*         IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS */
  2884.  
  2885. /*         LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS */
  2886.  
  2887. /*         MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE */
  2888.  
  2889. /*         INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS 
  2890. */
  2891. /*         RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 */
  2892. /*         ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION */
  2893.  
  2894. /*         ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION */
  2895. /*         ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN */
  2896. /*         THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT */
  2897.  
  2898. /*         TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS */
  2899. /*         IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. */
  2900. /*         SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. */
  2901.  
  2902. /*         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX */
  2903.  
  2904. /*         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT */
  2905.  
  2906. /*         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- */
  2907. /*         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE */
  2908.  
  2909. /*         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), */
  2910. /*         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF */
  2911.  
  2912. /*         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY 
  2913. */
  2914. /*         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN 
  2915. */
  2916. /*         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY 
  2917. */
  2918. /*         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER 
  2919. */
  2920. /*         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, 
  2921. */
  2922. /*         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS 
  2923. */
  2924. /*         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER 
  2925. */
  2926. /*         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY 
  2927. */
  2928. /*         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER */
  2929.  
  2930. /*         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE */
  2931. /*         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, */
  2932. /*         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, */
  2933.  
  2934. /*         OR -PI/2+P. */
  2935.  
  2936. /* ***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ */
  2937. /*                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF */
  2938. /*                 COMMERCE, 1955. */
  2939.  
  2940. /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
  2941. /*                 BY D. E. AMOS, SAND83-0083, MAY, 1983. */
  2942.  
  2943. /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
  2944. /*                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983. 
  2945. */
  2946.  
  2947. /*               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
  2948.  
  2949. /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- 
  2950. */
  2951. /*                 1018, MAY, 1985 */
  2952.  
  2953. /*               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
  2954. /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. */
  2955.  
  2956. /*                 MATH. SOFTWARE, 1986 */
  2957.  
  2958. /* ***ROUTINES CALLED  ZACON,ZBKNU,ZBUNK,ZUOIK,Z1ABS,I1MACH,D1MACH */
  2959. /* ***END PROLOGUE  ZBESK */
  2960.  
  2961. /*     COMPLEX CY,Z */
  2962. /* ***FIRST EXECUTABLE STATEMENT  ZBESK */
  2963.     /* Parameter adjustments */
  2964.     --cyi;
  2965.     --cyr;
  2966.  
  2967.     /* Function Body */
  2968.     *ierr = 0;
  2969.     *nz = 0;
  2970.     if (*zi == 0. && *zr == 0.) {
  2971.         *ierr = 1;
  2972.     }
  2973.     if (*fnu < 0.) {
  2974.         *ierr = 1;
  2975.     }
  2976.     if (*kode < 1 || *kode > 2) {
  2977.         *ierr = 1;
  2978.     }
  2979.     if (*n < 1) {
  2980.         *ierr = 1;
  2981.     }
  2982.     if (*ierr != 0) {
  2983.         return 0;
  2984.     }
  2985.     nn = *n;
  2986. /* -----------------------------------------------------------------------
  2987.  */
  2988. /*     SET PARAMETERS RELATED TO MACHINE CONSTANTS. */
  2989. /*     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. */
  2990. /*     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. */
  2991. /*     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND */
  2992. /*     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR */
  2993. /*     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. */
  2994. /*     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. 
  2995. */
  2996. /*     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). */
  2997. /*     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU 
  2998. */
  2999. /* -----------------------------------------------------------------------
  3000.  */
  3001. /* Computing MAX */
  3002.     d__1 = d1mach_(&c__4);
  3003.     tol = max(d__1,1e-18);
  3004.     k1 = i1mach_(&c__15);
  3005.     k2 = i1mach_(&c__16);
  3006.     r1m5 = d1mach_(&c__5);
  3007. /* Computing MIN */
  3008.     i__1 = abs(k1), i__2 = abs(k2);
  3009.     k = min(i__1,i__2);
  3010.     elim = ((doublereal) ((real) k) * r1m5 - 3.) * 2.303;
  3011.     k1 = i1mach_(&c__14) - 1;
  3012.     aa = r1m5 * (doublereal) ((real) k1);
  3013.     dig = min(aa,18.);
  3014.     aa *= 2.303;
  3015. /* Computing MAX */
  3016.     d__1 = -aa;
  3017.     alim = elim + max(d__1,-41.45);
  3018.     fnul = (dig - 3.) * 6. + 10.;
  3019.     rl = dig * 1.2 + 3.;
  3020. /*-----------------------------------------------------------------------
  3021. ------*/
  3022. /*     TEST FOR PROPER RANGE */
  3023. /* -----------------------------------------------------------------------
  3024.  */
  3025.     az = z1abs_(zr, zi);
  3026.     fn = *fnu + (doublereal) ((real) (nn - 1));
  3027.     aa = .5 / tol;
  3028.     bb = (doublereal) ((real) i1mach_(&c__9)) * .5;
  3029.     aa = min(aa,bb);
  3030.     if (az > aa) {
  3031.         goto L260;
  3032.     }
  3033.     if (fn > aa) {
  3034.         goto L260;
  3035.     }
  3036.     aa = sqrt(aa);
  3037.     if (az > aa) {
  3038.         *ierr = 3;
  3039.     }
  3040.     if (fn > aa) {
  3041.         *ierr = 3;
  3042.     }
  3043. /* -----------------------------------------------------------------------
  3044.  */
  3045. /*     OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE */
  3046. /* -----------------------------------------------------------------------
  3047.  */
  3048. /*     UFL = DEXP(-ELIM) */
  3049.     ufl = d1mach_(&c__1) * 1e3;
  3050.     if (az < ufl) {
  3051.         goto L180;
  3052.     }
  3053.     if (*fnu > fnul) {
  3054.         goto L80;
  3055.     }
  3056.     if (fn <= 1.) {
  3057.         goto L60;
  3058.     }
  3059.     if (fn > 2.) {
  3060.         goto L50;
  3061.     }
  3062.     if (az > tol) {
  3063.         goto L60;
  3064.     }
  3065.     arg = az * .5;
  3066.     aln = -fn * log(arg);
  3067.     if (aln > elim) {
  3068.         goto L180;
  3069.     }
  3070.     goto L60;
  3071. L50:
  3072.     zuoik_(zr, zi, fnu, kode, &c__2, &nn, &cyr[1], &cyi[1], &nuf, &tol, &elim,
  3073.              &alim);
  3074.     if (nuf < 0) {
  3075.         goto L180;
  3076.     }
  3077.     *nz += nuf;
  3078.     nn -= nuf;
  3079. /* -----------------------------------------------------------------------
  3080.  */
  3081. /*     HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK */
  3082. /*     IF NUF=NN, THEN CY(I)=CZERO FOR ALL I */
  3083. /* -----------------------------------------------------------------------
  3084.  */
  3085.     if (nn == 0) {
  3086.         goto L100;
  3087.     }
  3088. L60:
  3089.     if (*zr < 0.) {
  3090.         goto L70;
  3091.     }
  3092. /* -----------------------------------------------------------------------
  3093.  */
  3094. /*     RIGHT HALF PLANE COMPUTATION, REAL(Z).GE.0. */
  3095. /* -----------------------------------------------------------------------
  3096.  */
  3097.     zbknu_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, &tol, &elim, &alim);
  3098.  
  3099.     if (nw < 0) {
  3100.         goto L200;
  3101.     }
  3102.     *nz = nw;
  3103.     return 0;
  3104. /* -----------------------------------------------------------------------
  3105.  */
  3106. /*     LEFT HALF PLANE COMPUTATION */
  3107. /*     PI/2.LT.ARG(Z).LE.PI AND -PI.LT.ARG(Z).LT.-PI/2. */
  3108. /* -----------------------------------------------------------------------
  3109.  */
  3110. L70:
  3111.     if (*nz != 0) {
  3112.         goto L180;
  3113.     }
  3114.     mr = 1;
  3115.     if (*zi < 0.) {
  3116.         mr = -1;
  3117.     }
  3118.     zacon_(zr, zi, fnu, kode, &mr, &nn, &cyr[1], &cyi[1], &nw, &rl, &fnul, &
  3119.             tol, &elim, &alim);
  3120.     if (nw < 0) {
  3121.         goto L200;
  3122.     }
  3123.     *nz = nw;
  3124.     return 0;
  3125. /* -----------------------------------------------------------------------
  3126.  */
  3127. /*     UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL */
  3128. /* -----------------------------------------------------------------------
  3129.  */
  3130. L80:
  3131.     mr = 0;
  3132.     if (*zr >= 0.) {
  3133.         goto L90;
  3134.     }
  3135.     mr = 1;
  3136.     if (*zi < 0.) {
  3137.         mr = -1;
  3138.     }
  3139. L90:
  3140.     zbunk_(zr, zi, fnu, kode, &mr, &nn, &cyr[1], &cyi[1], &nw, &tol, &elim, &
  3141.             alim);
  3142.     if (nw < 0) {
  3143.         goto L200;
  3144.     }
  3145.     *nz += nw;
  3146.     return 0;
  3147. L100:
  3148.     if (*zr < 0.) {
  3149.         goto L180;
  3150.     }
  3151.     return 0;
  3152. L180:
  3153.     *nz = 0;
  3154.     *ierr = 2;
  3155.     return 0;
  3156. L200:
  3157.     if (nw == -1) {
  3158.         goto L180;
  3159.     }
  3160.     *nz = 0;
  3161.     *ierr = 5;
  3162.     return 0;
  3163. L260:
  3164.     *nz = 0;
  3165.     *ierr = 4;
  3166.     return 0;
  3167. } /* zbesk_ */
  3168.  
  3169. /* Subroutine */ int zbesy_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  3170.         integer *kode, integer *n, doublereal *cyr, doublereal *cyi, integer *
  3171.         nz, doublereal *cwrkr, doublereal *cwrki, integer *ierr)
  3172. {
  3173.     /* System generated locals */
  3174.     integer i__1, i__2;
  3175.     doublereal d__1, d__2;
  3176.  
  3177.     /* Builtin functions */
  3178.     double cos(doublereal), sin(doublereal), exp(doublereal);
  3179.  
  3180.     /* Local variables */
  3181.     static doublereal hcii, elim, atol, rtol;
  3182.     static integer i, k;
  3183.     static doublereal ascle;
  3184.     extern /* Subroutine */ int zbesh_(doublereal *, doublereal *, doublereal 
  3185.             *, integer *, integer *, integer *, doublereal *, doublereal *, 
  3186.             integer *, integer *);
  3187.     extern doublereal d1mach_(integer *);
  3188.     static integer k1, k2;
  3189.     extern integer i1mach_(integer *);
  3190.     static doublereal aa, bb, ey, c1i, c2i, c1r, c2r;
  3191.     static integer nz1, nz2;
  3192.     static doublereal exi;
  3193.     static real r1m5;
  3194.     static doublereal exr, sti, tay, tol, str;
  3195.  
  3196. /* ***BEGIN PROLOGUE  ZBESY */
  3197. /* ***DATE WRITTEN   830501   (YYMMDD) */
  3198. /* ***REVISION DATE  890801   (YYMMDD) */
  3199. /* ***CATEGORY NO.  B5K */
  3200. /* ***KEYWORDS  Y-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT, */
  3201. /*             BESSEL FUNCTION OF SECOND KIND */
  3202. /*         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- */
  3203.  
  3204. /*         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS */
  3205. /*         LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. */
  3206. /*         CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN */
  3207. /*         LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG */
  3208.  
  3209. /*         IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS */
  3210. /*         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. 
  3211. */
  3212. /*         IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS */
  3213.  
  3214. /*         LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS */
  3215.  
  3216. /*         MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE */
  3217.  
  3218. /*         INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS 
  3219. */
  3220. /*         RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 */
  3221. /*         ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION */
  3222.  
  3223. /*         ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION */
  3224. /*         ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN */
  3225. /*         THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT */
  3226.  
  3227. /*         TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS */
  3228. /*         IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. */
  3229. /*         SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. */
  3230.  
  3231. /*         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX */
  3232.  
  3233. /*         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT */
  3234.  
  3235. /*         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- */
  3236. /*         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE */
  3237.  
  3238. /*         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), */
  3239. /*         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF */
  3240.  
  3241. /*         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY 
  3242. */
  3243. /*         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN 
  3244. */
  3245. /*         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY 
  3246. */
  3247. /*         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER 
  3248. */
  3249. /*         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, 
  3250. */
  3251. /*         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS 
  3252. */
  3253. /*         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER 
  3254. */
  3255. /*         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY 
  3256. */
  3257. /*         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER */
  3258.  
  3259. /*         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE */
  3260. /*         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, */
  3261. /*         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, */
  3262.  
  3263. /*         OR -PI/2+P. */
  3264.  
  3265. /* ***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ */
  3266. /*                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF */
  3267. /*                 COMMERCE, 1955. */
  3268.  
  3269. /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
  3270. /*                 BY D. E. AMOS, SAND83-0083, MAY, 1983. */
  3271.  
  3272. /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
  3273. /*                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 
  3274. */
  3275.  
  3276. /*               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
  3277.  
  3278. /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- 
  3279. */
  3280. /*                 1018, MAY, 1985 */
  3281.  
  3282. /*               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
  3283. /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. */
  3284.  
  3285. /*                 MATH. SOFTWARE, 1986 */
  3286.  
  3287. /* ***ROUTINES CALLED  ZBESH,I1MACH,D1MACH */
  3288. /* ***END PROLOGUE  ZBESY */
  3289.  
  3290. /*     COMPLEX CWRK,CY,C1,C2,EX,HCI,Z,ZU,ZV */
  3291. /* ***FIRST EXECUTABLE STATEMENT  ZBESY */
  3292.     /* Parameter adjustments */
  3293.     --cwrki;
  3294.     --cwrkr;
  3295.     --cyi;
  3296.     --cyr;
  3297.  
  3298.     /* Function Body */
  3299.     *ierr = 0;
  3300.     *nz = 0;
  3301.     if (*zr == 0. && *zi == 0.) {
  3302.         *ierr = 1;
  3303.     }
  3304.     if (*fnu < 0.) {
  3305.         *ierr = 1;
  3306.     }
  3307.     if (*kode < 1 || *kode > 2) {
  3308.         *ierr = 1;
  3309.     }
  3310.     if (*n < 1) {
  3311.         *ierr = 1;
  3312.     }
  3313.     if (*ierr != 0) {
  3314.         return 0;
  3315.     }
  3316.     hcii = .5;
  3317.     zbesh_(zr, zi, fnu, kode, &c__1, n, &cyr[1], &cyi[1], &nz1, ierr);
  3318.     if (*ierr != 0 && *ierr != 3) {
  3319.         goto L170;
  3320.     }
  3321.     zbesh_(zr, zi, fnu, kode, &c__2, n, &cwrkr[1], &cwrki[1], &nz2, ierr);
  3322.     if (*ierr != 0 && *ierr != 3) {
  3323.         goto L170;
  3324.     }
  3325.     *nz = min(nz1,nz2);
  3326.     if (*kode == 2) {
  3327.         goto L60;
  3328.     }
  3329.     i__1 = *n;
  3330.     for (i = 1; i <= i__1; ++i) {
  3331.         str = cwrkr[i] - cyr[i];
  3332.         sti = cwrki[i] - cyi[i];
  3333.         cyr[i] = -sti * hcii;
  3334.         cyi[i] = str * hcii;
  3335. /* L50: */
  3336.     }
  3337.     return 0;
  3338. L60:
  3339. /* Computing MAX */
  3340.     d__1 = d1mach_(&c__4);
  3341.     tol = max(d__1,1e-18);
  3342.     k1 = i1mach_(&c__15);
  3343.     k2 = i1mach_(&c__16);
  3344. /* Computing MIN */
  3345.     i__1 = abs(k1), i__2 = abs(k2);
  3346.     k = min(i__1,i__2);
  3347.     r1m5 = d1mach_(&c__5);
  3348. /* -----------------------------------------------------------------------
  3349.  */
  3350. /*     ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT */
  3351. /* -----------------------------------------------------------------------
  3352.  */
  3353.     elim = ((doublereal) ((real) k) * r1m5 - 3.) * 2.303;
  3354.     exr = cos(*zr);
  3355.     exi = sin(*zr);
  3356.     ey = 0.;
  3357.     tay = (d__1 = *zi + *zi, abs(d__1));
  3358.     if (tay < elim) {
  3359.         ey = exp(-tay);
  3360.     }
  3361.     if (*zi < 0.) {
  3362.         goto L90;
  3363.     }
  3364.     c1r = exr * ey;
  3365.     c1i = exi * ey;
  3366.     c2r = exr;
  3367.     c2i = -exi;
  3368. L70:
  3369.     *nz = 0;
  3370.     rtol = 1. / tol;
  3371.     ascle = d1mach_(&c__1) * rtol * 1e3;
  3372.     i__1 = *n;
  3373.     for (i = 1; i <= i__1; ++i) {
  3374. /*       STR = C1R*CYR(I) - C1I*CYI(I) */
  3375. /*       STI = C1R*CYI(I) + C1I*CYR(I) */
  3376. /*       STR = -STR + C2R*CWRKR(I) - C2I*CWRKI(I) */
  3377. /*       STI = -STI + C2R*CWRKI(I) + C2I*CWRKR(I) */
  3378. /*       CYR(I) = -STI*HCII */
  3379. /*       CYI(I) = STR*HCII */
  3380.         aa = cwrkr[i];
  3381.         bb = cwrki[i];
  3382.         atol = 1.;
  3383. /* Computing MAX */
  3384.         d__1 = abs(aa), d__2 = abs(bb);
  3385.         if (max(d__1,d__2) > ascle) {
  3386.             goto L75;
  3387.         }
  3388.         aa *= rtol;
  3389.         bb *= rtol;
  3390.         atol = tol;
  3391. L75:
  3392.         str = (aa * c2r - bb * c2i) * atol;
  3393.         sti = (aa * c2i + bb * c2r) * atol;
  3394.         aa = cyr[i];
  3395.         bb = cyi[i];
  3396.         atol = 1.;
  3397. /* Computing MAX */
  3398.         d__1 = abs(aa), d__2 = abs(bb);
  3399.         if (max(d__1,d__2) > ascle) {
  3400.             goto L85;
  3401.         }
  3402.         aa *= rtol;
  3403.         bb *= rtol;
  3404.         atol = tol;
  3405. L85:
  3406.         str -= (aa * c1r - bb * c1i) * atol;
  3407.         sti -= (aa * c1i + bb * c1r) * atol;
  3408.         cyr[i] = -sti * hcii;
  3409.         cyi[i] = str * hcii;
  3410.         if (str == 0. && sti == 0. && ey == 0.) {
  3411.             ++(*nz);
  3412.         }
  3413. /* L80: */
  3414.     }
  3415.     return 0;
  3416. L90:
  3417.     c1r = exr;
  3418.     c1i = exi;
  3419.     c2r = exr * ey;
  3420.     c2i = -exi * ey;
  3421.     goto L70;
  3422. L170:
  3423.     *nz = 0;
  3424.     return 0;
  3425. } /* zbesy_ */
  3426.  
  3427. /* Subroutine */ int zbinu_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  3428.         integer *kode, integer *n, doublereal *cyr, doublereal *cyi, integer *
  3429.         nz, doublereal *rl, doublereal *fnul, doublereal *tol, doublereal *
  3430.         elim, doublereal *alim)
  3431. {
  3432.     /* Initialized data */
  3433.  
  3434.     static doublereal zeror = 0.;
  3435.     static doublereal zeroi = 0.;
  3436.  
  3437.     /* System generated locals */
  3438.     integer i__1;
  3439.  
  3440.     /* Local variables */
  3441.     static doublereal dfnu;
  3442.     extern doublereal z1abs_(doublereal *, doublereal *);
  3443.     static integer i, nlast;
  3444.     extern /* Subroutine */ int zbuni_(doublereal *, doublereal *, doublereal 
  3445.             *, integer *, integer *, doublereal *, doublereal *, integer *, 
  3446.             integer *, integer *, doublereal *, doublereal *, doublereal *, 
  3447.             doublereal *), zseri_(doublereal *, doublereal *, doublereal *, 
  3448.             integer *, integer *, doublereal *, doublereal *, integer *, 
  3449.             doublereal *, doublereal *, doublereal *), zmlri_(doublereal *, 
  3450.             doublereal *, doublereal *, integer *, integer *, doublereal *, 
  3451.             doublereal *, integer *, doublereal *), zasyi_(doublereal *, 
  3452.             doublereal *, doublereal *, integer *, integer *, doublereal *, 
  3453.             doublereal *, integer *, doublereal *, doublereal *, doublereal *,
  3454.              doublereal *), zuoik_(doublereal *, doublereal *, doublereal *, 
  3455.             integer *, integer *, integer *, doublereal *, doublereal *, 
  3456.             integer *, doublereal *, doublereal *, doublereal *), zwrsk_(
  3457.             doublereal *, doublereal *, doublereal *, integer *, integer *, 
  3458.             doublereal *, doublereal *, integer *, doublereal *, doublereal *,
  3459.              doublereal *, doublereal *, doublereal *);
  3460.     static doublereal az;
  3461.     static integer nn, nw;
  3462.     static doublereal cwi[2], cwr[2];
  3463.     static integer nui, inw;
  3464.  
  3465. /* ***BEGIN PROLOGUE  ZBINU */
  3466. /* ***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZAIRY,ZBIRY */
  3467.  
  3468. /*     ZBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE */
  3469.  
  3470. /* ***ROUTINES CALLED  Z1ABS,ZASYI,ZBUNI,ZMLRI,ZSERI,ZUOIK,ZWRSK */
  3471. /* ***END PROLOGUE  ZBINU */
  3472.     /* Parameter adjustments */
  3473.     --cyi;
  3474.     --cyr;
  3475.  
  3476.     /* Function Body */
  3477.  
  3478.     *nz = 0;
  3479.     az = z1abs_(zr, zi);
  3480.     nn = *n;
  3481.     dfnu = *fnu + (doublereal) ((real) (*n - 1));
  3482.     if (az <= 2.) {
  3483.         goto L10;
  3484.     }
  3485.     if (az * az * .25 > dfnu + 1.) {
  3486.         goto L20;
  3487.     }
  3488. L10:
  3489. /* -----------------------------------------------------------------------
  3490.  */
  3491. /*     POWER SERIES */
  3492. /* -----------------------------------------------------------------------
  3493.  */
  3494.     zseri_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, tol, elim, alim);
  3495.     inw = abs(nw);
  3496.     *nz += inw;
  3497.     nn -= inw;
  3498.     if (nn == 0) {
  3499.         return 0;
  3500.     }
  3501.     if (nw >= 0) {
  3502.         goto L120;
  3503.     }
  3504.     dfnu = *fnu + (doublereal) ((real) (nn - 1));
  3505. L20:
  3506.     if (az < *rl) {
  3507.         goto L40;
  3508.     }
  3509.     if (dfnu <= 1.) {
  3510.         goto L30;
  3511.     }
  3512.     if (az + az < dfnu * dfnu) {
  3513.         goto L50;
  3514.     }
  3515. /* -----------------------------------------------------------------------
  3516.  */
  3517. /*     ASYMPTOTIC EXPANSION FOR LARGE Z */
  3518. /* -----------------------------------------------------------------------
  3519.  */
  3520. L30:
  3521.     zasyi_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, rl, tol, elim, alim)
  3522.             ;
  3523.     if (nw < 0) {
  3524.         goto L130;
  3525.     }
  3526.     goto L120;
  3527. L40:
  3528.     if (dfnu <= 1.) {
  3529.         goto L70;
  3530.     }
  3531. L50:
  3532. /* -----------------------------------------------------------------------
  3533.  */
  3534. /*     OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM */
  3535. /* -----------------------------------------------------------------------
  3536.  */
  3537.     zuoik_(zr, zi, fnu, kode, &c__1, &nn, &cyr[1], &cyi[1], &nw, tol, elim, 
  3538.             alim);
  3539.     if (nw < 0) {
  3540.         goto L130;
  3541.     }
  3542.     *nz += nw;
  3543.     nn -= nw;
  3544.     if (nn == 0) {
  3545.         return 0;
  3546.     }
  3547.     dfnu = *fnu + (doublereal) ((real) (nn - 1));
  3548.     if (dfnu > *fnul) {
  3549.         goto L110;
  3550.     }
  3551.     if (az > *fnul) {
  3552.         goto L110;
  3553.     }
  3554. L60:
  3555.     if (az > *rl) {
  3556.         goto L80;
  3557.     }
  3558. L70:
  3559. /* -----------------------------------------------------------------------
  3560.  */
  3561. /*     MILLER ALGORITHM NORMALIZED BY THE SERIES */
  3562. /* -----------------------------------------------------------------------
  3563.  */
  3564.     zmlri_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, tol);
  3565.     if (nw < 0) {
  3566.         goto L130;
  3567.     }
  3568.     goto L120;
  3569. L80:
  3570. /* -----------------------------------------------------------------------
  3571.  */
  3572. /*     MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN */
  3573. /* -----------------------------------------------------------------------
  3574.  */
  3575. /* -----------------------------------------------------------------------
  3576.  */
  3577. /*     OVERFLOW TEST ON K FUNCTIONS USED IN WRONSKIAN */
  3578. /* -----------------------------------------------------------------------
  3579.  */
  3580.     zuoik_(zr, zi, fnu, kode, &c__2, &c__2, cwr, cwi, &nw, tol, elim, alim);
  3581.     if (nw >= 0) {
  3582.         goto L100;
  3583.     }
  3584.     *nz = nn;
  3585.     i__1 = nn;
  3586.     for (i = 1; i <= i__1; ++i) {
  3587.         cyr[i] = zeror;
  3588.         cyi[i] = zeroi;
  3589. /* L90: */
  3590.     }
  3591.     return 0;
  3592. L100:
  3593.     if (nw > 0) {
  3594.         goto L130;
  3595.     }
  3596.     zwrsk_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, cwr, cwi, tol, elim,
  3597.              alim);
  3598.     if (nw < 0) {
  3599.         goto L130;
  3600.     }
  3601.     goto L120;
  3602. L110:
  3603. /* -----------------------------------------------------------------------
  3604.  */
  3605. /*     INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD */
  3606. /* -----------------------------------------------------------------------
  3607.  */
  3608.     nui = (integer) (*fnul - dfnu) + 1;
  3609.     nui = max(nui,0);
  3610.     zbuni_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, &nui, &nlast, fnul, 
  3611.             tol, elim, alim);
  3612.     if (nw < 0) {
  3613.         goto L130;
  3614.     }
  3615.     *nz += nw;
  3616.     if (nlast == 0) {
  3617.         goto L120;
  3618.     }
  3619.     nn = nlast;
  3620.     goto L60;
  3621. L120:
  3622.     return 0;
  3623. L130:
  3624.     *nz = -1;
  3625.     if (nw == -2) {
  3626.         *nz = -2;
  3627.     }
  3628.     return 0;
  3629. } /* zbinu_ */
  3630.  
  3631. /* funz3.f -- translated by f2c (version of 16 May 1991  13:06:06).
  3632.    You must link the resulting object file with the libraries:
  3633.         -link <S|C|M|L>f2c.lib   (in that order)
  3634. */
  3635.  
  3636.  
  3637.  
  3638. /* Table of constant values */
  3639. /*
  3640. static integer c__4 = 4;
  3641. static integer c__15 = 15;
  3642. static integer c__16 = 16;
  3643. static integer c__5 = 5;
  3644. static integer c__14 = 14;
  3645. static integer c__9 = 9;
  3646. static integer c__1 = 1;
  3647. static integer c__2 = 2;
  3648. */
  3649. static doublereal c_b33 = .5;
  3650. static doublereal c_b34 = 0.;
  3651.  
  3652. /* Subroutine */ int zbiry_(doublereal *zr, doublereal *zi, integer *id, 
  3653.         integer *kode, doublereal *bir, doublereal *bii, integer *ierr)
  3654. {
  3655.     /* Initialized data */
  3656.  
  3657.     static doublereal tth = .666666666666666667;
  3658.     static doublereal c1 = .614926627446000736;
  3659.     static doublereal c2 = .448288357353826359;
  3660.     static doublereal coef = .577350269189625765;
  3661.     static doublereal pi = 3.14159265358979324;
  3662.     static doublereal coner = 1.;
  3663.     static doublereal conei = 0.;
  3664.  
  3665.     /* System generated locals */
  3666.     integer i__1, i__2;
  3667.     doublereal d__1;
  3668.  
  3669.     /* Builtin functions */
  3670.     double exp(doublereal), pow_dd(doublereal *, doublereal *), sqrt(
  3671.             doublereal), log(doublereal), cos(doublereal), sin(doublereal);
  3672.  
  3673.     /* Local variables */
  3674.     static doublereal sfac, alim, elim, csqi, atrm, fnul, ztai, csqr;
  3675.     extern /* Subroutine */ int zdiv_(doublereal *, doublereal *, doublereal *
  3676.             , doublereal *, doublereal *, doublereal *);
  3677.     static doublereal ztar;
  3678.     extern doublereal z1abs_(doublereal *, doublereal *);
  3679.     static doublereal trm1i, trm2i, trm1r, trm2r;
  3680.     static integer k;
  3681.     static doublereal d1, d2;
  3682.     extern /* Subroutine */ int zbinu_(doublereal *, doublereal *, doublereal 
  3683.             *, integer *, integer *, doublereal *, doublereal *, integer *, 
  3684.             doublereal *, doublereal *, doublereal *, doublereal *, 
  3685.             doublereal *);
  3686.     static integer k1;
  3687.     extern doublereal d1mach_(integer *);
  3688.     static integer k2;
  3689.     extern integer i1mach_(integer *);
  3690.     extern /* Subroutine */ int zsqrt_(doublereal *, doublereal *, doublereal 
  3691.             *, doublereal *);
  3692.     static doublereal aa, bb, ad, cc, ak, bk, ck, dk, az, rl;
  3693.     static integer nz;
  3694.     static doublereal s1i, az3, s2i, s1r, s2r, z3i, z3r, eaa, fid, dig, cyi[2]
  3695.             , fmr, r1m5, fnu, cyr[2], tol, sti, str;
  3696.  
  3697. /* ***BEGIN PROLOGUE  ZBIRY */
  3698. /* ***DATE WRITTEN   830501   (YYMMDD) */
  3699. /* ***REVISION DATE  890801   (YYMMDD) */
  3700. /* ***CATEGORY NO.  B5K */
  3701. /* ***KEYWORDS  AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD */
  3702. /* ***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES */
  3703. /* ***PURPOSE  TO COMPUTE AIRY FUNCTIONS BI(Z) AND DBI(Z) FOR COMPLEX Z */
  3704.  
  3705. /* ***DESCRIPTION */
  3706.  
  3707. /*                      ***A DOUBLE PRECISION ROUTINE*** */
  3708. /*         ON KODE=1, CBIRY COMPUTES THE COMPLEX AIRY FUNCTION BI(Z) OR */
  3709.  
  3710. /*         ITS DERIVATIVE DBI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON */
  3711. /*         KODE=2, A SCALING OPTION CEXP(-AXZTA)*BI(Z) OR CEXP(-AXZTA)* */
  3712.  
  3713. /*         DBI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL BEHAVIOR IN */
  3714. /*         BOTH THE LEFT AND RIGHT HALF PLANES WHERE */
  3715. /*         ZTA=(2/3)*Z*CSQRT(Z)=CMPLX(XZTA,YZTA) AND AXZTA=ABS(XZTA). */
  3716. /*         DEFINTIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF */
  3717. /*         MATHEMATICAL FUNCTIONS (REF. 1). */
  3718.  
  3719. /*         INPUT      ZR,ZI ARE DOUBLE PRECISION */
  3720. /*           ZR,ZI  - Z=CMPLX(ZR,ZI) */
  3721. /*           ID     - ORDER OF DERIVATIVE, ID=0 OR ID=1 */
  3722. /*           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION */
  3723. /*                    KODE= 1  RETURNS */
  3724. /*                             BI=BI(Z)                 ON ID=0 OR */
  3725. /*                             BI=DBI(Z)/DZ             ON ID=1 */
  3726. /*                        = 2  RETURNS */
  3727. /*                             BI=CEXP(-AXZTA)*BI(Z)     ON ID=0 OR */
  3728. /*                             BI=CEXP(-AXZTA)*DBI(Z)/DZ ON ID=1 WHERE */
  3729. /*                             ZTA=(2/3)*Z*CSQRT(Z)=CMPLX(XZTA,YZTA) */
  3730. /*                             AND AXZTA=ABS(XZTA) */
  3731.  
  3732. /*         OUTPUT     BIR,BII ARE DOUBLE PRECISION */
  3733. /*           BIR,BII- COMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND 
  3734. */
  3735. /*                    KODE */
  3736. /*           IERR   - ERROR FLAG */
  3737. /*                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED */
  3738. /*                    IERR=1, INPUT ERROR   - NO COMPUTATION */
  3739. /*                    IERR=2, OVERFLOW      - NO COMPUTATION, REAL(Z) */
  3740. /*                            TOO LARGE ON KODE=1 */
  3741. /*                    IERR=3, CABS(Z) LARGE      - COMPUTATION COMPLETED 
  3742. */
  3743. /*                            LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION 
  3744. */
  3745. /*                            PRODUCE LESS THAN HALF OF MACHINE ACCURACY 
  3746. */
  3747. /*                    IERR=4, CABS(Z) TOO LARGE  - NO COMPUTATION */
  3748. /*                            COMPLETE LOSS OF ACCURACY BY ARGUMENT */
  3749. /*                            REDUCTION */
  3750. /*                    IERR=5, ERROR              - NO COMPUTATION, */
  3751. /*                            ALGORITHM TERMINATION CONDITION NOT MET */
  3752.  
  3753. /* ***LONG DESCRIPTION */
  3754.  
  3755. /*         BI AND DBI ARE COMPUTED FOR CABS(Z).GT.1.0 FROM THE I BESSEL */
  3756.  
  3757. /*         FUNCTIONS BY */
  3758.  
  3759. /*                BI(Z)=C*SQRT(Z)*( I(-1/3,ZTA) + I(1/3,ZTA) ) */
  3760. /*               DBI(Z)=C *  Z  * ( I(-2/3,ZTA) + I(2/3,ZTA) ) */
  3761. /*                               C=1.0/SQRT(3.0) */
  3762. /*                             ZTA=(2/3)*Z**(3/2) */
  3763.  
  3764. /*         WITH THE POWER SERIES FOR CABS(Z).LE.1.0. */
  3765.  
  3766. /*         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- */
  3767.  
  3768. /*         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES */
  3769. /*         OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF 
  3770. */
  3771. /*         THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR), */
  3772. /*         THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR */
  3773.  
  3774. /*         FLAG IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS 
  3775. */
  3776. /*         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. 
  3777. */
  3778. /*         ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN 
  3779. */
  3780. /*         ALL SIGNIFICANCE IS LOST AND IERR=4. IN ORDER TO USE THE INT */
  3781.  
  3782. /*         FUNCTION, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE */
  3783. /*         LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA */
  3784. /*         MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, */
  3785.  
  3786. /*         AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE */
  3787. /*         PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE */
  3788. /*         PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT- 
  3789. */
  3790. /*         ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG- 
  3791. */
  3792. /*         NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN */
  3793. /*         DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN */
  3794. /*         EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, */
  3795. /*         NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE */
  3796. /*         PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER */
  3797. /*         MACHINES. */
  3798.  
  3799. /*         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX */
  3800.  
  3801. /*         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT */
  3802.  
  3803. /*         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- */
  3804. /*         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE */
  3805.  
  3806. /*         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), */
  3807. /*         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF */
  3808.  
  3809. /*         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY 
  3810. */
  3811. /*         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN 
  3812. */
  3813. /*         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY 
  3814. */
  3815. /*         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER 
  3816. */
  3817. /*         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, 
  3818. */
  3819. /*         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS 
  3820. */
  3821. /*         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER 
  3822. */
  3823. /*         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY 
  3824. */
  3825. /*         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER */
  3826.  
  3827. /*         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE */
  3828. /*         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, */
  3829. /*         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, */
  3830.  
  3831. /*         OR -PI/2+P. */
  3832.  
  3833. /* ***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ */
  3834. /*                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF */
  3835. /*                 COMMERCE, 1955. */
  3836.  
  3837. /*               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
  3838. /*                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 
  3839. */
  3840.  
  3841. /*               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
  3842.  
  3843. /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- 
  3844. */
  3845. /*                 1018, MAY, 1985 */
  3846.  
  3847. /*               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
  3848. /*                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. */
  3849.  
  3850. /*                 MATH. SOFTWARE, 1986 */
  3851.  
  3852. /* ***ROUTINES CALLED  ZBINU,Z1ABS,ZDIV,ZSQRT,D1MACH,I1MACH */
  3853. /* ***END PROLOGUE  ZBIRY */
  3854. /*     COMPLEX BI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3 */
  3855. /* ***FIRST EXECUTABLE STATEMENT  ZBIRY */
  3856.     *ierr = 0;
  3857.     nz = 0;
  3858.     if (*id < 0 || *id > 1) {
  3859.         *ierr = 1;
  3860.     }
  3861.     if (*kode < 1 || *kode > 2) {
  3862.         *ierr = 1;
  3863.     }
  3864.     if (*ierr != 0) {
  3865.         return 0;
  3866.     }
  3867.     az = z1abs_(zr, zi);
  3868. /* Computing MAX */
  3869.     d__1 = d1mach_(&c__4);
  3870.     tol = max(d__1,1e-18);
  3871.     fid = (doublereal) ((real) (*id));
  3872.     if (az > 1.) {
  3873.         goto L70;
  3874.     }
  3875. /* -----------------------------------------------------------------------
  3876.  */
  3877. /*     POWER SERIES FOR CABS(Z).LE.1. */
  3878. /* -----------------------------------------------------------------------
  3879.  */
  3880.     s1r = coner;
  3881.     s1i = conei;
  3882.     s2r = coner;
  3883.     s2i = conei;
  3884.     if (az < tol) {
  3885.         goto L130;
  3886.     }
  3887.     aa = az * az;
  3888.     if (aa < tol / az) {
  3889.         goto L40;
  3890.     }
  3891.     trm1r = coner;
  3892.     trm1i = conei;
  3893.     trm2r = coner;
  3894.     trm2i = conei;
  3895.     atrm = 1.;
  3896.     str = *zr * *zr - *zi * *zi;
  3897.     sti = *zr * *zi + *zi * *zr;
  3898.     z3r = str * *zr - sti * *zi;
  3899.     z3i = str * *zi + sti * *zr;
  3900.     az3 = az * aa;
  3901.     ak = fid + 2.;
  3902.     bk = 3. - fid - fid;
  3903.     ck = 4. - fid;
  3904.     dk = fid + 3. + fid;
  3905.     d1 = ak * dk;
  3906.     d2 = bk * ck;
  3907.     ad = min(d1,d2);
  3908.     ak = fid * 9. + 24.;
  3909.     bk = 30. - fid * 9.;
  3910.     for (k = 1; k <= 25; ++k) {
  3911.         str = (trm1r * z3r - trm1i * z3i) / d1;
  3912.         trm1i = (trm1r * z3i + trm1i * z3r) / d1;
  3913.         trm1r = str;
  3914.         s1r += trm1r;
  3915.         s1i += trm1i;
  3916.         str = (trm2r * z3r - trm2i * z3i) / d2;
  3917.         trm2i = (trm2r * z3i + trm2i * z3r) / d2;
  3918.         trm2r = str;
  3919.         s2r += trm2r;
  3920.         s2i += trm2i;
  3921.         atrm = atrm * az3 / ad;
  3922.         d1 += ak;
  3923.         d2 += bk;
  3924.         ad = min(d1,d2);
  3925.         if (atrm < tol * ad) {
  3926.             goto L40;
  3927.         }
  3928.         ak += 18.;
  3929.         bk += 18.;
  3930. /* L30: */
  3931.     }
  3932. L40:
  3933.     if (*id == 1) {
  3934.         goto L50;
  3935.     }
  3936.     *bir = c1 * s1r + c2 * (*zr * s2r - *zi * s2i);
  3937.     *bii = c1 * s1i + c2 * (*zr * s2i + *zi * s2r);
  3938.     if (*kode == 1) {
  3939.         return 0;
  3940.     }
  3941.     zsqrt_(zr, zi, &str, &sti);
  3942.     ztar = tth * (*zr * str - *zi * sti);
  3943.     ztai = tth * (*zr * sti + *zi * str);
  3944.     aa = ztar;
  3945.     aa = -abs(aa);
  3946.     eaa = exp(aa);
  3947.     *bir *= eaa;
  3948.     *bii *= eaa;
  3949.     return 0;
  3950. L50:
  3951.     *bir = s2r * c2;
  3952.     *bii = s2i * c2;
  3953.     if (az <= tol) {
  3954.         goto L60;
  3955.     }
  3956.     cc = c1 / (fid + 1.);
  3957.     str = s1r * *zr - s1i * *zi;
  3958.     sti = s1r * *zi + s1i * *zr;
  3959.     *bir += cc * (str * *zr - sti * *zi);
  3960.     *bii += cc * (str * *zi + sti * *zr);
  3961. L60:
  3962.     if (*kode == 1) {
  3963.         return 0;
  3964.     }
  3965.     zsqrt_(zr, zi, &str, &sti);
  3966.     ztar = tth * (*zr * str - *zi * sti);
  3967.     ztai = tth * (*zr * sti + *zi * str);
  3968.     aa = ztar;
  3969.     aa = -abs(aa);
  3970.     eaa = exp(aa);
  3971.     *bir *= eaa;
  3972.     *bii *= eaa;
  3973.     return 0;
  3974. /* -----------------------------------------------------------------------
  3975.  */
  3976. /*     CASE FOR CABS(Z).GT.1.0 */
  3977. /* -----------------------------------------------------------------------
  3978.  */
  3979. L70:
  3980.     fnu = (fid + 1.) / 3.;
  3981. /* -----------------------------------------------------------------------
  3982.  */
  3983. /*     SET PARAMETERS RELATED TO MACHINE CONSTANTS. */
  3984. /*     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. */
  3985. /*     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. */
  3986. /*     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND */
  3987. /*     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR */
  3988. /*     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. */
  3989. /*     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. 
  3990. */
  3991. /*     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). */
  3992. /*     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. 
  3993. */
  3994. /* -----------------------------------------------------------------------
  3995.  */
  3996.     k1 = i1mach_(&c__15);
  3997.     k2 = i1mach_(&c__16);
  3998.     r1m5 = d1mach_(&c__5);
  3999. /* Computing MIN */
  4000.     i__1 = abs(k1), i__2 = abs(k2);
  4001.     k = min(i__1,i__2);
  4002.     elim = ((doublereal) ((real) k) * r1m5 - 3.) * 2.303;
  4003.     k1 = i1mach_(&c__14) - 1;
  4004.     aa = r1m5 * (doublereal) ((real) k1);
  4005.     dig = min(aa,18.);
  4006.     aa *= 2.303;
  4007. /* Computing MAX */
  4008.     d__1 = -aa;
  4009.     alim = elim + max(d__1,-41.45);
  4010.     rl = dig * 1.2 + 3.;
  4011.     fnul = (dig - 3.) * 6. + 10.;
  4012. /* -----------------------------------------------------------------------
  4013.  */
  4014. /*     TEST FOR RANGE */
  4015. /* -----------------------------------------------------------------------
  4016.  */
  4017.     aa = .5 / tol;
  4018.     bb = (doublereal) ((real) i1mach_(&c__9)) * .5;
  4019.     aa = min(aa,bb);
  4020.     aa = pow_dd(&aa, &tth);
  4021.     if (az > aa) {
  4022.         goto L260;
  4023.     }
  4024.     aa = sqrt(aa);
  4025.     if (az > aa) {
  4026.         *ierr = 3;
  4027.     }
  4028.     zsqrt_(zr, zi, &csqr, &csqi);
  4029.     ztar = tth * (*zr * csqr - *zi * csqi);
  4030.     ztai = tth * (*zr * csqi + *zi * csqr);
  4031. /* -----------------------------------------------------------------------
  4032.  */
  4033. /*     RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL */
  4034. /* -----------------------------------------------------------------------
  4035.  */
  4036.     sfac = 1.;
  4037.     ak = ztai;
  4038.     if (*zr >= 0.) {
  4039.         goto L80;
  4040.     }
  4041.     bk = ztar;
  4042.     ck = -abs(bk);
  4043.     ztar = ck;
  4044.     ztai = ak;
  4045. L80:
  4046.     if (*zi != 0. || *zr > 0.) {
  4047.         goto L90;
  4048.     }
  4049.     ztar = 0.;
  4050.     ztai = ak;
  4051. L90:
  4052.     aa = ztar;
  4053.     if (*kode == 2) {
  4054.         goto L100;
  4055.     }
  4056. /* -----------------------------------------------------------------------
  4057.  */
  4058. /*     OVERFLOW TEST */
  4059. /* -----------------------------------------------------------------------
  4060.  */
  4061.     bb = abs(aa);
  4062.     if (bb < alim) {
  4063.         goto L100;
  4064.     }
  4065.     bb += log(az) * .25;
  4066.     sfac = tol;
  4067.     if (bb > elim) {
  4068.         goto L190;
  4069.     }
  4070. L100:
  4071.     fmr = 0.;
  4072.     if (aa >= 0. && *zr > 0.) {
  4073.         goto L110;
  4074.     }
  4075.     fmr = pi;
  4076.     if (*zi < 0.) {
  4077.         fmr = -pi;
  4078.     }
  4079.     ztar = -ztar;
  4080.     ztai = -ztai;
  4081. L110:
  4082. /* -----------------------------------------------------------------------
  4083.  */
  4084. /*     AA=FACTOR FOR ANALYTIC CONTINUATION OF I(FNU,ZTA) */
  4085. /*     KODE=2 RETURNS EXP(-ABS(XZTA))*I(FNU,ZTA) FROM CBESI */
  4086. /* -----------------------------------------------------------------------
  4087.  */
  4088.     zbinu_(&ztar, &ztai, &fnu, kode, &c__1, cyr, cyi, &nz, &rl, &fnul, &tol, &
  4089.             elim, &alim);
  4090.     if (nz < 0) {
  4091.         goto L200;
  4092.     }
  4093.     aa = fmr * fnu;
  4094.     z3r = sfac;
  4095.     str = cos(aa);
  4096.     sti = sin(aa);
  4097.     s1r = (str * cyr[0] - sti * cyi[0]) * z3r;
  4098.     s1i = (str * cyi[0] + sti * cyr[0]) * z3r;
  4099.     fnu = (2. - fid) / 3.;
  4100.     zbinu_(&ztar, &ztai, &fnu, kode, &c__2, cyr, cyi, &nz, &rl, &fnul, &tol, &
  4101.             elim, &alim);
  4102.     cyr[0] *= z3r;
  4103.     cyi[0] *= z3r;
  4104.     cyr[1] *= z3r;
  4105.     cyi[1] *= z3r;
  4106. /* -----------------------------------------------------------------------
  4107.  */
  4108. /*     BACKWARD RECUR ONE STEP FOR ORDERS -1/3 OR -2/3 */
  4109. /* -----------------------------------------------------------------------
  4110.  */
  4111.     zdiv_(cyr, cyi, &ztar, &ztai, &str, &sti);
  4112.     s2r = (fnu + fnu) * str + cyr[1];
  4113.     s2i = (fnu + fnu) * sti + cyi[1];
  4114.     aa = fmr * (fnu - 1.);
  4115.     str = cos(aa);
  4116.     sti = sin(aa);
  4117.     s1r = coef * (s1r + s2r * str - s2i * sti);
  4118.     s1i = coef * (s1i + s2r * sti + s2i * str);
  4119.     if (*id == 1) {
  4120.         goto L120;
  4121.     }
  4122.     str = csqr * s1r - csqi * s1i;
  4123.     s1i = csqr * s1i + csqi * s1r;
  4124.     s1r = str;
  4125.     *bir = s1r / sfac;
  4126.     *bii = s1i / sfac;
  4127.     return 0;
  4128. L120:
  4129.     str = *zr * s1r - *zi * s1i;
  4130.     s1i = *zr * s1i + *zi * s1r;
  4131.     s1r = str;
  4132.     *bir = s1r / sfac;
  4133.     *bii = s1i / sfac;
  4134.     return 0;
  4135. L130:
  4136.     aa = c1 * (1. - fid) + fid * c2;
  4137.     *bir = aa;
  4138.     *bii = 0.;
  4139.     return 0;
  4140. L190:
  4141.     *ierr = 2;
  4142.     nz = 0;
  4143.     return 0;
  4144. L200:
  4145.     if (nz == -1) {
  4146.         goto L190;
  4147.     }
  4148.     nz = 0;
  4149.     *ierr = 5;
  4150.     return 0;
  4151. L260:
  4152.     *ierr = 4;
  4153.     nz = 0;
  4154.     return 0;
  4155. } /* zbiry_ */
  4156.  
  4157. /* Subroutine */ int zbknu_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  4158.         integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
  4159.         nz, doublereal *tol, doublereal *elim, doublereal *alim)
  4160. {
  4161.     /* Initialized data */
  4162.  
  4163.     static integer kmax = 30;
  4164.     static doublereal czeror = 0.;
  4165.     static doublereal czeroi = 0.;
  4166.     static doublereal coner = 1.;
  4167.     static doublereal conei = 0.;
  4168.     static doublereal ctwor = 2.;
  4169.     static doublereal r1 = 2.;
  4170.     static doublereal dpi = 3.14159265358979324;
  4171.     static doublereal rthpi = 1.25331413731550025;
  4172.     static doublereal spi = 1.90985931710274403;
  4173.     static doublereal hpi = 1.57079632679489662;
  4174.     static doublereal fpi = 1.89769999331517738;
  4175.     static doublereal tth = .666666666666666666;
  4176.     static doublereal cc[8] = { .577215664901532861,-.0420026350340952355,
  4177.             -.0421977345555443367,.00721894324666309954,
  4178.             -2.15241674114950973e-4,-2.01348547807882387e-5,
  4179.             1.13302723198169588e-6,6.11609510448141582e-9 };
  4180.  
  4181.     /* System generated locals */
  4182.     integer i__1;
  4183.     doublereal d__1;
  4184.  
  4185.     /* Builtin functions */
  4186.     double sin(doublereal), exp(doublereal), cos(doublereal), atan(doublereal)
  4187.             , sqrt(doublereal), log(doublereal);
  4188.  
  4189.     /* Local variables */
  4190.     static doublereal cchi, cchr, alas, cshi;
  4191.     static integer inub, idum;
  4192.     static doublereal cshr, fmui, rcaz, csrr[3], cssr[3], fmur;
  4193.     extern /* Subroutine */ int zlog_(doublereal *, doublereal *, doublereal *
  4194.             , doublereal *, integer *);
  4195.     static doublereal smui;
  4196.     extern /* Subroutine */ int zdiv_(doublereal *, doublereal *, doublereal *
  4197.             , doublereal *, doublereal *, doublereal *);
  4198.     static doublereal smur;
  4199.     extern /* Subroutine */ int zexp_(doublereal *, doublereal *, doublereal *
  4200.             , doublereal *), zmlt_(doublereal *, doublereal *, doublereal *, 
  4201.             doublereal *, doublereal *, doublereal *);
  4202.     extern doublereal z1abs_(doublereal *, doublereal *);
  4203.     static integer i, j, k, iflag;
  4204.     static doublereal s;
  4205.     static integer kflag;
  4206.     static doublereal coefi;
  4207.     static integer koded;
  4208.     static doublereal ascle, coefr, helim, celmr, csclr, crscr;
  4209.     extern /* Subroutine */ int zshch_(doublereal *, doublereal *, doublereal 
  4210.             *, doublereal *, doublereal *, doublereal *);
  4211.     static doublereal a1, a2, etest;
  4212.     extern /* Subroutine */ int zuchk_(doublereal *, doublereal *, integer *, 
  4213.             doublereal *, doublereal *), zkscl_(doublereal *, doublereal *, 
  4214.             doublereal *, integer *, doublereal *, doublereal *, integer *, 
  4215.             doublereal *, doublereal *, doublereal *, doublereal *, 
  4216.             doublereal *);
  4217.     static doublereal g1, g2;
  4218.     extern doublereal d1mach_(integer *);
  4219.     extern integer i1mach_(integer *);
  4220.     static doublereal t1, t2;
  4221.     extern /* Subroutine */ int zsqrt_(doublereal *, doublereal *, doublereal 
  4222.             *, doublereal *);
  4223.     static doublereal aa, bb, fc, ak, bk;
  4224.     static integer ic;
  4225.     static doublereal fi, fk, as;
  4226.     static integer kk;
  4227.     static doublereal fr, pi, qi, tm, pr, qr;
  4228.     extern doublereal dgamln_(doublereal *, integer *);
  4229.     static integer nw;
  4230.     static doublereal p1i, p2i, s1i, s2i, p2m, p1r, p2r, s1r, s2r, cbi, cbr, 
  4231.             cki, caz, csi, ckr, fhs, fks, rak, czi, dnu, csr, elm, zdi, bry[3]
  4232.             , pti, czr, sti, zdr, cyr[2], rzi, ptr, cyi[2];
  4233.     static integer inu;
  4234.     static doublereal str, rzr, dnu2;
  4235.  
  4236. /* ***BEGIN PROLOGUE  ZBKNU */
  4237. /* ***REFER TO  ZBESI,ZBESK,ZAIRY,ZBESH */
  4238.  
  4239. /*     ZBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE. */
  4240.  
  4241. /* ***ROUTINES CALLED  DGAMLN,I1MACH,D1MACH,ZKSCL,ZSHCH,ZUCHK,Z1ABS,ZDIV, 
  4242. */
  4243. /*                    ZEXP,ZLOG,ZMLT,ZSQRT */
  4244. /* ***END PROLOGUE  ZBKNU */
  4245.  
  4246. /*     COMPLEX Z,Y,A,B,RZ,SMU,FU,FMU,F,FLRZ,CZ,S1,S2,CSH,CCH */
  4247. /*     COMPLEX CK,P,Q,COEF,P1,P2,CBK,PT,CZERO,CONE,CTWO,ST,EZ,CS,DK */
  4248.  
  4249.     /* Parameter adjustments */
  4250.     --yi;
  4251.     --yr;
  4252.  
  4253.     /* Function Body */
  4254.  
  4255.     caz = z1abs_(zr, zi);
  4256.     csclr = 1. / *tol;
  4257.     crscr = *tol;
  4258.     cssr[0] = csclr;
  4259.     cssr[1] = 1.;
  4260.     cssr[2] = crscr;
  4261.     csrr[0] = crscr;
  4262.     csrr[1] = 1.;
  4263.     csrr[2] = csclr;
  4264.     bry[0] = d1mach_(&c__1) * 1e3 / *tol;
  4265.     bry[1] = 1. / bry[0];
  4266.     bry[2] = d1mach_(&c__2);
  4267.     *nz = 0;
  4268.     iflag = 0;
  4269.     koded = *kode;
  4270.     rcaz = 1. / caz;
  4271.     str = *zr * rcaz;
  4272.     sti = -(*zi) * rcaz;
  4273.     rzr = (str + str) * rcaz;
  4274.     rzi = (sti + sti) * rcaz;
  4275.     inu = (integer) (*fnu + .5);
  4276.     dnu = *fnu - (doublereal) ((real) inu);
  4277.     if (abs(dnu) == .5) {
  4278.         goto L110;
  4279.     }
  4280.     dnu2 = 0.;
  4281.     if (abs(dnu) > *tol) {
  4282.         dnu2 = dnu * dnu;
  4283.     }
  4284.     if (caz > r1) {
  4285.         goto L110;
  4286.     }
  4287. /* -----------------------------------------------------------------------
  4288.  */
  4289. /*     SERIES FOR CABS(Z).LE.R1 */
  4290. /* -----------------------------------------------------------------------
  4291.  */
  4292.     fc = 1.;
  4293.     zlog_(&rzr, &rzi, &smur, &smui, &idum);
  4294.     fmur = smur * dnu;
  4295.     fmui = smui * dnu;
  4296.     zshch_(&fmur, &fmui, &cshr, &cshi, &cchr, &cchi);
  4297.     if (dnu == 0.) {
  4298.         goto L10;
  4299.     }
  4300.     fc = dnu * dpi;
  4301.     fc /= sin(fc);
  4302.     smur = cshr / dnu;
  4303.     smui = cshi / dnu;
  4304. L10:
  4305.     a2 = dnu + 1.;
  4306. /* -----------------------------------------------------------------------
  4307.  */
  4308. /*     GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU), T2=1/GAM(1+DNU) 
  4309. */
  4310. /* -----------------------------------------------------------------------
  4311.  */
  4312.     t2 = exp(-dgamln_(&a2, &idum));
  4313.     t1 = 1. / (t2 * fc);
  4314.     if (abs(dnu) > .1) {
  4315.         goto L40;
  4316.     }
  4317. /* -----------------------------------------------------------------------
  4318.  */
  4319. /*     SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) */
  4320. /* -----------------------------------------------------------------------
  4321.  */
  4322.     ak = 1.;
  4323.     s = cc[0];
  4324.     for (k = 2; k <= 8; ++k) {
  4325.         ak *= dnu2;
  4326.         tm = cc[k - 1] * ak;
  4327.         s += tm;
  4328.         if (abs(tm) < *tol) {
  4329.             goto L30;
  4330.         }
  4331. /* L20: */
  4332.     }
  4333. L30:
  4334.     g1 = -s;
  4335.     goto L50;
  4336. L40:
  4337.     g1 = (t1 - t2) / (dnu + dnu);
  4338. L50:
  4339.     g2 = (t1 + t2) * .5;
  4340.     fr = fc * (cchr * g1 + smur * g2);
  4341.     fi = fc * (cchi * g1 + smui * g2);
  4342.     zexp_(&fmur, &fmui, &str, &sti);
  4343.     pr = str * .5 / t2;
  4344.     pi = sti * .5 / t2;
  4345.     zdiv_(&c_b33, &c_b34, &str, &sti, &ptr, &pti);
  4346.     qr = ptr / t1;
  4347.     qi = pti / t1;
  4348.     s1r = fr;
  4349.     s1i = fi;
  4350.     s2r = pr;
  4351.     s2i = pi;
  4352.     ak = 1.;
  4353.     a1 = 1.;
  4354.     ckr = coner;
  4355.     cki = conei;
  4356.     bk = 1. - dnu2;
  4357.     if (inu > 0 || *n > 1) {
  4358.         goto L80;
  4359.     }
  4360. /* -----------------------------------------------------------------------
  4361.  */
  4362. /*     GENERATE K(FNU,Z), 0.0D0 .LE. FNU .LT. 0.5D0 AND N=1 */
  4363. /* -----------------------------------------------------------------------
  4364.  */
  4365.     if (caz < *tol) {
  4366.         goto L70;
  4367.     }
  4368.     zmlt_(zr, zi, zr, zi, &czr, &czi);
  4369.     czr *= .25;
  4370.     czi *= .25;
  4371.     t1 = caz * .25 * caz;
  4372. L60:
  4373.     fr = (fr * ak + pr + qr) / bk;
  4374.     fi = (fi * ak + pi + qi) / bk;
  4375.     str = 1. / (ak - dnu);
  4376.     pr *= str;
  4377.     pi *= str;
  4378.     str = 1. / (ak + dnu);
  4379.     qr *= str;
  4380.     qi *= str;
  4381.     str = ckr * czr - cki * czi;
  4382.     rak = 1. / ak;
  4383.     cki = (ckr * czi + cki * czr) * rak;
  4384.     ckr = str * rak;
  4385.     s1r = ckr * fr - cki * fi + s1r;
  4386.     s1i = ckr * fi + cki * fr + s1i;
  4387.     a1 = a1 * t1 * rak;
  4388.     bk = bk + ak + ak + 1.;
  4389.     ak += 1.;
  4390.     if (a1 > *tol) {
  4391.         goto L60;
  4392.     }
  4393. L70:
  4394.     yr[1] = s1r;
  4395.     yi[1] = s1i;
  4396.     if (koded == 1) {
  4397.         return 0;
  4398.     }
  4399.     zexp_(zr, zi, &str, &sti);
  4400.     zmlt_(&s1r, &s1i, &str, &sti, &yr[1], &yi[1]);
  4401.     return 0;
  4402. /* -----------------------------------------------------------------------
  4403.  */
  4404. /*     GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE */
  4405. /* -----------------------------------------------------------------------
  4406.  */
  4407. L80:
  4408.     if (caz < *tol) {
  4409.         goto L100;
  4410.     }
  4411.     zmlt_(zr, zi, zr, zi, &czr, &czi);
  4412.     czr *= .25;
  4413.     czi *= .25;
  4414.     t1 = caz * .25 * caz;
  4415. L90:
  4416.     fr = (fr * ak + pr + qr) / bk;
  4417.     fi = (fi * ak + pi + qi) / bk;
  4418.     str = 1. / (ak - dnu);
  4419.     pr *= str;
  4420.     pi *= str;
  4421.     str = 1. / (ak + dnu);
  4422.     qr *= str;
  4423.     qi *= str;
  4424.     str = ckr * czr - cki * czi;
  4425.     rak = 1. / ak;
  4426.     cki = (ckr * czi + cki * czr) * rak;
  4427.     ckr = str * rak;
  4428.     s1r = ckr * fr - cki * fi + s1r;
  4429.     s1i = ckr * fi + cki * fr + s1i;
  4430.     str = pr - fr * ak;
  4431.     sti = pi - fi * ak;
  4432.     s2r = ckr * str - cki * sti + s2r;
  4433.     s2i = ckr * sti + cki * str + s2i;
  4434.     a1 = a1 * t1 * rak;
  4435.     bk = bk + ak + ak + 1.;
  4436.     ak += 1.;
  4437.     if (a1 > *tol) {
  4438.         goto L90;
  4439.     }
  4440. L100:
  4441.     kflag = 2;
  4442.     a1 = *fnu + 1.;
  4443.     ak = a1 * abs(smur);
  4444.     if (ak > *alim) {
  4445.         kflag = 3;
  4446.     }
  4447.     str = cssr[kflag - 1];
  4448.     p2r = s2r * str;
  4449.     p2i = s2i * str;
  4450.     zmlt_(&p2r, &p2i, &rzr, &rzi, &s2r, &s2i);
  4451.     s1r *= str;
  4452.     s1i *= str;
  4453.     if (koded == 1) {
  4454.         goto L210;
  4455.     }
  4456.     zexp_(zr, zi, &fr, &fi);
  4457.     zmlt_(&s1r, &s1i, &fr, &fi, &s1r, &s1i);
  4458.     zmlt_(&s2r, &s2i, &fr, &fi, &s2r, &s2i);
  4459.     goto L210;
  4460. /* -----------------------------------------------------------------------
  4461.  */
  4462. /*     IFLAG=0 MEANS NO UNDERFLOW OCCURRED */
  4463. /*     IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH */
  4464. /*     KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD */
  4465. /*     RECURSION */
  4466. /* -----------------------------------------------------------------------
  4467.  */
  4468. L110:
  4469.     zsqrt_(zr, zi, &str, &sti);
  4470.     zdiv_(&rthpi, &czeroi, &str, &sti, &coefr, &coefi);
  4471.     kflag = 2;
  4472.     if (koded == 2) {
  4473.         goto L120;
  4474.     }
  4475.     if (*zr > *alim) {
  4476.         goto L290;
  4477.     }
  4478. /*     BLANK LINE */
  4479.     str = exp(-(*zr)) * cssr[kflag - 1];
  4480.     sti = -str * sin(*zi);
  4481.     str *= cos(*zi);
  4482.     zmlt_(&coefr, &coefi, &str, &sti, &coefr, &coefi);
  4483. L120:
  4484.     if (abs(dnu) == .5) {
  4485.         goto L300;
  4486.     }
  4487. /* -----------------------------------------------------------------------
  4488.  */
  4489. /*     MILLER ALGORITHM FOR CABS(Z).GT.R1 */
  4490. /* -----------------------------------------------------------------------
  4491.  */
  4492.     ak = cos(dpi * dnu);
  4493.     ak = abs(ak);
  4494.     if (ak == czeror) {
  4495.         goto L300;
  4496.     }
  4497.     fhs = (d__1 = .25 - dnu2, abs(d__1));
  4498.     if (fhs == czeror) {
  4499.         goto L300;
  4500.     }
  4501. /* -----------------------------------------------------------------------
  4502.  */
  4503. /*     COMPUTE R2=F(E). IF CABS(Z).GE.R2, USE FORWARD RECURRENCE TO */
  4504. /*     DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT LINE ON */
  4505. /*     12.LE.E.LE.60. E IS COMPUTED FROM 2**(-E)=B**(1-I1MACH(14))= */
  4506. /*     TOL WHERE B IS THE BASE OF THE ARITHMETIC. */
  4507. /* -----------------------------------------------------------------------
  4508.  */
  4509.     t1 = (doublereal) ((real) (i1mach_(&c__14) - 1));
  4510.     t1 = t1 * d1mach_(&c__5) * 3.321928094;
  4511.     t1 = max(t1,12.);
  4512.     t1 = min(t1,60.);
  4513.     t2 = tth * t1 - 6.;
  4514.     if (*zr != 0.) {
  4515.         goto L130;
  4516.     }
  4517.     t1 = hpi;
  4518.     goto L140;
  4519. L130:
  4520.     t1 = atan(*zi / *zr);
  4521.     t1 = abs(t1);
  4522. L140:
  4523.     if (t2 > caz) {
  4524.         goto L170;
  4525.     }
  4526. /* -----------------------------------------------------------------------
  4527.  */
  4528. /*     FORWARD RECURRENCE LOOP WHEN CABS(Z).GE.R2 */
  4529. /* -----------------------------------------------------------------------
  4530.  */
  4531.     etest = ak / (dpi * caz * *tol);
  4532.     fk = coner;
  4533.     if (etest < coner) {
  4534.         goto L180;
  4535.     }
  4536.     fks = ctwor;
  4537.     ckr = caz + caz + ctwor;
  4538.     p1r = czeror;
  4539.     p2r = coner;
  4540.     i__1 = kmax;
  4541.     for (i = 1; i <= i__1; ++i) {
  4542.         ak = fhs / fks;
  4543.         cbr = ckr / (fk + coner);
  4544.         ptr = p2r;
  4545.         p2r = cbr * p2r - p1r * ak;
  4546.         p1r = ptr;
  4547.         ckr += ctwor;
  4548.         fks = fks + fk + fk + ctwor;
  4549.         fhs = fhs + fk + fk;
  4550.         fk += coner;
  4551.         str = abs(p2r) * fk;
  4552.         if (etest < str) {
  4553.             goto L160;
  4554.         }
  4555. /* L150: */
  4556.     }
  4557.     goto L310;
  4558. L160:
  4559.     fk += spi * t1 * sqrt(t2 / caz);
  4560.     fhs = (d__1 = .25 - dnu2, abs(d__1));
  4561.     goto L180;
  4562. L170:
  4563. /* -----------------------------------------------------------------------
  4564.  */
  4565. /*     COMPUTE BACKWARD INDEX K FOR CABS(Z).LT.R2 */
  4566. /* -----------------------------------------------------------------------
  4567.  */
  4568.     a2 = sqrt(caz);
  4569.     ak = fpi * ak / (*tol * sqrt(a2));
  4570.     aa = t1 * 3. / (caz + 1.);
  4571.     bb = t1 * 14.7 / (caz + 28.);
  4572.     ak = (log(ak) + caz * cos(aa) / (caz * .008 + 1.)) / cos(bb);
  4573.     fk = ak * .12125 * ak / caz + 1.5;
  4574. L180:
  4575. /* -----------------------------------------------------------------------
  4576.  */
  4577. /*     BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM */
  4578. /* -----------------------------------------------------------------------
  4579.  */
  4580.     k = (integer) fk;
  4581.     fk = (doublereal) ((real) k);
  4582.     fks = fk * fk;
  4583.     p1r = czeror;
  4584.     p1i = czeroi;
  4585.     p2r = *tol;
  4586.     p2i = czeroi;
  4587.     csr = p2r;
  4588.     csi = p2i;
  4589.     i__1 = k;
  4590.     for (i = 1; i <= i__1; ++i) {
  4591.         a1 = fks - fk;
  4592.         ak = (fks + fk) / (a1 + fhs);
  4593.         rak = 2. / (fk + coner);
  4594.         cbr = (fk + *zr) * rak;
  4595.         cbi = *zi * rak;
  4596.         ptr = p2r;
  4597.         pti = p2i;
  4598.         p2r = (ptr * cbr - pti * cbi - p1r) * ak;
  4599.         p2i = (pti * cbr + ptr * cbi - p1i) * ak;
  4600.         p1r = ptr;
  4601.         p1i = pti;
  4602.         csr += p2r;
  4603.         csi += p2i;
  4604.         fks = a1 - fk + coner;
  4605.         fk -= coner;
  4606. /* L190: */
  4607.     }
  4608. /* -----------------------------------------------------------------------
  4609.  */
  4610. /*     COMPUTE (P2/CS)=(P2/CABS(CS))*(CONJG(CS)/CABS(CS)) FOR BETTER */
  4611. /*     SCALING */
  4612. /* -----------------------------------------------------------------------
  4613.  */
  4614.     tm = z1abs_(&csr, &csi);
  4615.     ptr = 1. / tm;
  4616.     s1r = p2r * ptr;
  4617.     s1i = p2i * ptr;
  4618.     csr *= ptr;
  4619.     csi = -csi * ptr;
  4620.     zmlt_(&coefr, &coefi, &s1r, &s1i, &str, &sti);
  4621.     zmlt_(&str, &sti, &csr, &csi, &s1r, &s1i);
  4622.     if (inu > 0 || *n > 1) {
  4623.         goto L200;
  4624.     }
  4625.     zdr = *zr;
  4626.     zdi = *zi;
  4627.     if (iflag == 1) {
  4628.         goto L270;
  4629.     }
  4630.     goto L240;
  4631. L200:
  4632. /* -----------------------------------------------------------------------
  4633.  */
  4634. /*     COMPUTE P1/P2=(P1/CABS(P2)*CONJG(P2)/CABS(P2) FOR SCALING */
  4635. /* -----------------------------------------------------------------------
  4636.  */
  4637.     tm = z1abs_(&p2r, &p2i);
  4638.     ptr = 1. / tm;
  4639.     p1r *= ptr;
  4640.     p1i *= ptr;
  4641.     p2r *= ptr;
  4642.     p2i = -p2i * ptr;
  4643.     zmlt_(&p1r, &p1i, &p2r, &p2i, &ptr, &pti);
  4644.     str = dnu + .5 - ptr;
  4645.     sti = -pti;
  4646.     zdiv_(&str, &sti, zr, zi, &str, &sti);
  4647.     str += 1.;
  4648.     zmlt_(&str, &sti, &s1r, &s1i, &s2r, &s2i);
  4649. /* -----------------------------------------------------------------------
  4650.  */
  4651. /*     FORWARD RECURSION ON THE THREE TERM RECURSION WITH RELATION WITH */
  4652.  
  4653. /*     SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3 */
  4654. /* -----------------------------------------------------------------------
  4655.  */
  4656. L210:
  4657.     str = dnu + 1.;
  4658.     ckr = str * rzr;
  4659.     cki = str * rzi;
  4660.     if (*n == 1) {
  4661.         --inu;
  4662.     }
  4663.     if (inu > 0) {
  4664.         goto L220;
  4665.     }
  4666.     if (*n > 1) {
  4667.         goto L215;
  4668.     }
  4669.     s1r = s2r;
  4670.     s1i = s2i;
  4671. L215:
  4672.     zdr = *zr;
  4673.     zdi = *zi;
  4674.     if (iflag == 1) {
  4675.         goto L270;
  4676.     }
  4677.     goto L240;
  4678. L220:
  4679.     inub = 1;
  4680.     if (iflag == 1) {
  4681.         goto L261;
  4682.     }
  4683. L225:
  4684.     p1r = csrr[kflag - 1];
  4685.     ascle = bry[kflag - 1];
  4686.     i__1 = inu;
  4687.     for (i = inub; i <= i__1; ++i) {
  4688.         str = s2r;
  4689.         sti = s2i;
  4690.         s2r = ckr * str - cki * sti + s1r;
  4691.         s2i = ckr * sti + cki * str + s1i;
  4692.         s1r = str;
  4693.         s1i = sti;
  4694.         ckr += rzr;
  4695.         cki += rzi;
  4696.         if (kflag >= 3) {
  4697.             goto L230;
  4698.         }
  4699.         p2r = s2r * p1r;
  4700.         p2i = s2i * p1r;
  4701.         str = abs(p2r);
  4702.         sti = abs(p2i);
  4703.         p2m = max(str,sti);
  4704.         if (p2m <= ascle) {
  4705.             goto L230;
  4706.         }
  4707.         ++kflag;
  4708.         ascle = bry[kflag - 1];
  4709.         s1r *= p1r;
  4710.         s1i *= p1r;
  4711.         s2r = p2r;
  4712.         s2i = p2i;
  4713.         str = cssr[kflag - 1];
  4714.         s1r *= str;
  4715.         s1i *= str;
  4716.         s2r *= str;
  4717.         s2i *= str;
  4718.         p1r = csrr[kflag - 1];
  4719. L230:
  4720.         ;
  4721.     }
  4722.     if (*n != 1) {
  4723.         goto L240;
  4724.     }
  4725.     s1r = s2r;
  4726.     s1i = s2i;
  4727. L240:
  4728.     str = csrr[kflag - 1];
  4729.     yr[1] = s1r * str;
  4730.     yi[1] = s1i * str;
  4731.     if (*n == 1) {
  4732.         return 0;
  4733.     }
  4734.     yr[2] = s2r * str;
  4735.     yi[2] = s2i * str;
  4736.     if (*n == 2) {
  4737.         return 0;
  4738.     }
  4739.     kk = 2;
  4740. L250:
  4741.     ++kk;
  4742.     if (kk > *n) {
  4743.         return 0;
  4744.     }
  4745.     p1r = csrr[kflag - 1];
  4746.     ascle = bry[kflag - 1];
  4747.     i__1 = *n;
  4748.     for (i = kk; i <= i__1; ++i) {
  4749.         p2r = s2r;
  4750.         p2i = s2i;
  4751.         s2r = ckr * p2r - cki * p2i + s1r;
  4752.         s2i = cki * p2r + ckr * p2i + s1i;
  4753.         s1r = p2r;
  4754.         s1i = p2i;
  4755.         ckr += rzr;
  4756.         cki += rzi;
  4757.         p2r = s2r * p1r;
  4758.         p2i = s2i * p1r;
  4759.         yr[i] = p2r;
  4760.         yi[i] = p2i;
  4761.         if (kflag >= 3) {
  4762.             goto L260;
  4763.         }
  4764.         str = abs(p2r);
  4765.         sti = abs(p2i);
  4766.         p2m = max(str,sti);
  4767.         if (p2m <= ascle) {
  4768.             goto L260;
  4769.         }
  4770.         ++kflag;
  4771.         ascle = bry[kflag - 1];
  4772.         s1r *= p1r;
  4773.         s1i *= p1r;
  4774.         s2r = p2r;
  4775.         s2i = p2i;
  4776.         str = cssr[kflag - 1];
  4777.         s1r *= str;
  4778.         s1i *= str;
  4779.         s2r *= str;
  4780.         s2i *= str;
  4781.         p1r = csrr[kflag - 1];
  4782. L260:
  4783.         ;
  4784.     }
  4785.     return 0;
  4786. /* -----------------------------------------------------------------------
  4787.  */
  4788. /*     IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW */
  4789. /* -----------------------------------------------------------------------
  4790.  */
  4791. L261:
  4792.     helim = *elim * .5;
  4793.     elm = exp(-(*elim));
  4794.     celmr = elm;
  4795.     ascle = bry[0];
  4796.     zdr = *zr;
  4797.     zdi = *zi;
  4798.     ic = -1;
  4799.     j = 2;
  4800.     i__1 = inu;
  4801.     for (i = 1; i <= i__1; ++i) {
  4802.         str = s2r;
  4803.         sti = s2i;
  4804.         s2r = str * ckr - sti * cki + s1r;
  4805.         s2i = sti * ckr + str * cki + s1i;
  4806.         s1r = str;
  4807.         s1i = sti;
  4808.         ckr += rzr;
  4809.         cki += rzi;
  4810.         as = z1abs_(&s2r, &s2i);
  4811.         alas = log(as);
  4812.         p2r = -zdr + alas;
  4813.         if (p2r < -(*elim)) {
  4814.             goto L263;
  4815.         }
  4816.         zlog_(&s2r, &s2i, &str, &sti, &idum);
  4817.         p2r = -zdr + str;
  4818.         p2i = -zdi + sti;
  4819.         p2m = exp(p2r) / *tol;
  4820.         p1r = p2m * cos(p2i);
  4821.         p1i = p2m * sin(p2i);
  4822.         zuchk_(&p1r, &p1i, &nw, &ascle, tol);
  4823.         if (nw != 0) {
  4824.             goto L263;
  4825.         }
  4826.         j = 3 - j;
  4827.         cyr[j - 1] = p1r;
  4828.         cyi[j - 1] = p1i;
  4829.         if (ic == i - 1) {
  4830.             goto L264;
  4831.         }
  4832.         ic = i;
  4833.         goto L262;
  4834. L263:
  4835.         if (alas < helim) {
  4836.             goto L262;
  4837.         }
  4838.         zdr -= *elim;
  4839.         s1r *= celmr;
  4840.         s1i *= celmr;
  4841.         s2r *= celmr;
  4842.         s2i *= celmr;
  4843. L262:
  4844.         ;
  4845.     }
  4846.     if (*n != 1) {
  4847.         goto L270;
  4848.     }
  4849.     s1r = s2r;
  4850.     s1i = s2i;
  4851.     goto L270;
  4852. L264:
  4853.     kflag = 1;
  4854.     inub = i + 1;
  4855.     s2r = cyr[j - 1];
  4856.     s2i = cyi[j - 1];
  4857.     j = 3 - j;
  4858.     s1r = cyr[j - 1];
  4859.     s1i = cyi[j - 1];
  4860.     if (inub <= inu) {
  4861.         goto L225;
  4862.     }
  4863.     if (*n != 1) {
  4864.         goto L240;
  4865.     }
  4866.     s1r = s2r;
  4867.     s1i = s2i;
  4868.     goto L240;
  4869. L270:
  4870.     yr[1] = s1r;
  4871.     yi[1] = s1i;
  4872.     if (*n == 1) {
  4873.         goto L280;
  4874.     }
  4875.     yr[2] = s2r;
  4876.     yi[2] = s2i;
  4877. L280:
  4878.     ascle = bry[0];
  4879.     zkscl_(&zdr, &zdi, fnu, n, &yr[1], &yi[1], nz, &rzr, &rzi, &ascle, tol, 
  4880.             elim);
  4881.     inu = *n - *nz;
  4882.     if (inu <= 0) {
  4883.         return 0;
  4884.     }
  4885.     kk = *nz + 1;
  4886.     s1r = yr[kk];
  4887.     s1i = yi[kk];
  4888.     yr[kk] = s1r * csrr[0];
  4889.     yi[kk] = s1i * csrr[0];
  4890.     if (inu == 1) {
  4891.         return 0;
  4892.     }
  4893.     kk = *nz + 2;
  4894.     s2r = yr[kk];
  4895.     s2i = yi[kk];
  4896.     yr[kk] = s2r * csrr[0];
  4897.     yi[kk] = s2i * csrr[0];
  4898.     if (inu == 2) {
  4899.         return 0;
  4900.     }
  4901.     t2 = *fnu + (doublereal) ((real) (kk - 1));
  4902.     ckr = t2 * rzr;
  4903.     cki = t2 * rzi;
  4904.     kflag = 1;
  4905.     goto L250;
  4906. L290:
  4907. /* -----------------------------------------------------------------------
  4908.  */
  4909. /*     SCALE BY DEXP(Z), IFLAG = 1 CASES */
  4910. /* -----------------------------------------------------------------------
  4911.  */
  4912.     koded = 2;
  4913.     iflag = 1;
  4914.     kflag = 2;
  4915.     goto L120;
  4916. /* -----------------------------------------------------------------------
  4917.  */
  4918. /*     FNU=HALF ODD INTEGER CASE, DNU=-0.5 */
  4919. /* -----------------------------------------------------------------------
  4920.  */
  4921. L300:
  4922.     s1r = coefr;
  4923.     s1i = coefi;
  4924.     s2r = coefr;
  4925.     s2i = coefi;
  4926.     goto L210;
  4927.  
  4928.  
  4929. L310:
  4930.     *nz = -2;
  4931.     return 0;
  4932. } /* zbknu_ */
  4933.  
  4934. /* Subroutine */ int zbuni_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  4935.         integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
  4936.         nz, integer *nui, integer *nlast, doublereal *fnul, doublereal *tol, 
  4937.         doublereal *elim, doublereal *alim)
  4938. {
  4939.     /* System generated locals */
  4940.     integer i__1;
  4941.  
  4942.     /* Local variables */
  4943.     static doublereal dfnu, fnui;
  4944.     extern doublereal z1abs_(doublereal *, doublereal *);
  4945.     extern /* Subroutine */ int zuni1_(doublereal *, doublereal *, doublereal 
  4946.             *, integer *, integer *, doublereal *, doublereal *, integer *, 
  4947.             integer *, doublereal *, doublereal *, doublereal *, doublereal *)
  4948.             , zuni2_(doublereal *, doublereal *, doublereal *, integer *, 
  4949.             integer *, doublereal *, doublereal *, integer *, integer *, 
  4950.             doublereal *, doublereal *, doublereal *, doublereal *);
  4951.     static integer i, k, iflag;
  4952.     static doublereal ascle, csclr, cscrr;
  4953.     static integer iform;
  4954.     extern doublereal d1mach_(integer *);
  4955.     static doublereal ax, ay;
  4956.     static integer nl, nw;
  4957.     static doublereal c1i, c1m, c1r, s1i, s2i, s1r, s2r, cyi[2], gnu, raz, 
  4958.             cyr[2], sti, bry[3], rzi, str, rzr;
  4959.  
  4960. /* ***BEGIN PROLOGUE  ZBUNI */
  4961. /* ***REFER TO  ZBESI,ZBESK */
  4962.  
  4963. /*     ZBUNI COMPUTES THE I BESSEL FUNCTION FOR LARGE CABS(Z).GT. */
  4964. /*     FNUL AND FNU+N-1.LT.FNUL. THE ORDER IS INCREASED FROM */
  4965. /*     FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING */
  4966. /*     ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z) */
  4967. /*     ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2 */
  4968.  
  4969. /* ***ROUTINES CALLED  ZUNI1,ZUNI2,Z1ABS,D1MACH */
  4970. /* ***END PROLOGUE  ZBUNI */
  4971. /*     COMPLEX CSCL,CSCR,CY,RZ,ST,S1,S2,Y,Z */
  4972.     /* Parameter adjustments */
  4973.     --yi;
  4974.     --yr;
  4975.  
  4976.     /* Function Body */
  4977.     *nz = 0;
  4978.     ax = abs(*zr) * 1.7321;
  4979.     ay = abs(*zi);
  4980.     iform = 1;
  4981.     if (ay > ax) {
  4982.         iform = 2;
  4983.     }
  4984.     if (*nui == 0) {
  4985.         goto L60;
  4986.     }
  4987.     fnui = (doublereal) ((real) (*nui));
  4988.     dfnu = *fnu + (doublereal) ((real) (*n - 1));
  4989.     gnu = dfnu + fnui;
  4990.     if (iform == 2) {
  4991.         goto L10;
  4992.     }
  4993. /* -----------------------------------------------------------------------
  4994.  */
  4995. /*     ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN */
  4996. /*     -PI/3.LE.ARG(Z).LE.PI/3 */
  4997. /* -----------------------------------------------------------------------
  4998.  */
  4999.     zuni1_(zr, zi, &gnu, kode, &c__2, cyr, cyi, &nw, nlast, fnul, tol, elim, 
  5000.             alim);
  5001.     goto L20;
  5002. L10:
  5003. /* -----------------------------------------------------------------------
  5004.  */
  5005. /*     ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU */
  5006. /*     APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I */
  5007. /*     AND HPI=PI/2 */
  5008. /* -----------------------------------------------------------------------
  5009.  */
  5010.     zuni2_(zr, zi, &gnu, kode, &c__2, cyr, cyi, &nw, nlast, fnul, tol, elim, 
  5011.             alim);
  5012. L20:
  5013.     if (nw < 0) {
  5014.         goto L50;
  5015.     }
  5016.     if (nw != 0) {
  5017.         goto L90;
  5018.     }
  5019.     str = z1abs_(cyr, cyi);
  5020. /* ---------------------------------------------------------------------- 
  5021. */
  5022. /*     SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER USED */
  5023. /* ---------------------------------------------------------------------- 
  5024. */
  5025.     bry[0] = d1mach_(&c__1) * 1e3 / *tol;
  5026.     bry[1] = 1. / bry[0];
  5027.     bry[2] = bry[1];
  5028.     iflag = 2;
  5029.     ascle = bry[1];
  5030.     csclr = 1.;
  5031.     if (str > bry[0]) {
  5032.         goto L21;
  5033.     }
  5034.     iflag = 1;
  5035.     ascle = bry[0];
  5036.     csclr = 1. / *tol;
  5037.     goto L25;
  5038. L21:
  5039.     if (str < bry[1]) {
  5040.         goto L25;
  5041.     }
  5042.     iflag = 3;
  5043.     ascle = bry[2];
  5044.     csclr = *tol;
  5045. L25:
  5046.     cscrr = 1. / csclr;
  5047.     s1r = cyr[1] * csclr;
  5048.     s1i = cyi[1] * csclr;
  5049.     s2r = cyr[0] * csclr;
  5050.     s2i = cyi[0] * csclr;
  5051.     raz = 1. / z1abs_(zr, zi);
  5052.     str = *zr * raz;
  5053.     sti = -(*zi) * raz;
  5054.     rzr = (str + str) * raz;
  5055.     rzi = (sti + sti) * raz;
  5056.     i__1 = *nui;
  5057.     for (i = 1; i <= i__1; ++i) {
  5058.         str = s2r;
  5059.         sti = s2i;
  5060.         s2r = (dfnu + fnui) * (rzr * str - rzi * sti) + s1r;
  5061.         s2i = (dfnu + fnui) * (rzr * sti + rzi * str) + s1i;
  5062.         s1r = str;
  5063.         s1i = sti;
  5064.         fnui += -1.;
  5065.         if (iflag >= 3) {
  5066.             goto L30;
  5067.         }
  5068.         str = s2r * cscrr;
  5069.         sti = s2i * cscrr;
  5070.         c1r = abs(str);
  5071.         c1i = abs(sti);
  5072.         c1m = max(c1r,c1i);
  5073.         if (c1m <= ascle) {
  5074.             goto L30;
  5075.         }
  5076.         ++iflag;
  5077.         ascle = bry[iflag - 1];
  5078.         s1r *= cscrr;
  5079.         s1i *= cscrr;
  5080.         s2r = str;
  5081.         s2i = sti;
  5082.         csclr *= *tol;
  5083.         cscrr = 1. / csclr;
  5084.         s1r *= csclr;
  5085.         s1i *= csclr;
  5086.         s2r *= csclr;
  5087.         s2i *= csclr;
  5088. L30:
  5089.         ;
  5090.     }
  5091.     yr[*n] = s2r * cscrr;
  5092.     yi[*n] = s2i * cscrr;
  5093.     if (*n == 1) {
  5094.         return 0;
  5095.     }
  5096.     nl = *n - 1;
  5097.     fnui = (doublereal) ((real) nl);
  5098.     k = nl;
  5099.     i__1 = nl;
  5100.     for (i = 1; i <= i__1; ++i) {
  5101.         str = s2r;
  5102.         sti = s2i;
  5103.         s2r = (*fnu + fnui) * (rzr * str - rzi * sti) + s1r;
  5104.         s2i = (*fnu + fnui) * (rzr * sti + rzi * str) + s1i;
  5105.         s1r = str;
  5106.         s1i = sti;
  5107.         str = s2r * cscrr;
  5108.         sti = s2i * cscrr;
  5109.         yr[k] = str;
  5110.         yi[k] = sti;
  5111.         fnui += -1.;
  5112.         --k;
  5113.         if (iflag >= 3) {
  5114.             goto L40;
  5115.         }
  5116.         c1r = abs(str);
  5117.         c1i = abs(sti);
  5118.         c1m = max(c1r,c1i);
  5119.         if (c1m <= ascle) {
  5120.             goto L40;
  5121.         }
  5122.         ++iflag;
  5123.         ascle = bry[iflag - 1];
  5124.         s1r *= cscrr;
  5125.         s1i *= cscrr;
  5126.         s2r = str;
  5127.         s2i = sti;
  5128.         csclr *= *tol;
  5129.         cscrr = 1. / csclr;
  5130.         s1r *= csclr;
  5131.         s1i *= csclr;
  5132.         s2r *= csclr;
  5133.         s2i *= csclr;
  5134. L40:
  5135.         ;
  5136.     }
  5137.     return 0;
  5138. L50:
  5139.     *nz = -1;
  5140.     if (nw == -2) {
  5141.         *nz = -2;
  5142.     }
  5143.     return 0;
  5144. L60:
  5145.     if (iform == 2) {
  5146.         goto L70;
  5147.     }
  5148. /* -----------------------------------------------------------------------
  5149.  */
  5150. /*     ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN */
  5151. /*     -PI/3.LE.ARG(Z).LE.PI/3 */
  5152. /* -----------------------------------------------------------------------
  5153.  */
  5154.     zuni1_(zr, zi, fnu, kode, n, &yr[1], &yi[1], &nw, nlast, fnul, tol, elim, 
  5155.             alim);
  5156.     goto L80;
  5157. L70:
  5158. /* -----------------------------------------------------------------------
  5159.  */
  5160. /*     ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU */
  5161. /*     APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I */
  5162. /*     AND HPI=PI/2 */
  5163. /* -----------------------------------------------------------------------
  5164.  */
  5165.     zuni2_(zr, zi, fnu, kode, n, &yr[1], &yi[1], &nw, nlast, fnul, tol, elim, 
  5166.             alim);
  5167. L80:
  5168.     if (nw < 0) {
  5169.         goto L50;
  5170.     }
  5171.     *nz = nw;
  5172.     return 0;
  5173. L90:
  5174.     *nlast = *n;
  5175.     return 0;
  5176. } /* zbuni_ */
  5177.  
  5178. /* Subroutine */ int zbunk_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  5179.         integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *
  5180.         yi, integer *nz, doublereal *tol, doublereal *elim, doublereal *alim)
  5181. {
  5182.     extern /* Subroutine */ int zunk1_(doublereal *, doublereal *, doublereal 
  5183.             *, integer *, integer *, integer *, doublereal *, doublereal *, 
  5184.             integer *, doublereal *, doublereal *, doublereal *), zunk2_(
  5185.             doublereal *, doublereal *, doublereal *, integer *, integer *, 
  5186.             integer *, doublereal *, doublereal *, integer *, doublereal *, 
  5187.             doublereal *, doublereal *);
  5188.     static doublereal ax, ay;
  5189.  
  5190. /* ***BEGIN PROLOGUE  ZBUNK */
  5191. /* ***REFER TO  ZBESK,ZBESH */
  5192.  
  5193. /*     ZBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU.GT.FNUL. */
  5194. /*     ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z) */
  5195. /*     IN ZUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN ZUNK2 */
  5196.  
  5197. /* ***ROUTINES CALLED  ZUNK1,ZUNK2 */
  5198. /* ***END PROLOGUE  ZBUNK */
  5199. /*     COMPLEX Y,Z */
  5200.     /* Parameter adjustments */
  5201.     --yi;
  5202.     --yr;
  5203.  
  5204.     /* Function Body */
  5205.     *nz = 0;
  5206.     ax = abs(*zr) * 1.7321;
  5207.     ay = abs(*zi);
  5208.     if (ay > ax) {
  5209.         goto L10;
  5210.     }
  5211. /* -----------------------------------------------------------------------
  5212.  */
  5213. /*     ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN */
  5214. /*     -PI/3.LE.ARG(Z).LE.PI/3 */
  5215. /* -----------------------------------------------------------------------
  5216.  */
  5217.     zunk1_(zr, zi, fnu, kode, mr, n, &yr[1], &yi[1], nz, tol, elim, alim);
  5218.     goto L20;
  5219. L10:
  5220. /* -----------------------------------------------------------------------
  5221.  */
  5222. /*     ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU */
  5223. /*     APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I */
  5224. /*     AND HPI=PI/2 */
  5225. /* -----------------------------------------------------------------------
  5226.  */
  5227.     zunk2_(zr, zi, fnu, kode, mr, n, &yr[1], &yi[1], nz, tol, elim, alim);
  5228. L20:
  5229.     return 0;
  5230. } /* zbunk_ */
  5231.  
  5232. /* Subroutine */ int zdiv_(doublereal *ar, doublereal *ai, doublereal *br, 
  5233.         doublereal *bi, doublereal *cr, doublereal *ci)
  5234. {
  5235.     extern doublereal z1abs_(doublereal *, doublereal *);
  5236.     static doublereal ca, cb, cc, cd, bm;
  5237.  
  5238. /* ***BEGIN PROLOGUE  ZDIV */
  5239. /* ***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY */
  5240.  
  5241. /*     DOUBLE PRECISION COMPLEX DIVIDE C=A/B. */
  5242.  
  5243. /* ***ROUTINES CALLED  Z1ABS */
  5244. /* ***END PROLOGUE  ZDIV */
  5245.     bm = 1. / z1abs_(br, bi);
  5246.     cc = *br * bm;
  5247.     cd = *bi * bm;
  5248.     ca = (*ar * cc + *ai * cd) * bm;
  5249.     cb = (*ai * cc - *ar * cd) * bm;
  5250.     *cr = ca;
  5251.     *ci = cb;
  5252.     return 0;
  5253. } /* zdiv_ */
  5254.  
  5255. /* Subroutine */ int zexp_(doublereal *ar, doublereal *ai, doublereal *br, 
  5256.         doublereal *bi)
  5257. {
  5258.     /* Builtin functions */
  5259.     double exp(doublereal), cos(doublereal), sin(doublereal);
  5260.  
  5261.     /* Local variables */
  5262.     static doublereal ca, cb, zm;
  5263.  
  5264. /* ***BEGIN PROLOGUE  ZEXP */
  5265. /* ***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY */
  5266.  
  5267. /*     DOUBLE PRECISION COMPLEX EXPONENTIAL FUNCTION B=EXP(A) */
  5268.  
  5269. /* ***ROUTINES CALLED  (NONE) */
  5270. /* ***END PROLOGUE  ZEXP */
  5271.     zm = exp(*ar);
  5272.     ca = zm * cos(*ai);
  5273.     cb = zm * sin(*ai);
  5274.     *br = ca;
  5275.     *bi = cb;
  5276.     return 0;
  5277. } /* zexp_ */
  5278.  
  5279. /* Subroutine */ int zkscl_(doublereal *zrr, doublereal *zri, doublereal *fnu,
  5280.          integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *
  5281.         rzr, doublereal *rzi, doublereal *ascle, doublereal *tol, doublereal *
  5282.         elim)
  5283. {
  5284.     /* Initialized data */
  5285.  
  5286.     static doublereal zeror = 0.;
  5287.     static doublereal zeroi = 0.;
  5288.  
  5289.     /* System generated locals */
  5290.     integer i__1;
  5291.  
  5292.     /* Builtin functions */
  5293.     double log(doublereal), exp(doublereal), cos(doublereal), sin(doublereal);
  5294.  
  5295.  
  5296.     /* Local variables */
  5297.     static doublereal alas;
  5298.     static integer idum;
  5299.     extern /* Subroutine */ int zlog_(doublereal *, doublereal *, doublereal *
  5300.             , doublereal *, integer *);
  5301.     extern doublereal z1abs_(doublereal *, doublereal *);
  5302.     static integer i;
  5303.     static doublereal helim, celmr;
  5304.     extern /* Subroutine */ int zuchk_(doublereal *, doublereal *, integer *, 
  5305.             doublereal *, doublereal *);
  5306.     static integer ic;
  5307.     static doublereal as, fn;
  5308.     static integer kk, nn, nw;
  5309.     static doublereal s1i, s2i, s1r, s2r, acs, cki, elm, csi, ckr, cyi[2], 
  5310.             zdi, csr, cyr[2], zdr, str;
  5311.  
  5312. /* ***BEGIN PROLOGUE  ZKSCL */
  5313. /* ***REFER TO  ZBESK */
  5314.  
  5315. /*     SET K FUNCTIONS TO ZERO ON UNDERFLOW, CONTINUE RECURRENCE */
  5316. /*     ON SCALED FUNCTIONS UNTIL TWO MEMBERS COME ON SCALE, THEN */
  5317. /*     RETURN WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL. */
  5318.  
  5319. /* ***ROUTINES CALLED  ZUCHK,Z1ABS,ZLOG */
  5320. /* ***END PROLOGUE  ZKSCL */
  5321. /*     COMPLEX CK,CS,CY,CZERO,RZ,S1,S2,Y,ZR,ZD,CELM */
  5322.     /* Parameter adjustments */
  5323.     --yi;
  5324.     --yr;
  5325.  
  5326.     /* Function Body */
  5327.  
  5328.     *nz = 0;
  5329.     ic = 0;
  5330.     nn = min(2,*n);
  5331.     i__1 = nn;
  5332.     for (i = 1; i <= i__1; ++i) {
  5333.         s1r = yr[i];
  5334.         s1i = yi[i];
  5335.         cyr[i - 1] = s1r;
  5336.         cyi[i - 1] = s1i;
  5337.         as = z1abs_(&s1r, &s1i);
  5338.         acs = -(*zrr) + log(as);
  5339.         ++(*nz);
  5340.         yr[i] = zeror;
  5341.         yi[i] = zeroi;
  5342.         if (acs < -(*elim)) {
  5343.             goto L10;
  5344.         }
  5345.         zlog_(&s1r, &s1i, &csr, &csi, &idum);
  5346.         csr -= *zrr;
  5347.         csi -= *zri;
  5348.         str = exp(csr) / *tol;
  5349.         csr = str * cos(csi);
  5350.         csi = str * sin(csi);
  5351.         zuchk_(&csr, &csi, &nw, ascle, tol);
  5352.         if (nw != 0) {
  5353.             goto L10;
  5354.         }
  5355.         yr[i] = csr;
  5356.         yi[i] = csi;
  5357.         ic = i;
  5358.         --(*nz);
  5359. L10:
  5360.         ;
  5361.     }
  5362.     if (*n == 1) {
  5363.         return 0;
  5364.     }
  5365.     if (ic > 1) {
  5366.         goto L20;
  5367.     }
  5368.     yr[1] = zeror;
  5369.     yi[1] = zeroi;
  5370.     *nz = 2;
  5371. L20:
  5372.     if (*n == 2) {
  5373.         return 0;
  5374.     }
  5375.     if (*nz == 0) {
  5376.         return 0;
  5377.     }
  5378.     fn = *fnu + 1.;
  5379.     ckr = fn * *rzr;
  5380.     cki = fn * *rzi;
  5381.     s1r = cyr[0];
  5382.     s1i = cyi[0];
  5383.     s2r = cyr[1];
  5384.     s2i = cyi[1];
  5385.     helim = *elim * .5;
  5386.     elm = exp(-(*elim));
  5387.     celmr = elm;
  5388.     zdr = *zrr;
  5389.     zdi = *zri;
  5390.  
  5391. /*     FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE RECURRENCE IF */
  5392. /*     S2 GETS LARGER THAN EXP(ELIM/2) */
  5393.  
  5394.     i__1 = *n;
  5395.     for (i = 3; i <= i__1; ++i) {
  5396.         kk = i;
  5397.         csr = s2r;
  5398.         csi = s2i;
  5399.         s2r = ckr * csr - cki * csi + s1r;
  5400.         s2i = cki * csr + ckr * csi + s1i;
  5401.         s1r = csr;
  5402.         s1i = csi;
  5403.         ckr += *rzr;
  5404.         cki += *rzi;
  5405.         as = z1abs_(&s2r, &s2i);
  5406.         alas = log(as);
  5407.         acs = -zdr + alas;
  5408.         ++(*nz);
  5409.         yr[i] = zeror;
  5410.         yi[i] = zeroi;
  5411.         if (acs < -(*elim)) {
  5412.             goto L25;
  5413.         }
  5414.         zlog_(&s2r, &s2i, &csr, &csi, &idum);
  5415.         csr -= zdr;
  5416.         csi -= zdi;
  5417.         str = exp(csr) / *tol;
  5418.         csr = str * cos(csi);
  5419.         csi = str * sin(csi);
  5420.         zuchk_(&csr, &csi, &nw, ascle, tol);
  5421.         if (nw != 0) {
  5422.             goto L25;
  5423.         }
  5424.         yr[i] = csr;
  5425.         yi[i] = csi;
  5426.         --(*nz);
  5427.         if (ic == kk - 1) {
  5428.             goto L40;
  5429.         }
  5430.         ic = kk;
  5431.         goto L30;
  5432. L25:
  5433.         if (alas < helim) {
  5434.             goto L30;
  5435.         }
  5436.         zdr -= *elim;
  5437.         s1r *= celmr;
  5438.         s1i *= celmr;
  5439.         s2r *= celmr;
  5440.         s2i *= celmr;
  5441. L30:
  5442.         ;
  5443.     }
  5444.     *nz = *n;
  5445.     if (ic == *n) {
  5446.         *nz = *n - 1;
  5447.     }
  5448.     goto L45;
  5449. L40:
  5450.     *nz = kk - 2;
  5451. L45:
  5452.     i__1 = *nz;
  5453.     for (i = 1; i <= i__1; ++i) {
  5454.         yr[i] = zeror;
  5455.         yi[i] = zeroi;
  5456. /* L50: */
  5457.     }
  5458.     return 0;
  5459. } /* zkscl_ */
  5460.  
  5461. /* Subroutine */ int zlog_(doublereal *ar, doublereal *ai, doublereal *br, 
  5462.         doublereal *bi, integer *ierr)
  5463. {
  5464.     /* Initialized data */
  5465.  
  5466.     static doublereal dpi = 3.141592653589793238462643383;
  5467.     static doublereal dhpi = 1.570796326794896619231321696;
  5468.  
  5469.     /* Builtin functions */
  5470.     double atan(doublereal), log(doublereal);
  5471.  
  5472.     /* Local variables */
  5473.     extern doublereal z1abs_(doublereal *, doublereal *);
  5474.     static doublereal zm, dtheta;
  5475.  
  5476. /* ***BEGIN PROLOGUE  ZLOG */
  5477. /* ***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY */
  5478.  
  5479. /*     DOUBLE PRECISION COMPLEX LOGARITHM B=CLOG(A) */
  5480. /*     IERR=0,NORMAL RETURN      IERR=1, Z=CMPLX(0.0,0.0) */
  5481. /* ***ROUTINES CALLED  Z1ABS */
  5482. /* ***END PROLOGUE  ZLOG */
  5483.  
  5484.     *ierr = 0;
  5485.     if (*ar == 0.) {
  5486.         goto L10;
  5487.     }
  5488.     if (*ai == 0.) {
  5489.         goto L20;
  5490.     }
  5491.     dtheta = atan(*ai / *ar);
  5492.     if (dtheta <= 0.) {
  5493.         goto L40;
  5494.     }
  5495.     if (*ar < 0.) {
  5496.         dtheta -= dpi;
  5497.     }
  5498.     goto L50;
  5499. L10:
  5500.     if (*ai == 0.) {
  5501.         goto L60;
  5502.     }
  5503.     *bi = dhpi;
  5504.     *br = log((abs(*ai)));
  5505.     if (*ai < 0.) {
  5506.         *bi = -(*bi);
  5507.     }
  5508.     return 0;
  5509. L20:
  5510.     if (*ar > 0.) {
  5511.         goto L30;
  5512.     }
  5513.     *br = log((abs(*ar)));
  5514.     *bi = dpi;
  5515.     return 0;
  5516. L30:
  5517.     *br = log(*ar);
  5518.     *bi = 0.;
  5519.     return 0;
  5520. L40:
  5521.     if (*ar < 0.) {
  5522.         dtheta += dpi;
  5523.     }
  5524. L50:
  5525.     zm = z1abs_(ar, ai);
  5526.     *br = log(zm);
  5527.     *bi = dtheta;
  5528.     return 0;
  5529. L60:
  5530.     *ierr = 1;
  5531.     return 0;
  5532. } /* zlog_ */
  5533.  
  5534. /* funz4.f -- translated by f2c (version of 16 May 1991  13:06:06).
  5535.    You must link the resulting object file with the libraries:
  5536.         -link <S|C|M|L>f2c.lib   (in that order)
  5537. */
  5538.  
  5539.  
  5540.  
  5541. /* Table of constant values */
  5542. /*
  5543. static integer c__1 = 1;
  5544. */
  5545. /* Subroutine */ int zmlri_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  5546.         integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
  5547.         nz, doublereal *tol)
  5548. {
  5549.     /* Initialized data */
  5550.  
  5551.     static doublereal zeror = 0.;
  5552.     static doublereal zeroi = 0.;
  5553.     static doublereal coner = 1.;
  5554.     static doublereal conei = 0.;
  5555.  
  5556.     /* System generated locals */
  5557.     integer i__1, i__2;
  5558.     doublereal d__1, d__2, d__3;
  5559.  
  5560.     /* Builtin functions */
  5561.     double sqrt(doublereal), exp(doublereal);
  5562.  
  5563.     /* Local variables */
  5564.     static doublereal flam, fkap, scle, tfnf;
  5565.     static integer idum, ifnu;
  5566.     extern /* Subroutine */ int zlog_(doublereal *, doublereal *, doublereal *
  5567.             , doublereal *, integer *);
  5568.     static doublereal sumi, sumr;
  5569.     extern /* Subroutine */ int zexp_(doublereal *, doublereal *, doublereal *
  5570.             , doublereal *), zmlt_(doublereal *, doublereal *, doublereal *, 
  5571.             doublereal *, doublereal *, doublereal *);
  5572.     extern doublereal z1abs_(doublereal *, doublereal *);
  5573.     static integer i, k, m, itime;
  5574.     extern doublereal d1mach_(integer *);
  5575.     static doublereal ak, bk, ap, at;
  5576.     static integer kk, km;
  5577.     static doublereal az;
  5578.     extern doublereal dgamln_(doublereal *, integer *);
  5579.     static doublereal cnormi, cnormr, p1i, p2i, p1r, p2r, ack, cki, fnf, fkk, 
  5580.             ckr;
  5581.     static integer iaz;
  5582.     static doublereal rho;
  5583.     static integer inu;
  5584.     static doublereal pti, raz, sti, rzi, ptr, str, tst, rzr, rho2;
  5585.  
  5586. /* ***BEGIN PROLOGUE  ZMLRI */
  5587. /* ***REFER TO  ZBESI,ZBESK */
  5588.  
  5589. /*     ZMLRI COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY THE */
  5590. /*     MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES. */
  5591.  
  5592. /* ***ROUTINES CALLED  DGAMLN,D1MACH,Z1ABS,ZEXP,ZLOG,ZMLT */
  5593. /* ***END PROLOGUE  ZMLRI */
  5594. /*     COMPLEX CK,CNORM,CONE,CTWO,CZERO,PT,P1,P2,RZ,SUM,Y,Z */
  5595.     /* Parameter adjustments */
  5596.     --yi;
  5597.     --yr;
  5598.  
  5599.     /* Function Body */
  5600.     scle = d1mach_(&c__1) / *tol;
  5601.     *nz = 0;
  5602.     az = z1abs_(zr, zi);
  5603.     iaz = (integer) az;
  5604.     ifnu = (integer) (*fnu);
  5605.     inu = ifnu + *n - 1;
  5606.     at = (doublereal) ((real) iaz) + 1.;
  5607.     raz = 1. / az;
  5608.     str = *zr * raz;
  5609.     sti = -(*zi) * raz;
  5610.     ckr = str * at * raz;
  5611.     cki = sti * at * raz;
  5612.     rzr = (str + str) * raz;
  5613.     rzi = (sti + sti) * raz;
  5614.     p1r = zeror;
  5615.     p1i = zeroi;
  5616.     p2r = coner;
  5617.     p2i = conei;
  5618.     ack = (at + 1.) * raz;
  5619.     rho = ack + sqrt(ack * ack - 1.);
  5620.     rho2 = rho * rho;
  5621.     tst = (rho2 + rho2) / ((rho2 - 1.) * (rho - 1.));
  5622.     tst /= *tol;
  5623. /* -----------------------------------------------------------------------
  5624.  */
  5625. /*     COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES */
  5626. /* -----------------------------------------------------------------------
  5627.  */
  5628.     ak = at;
  5629.     for (i = 1; i <= 80; ++i) {
  5630.         ptr = p2r;
  5631.         pti = p2i;
  5632.         p2r = p1r - (ckr * ptr - cki * pti);
  5633.         p2i = p1i - (cki * ptr + ckr * pti);
  5634.         p1r = ptr;
  5635.         p1i = pti;
  5636.         ckr += rzr;
  5637.         cki += rzi;
  5638.         ap = z1abs_(&p2r, &p2i);
  5639.         if (ap > tst * ak * ak) {
  5640.             goto L20;
  5641.         }
  5642.         ak += 1.;
  5643. /* L10: */
  5644.     }
  5645.     goto L110;
  5646. L20:
  5647.     ++i;
  5648.     k = 0;
  5649.     if (inu < iaz) {
  5650.         goto L40;
  5651.     }
  5652. /* -----------------------------------------------------------------------
  5653.  */
  5654. /*     COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS */
  5655. /* -----------------------------------------------------------------------
  5656.  */
  5657.     p1r = zeror;
  5658.     p1i = zeroi;
  5659.     p2r = coner;
  5660.     p2i = conei;
  5661.     at = (doublereal) ((real) inu) + 1.;
  5662.     str = *zr * raz;
  5663.     sti = -(*zi) * raz;
  5664.     ckr = str * at * raz;
  5665.     cki = sti * at * raz;
  5666.     ack = at * raz;
  5667.     tst = sqrt(ack / *tol);
  5668.     itime = 1;
  5669.     for (k = 1; k <= 80; ++k) {
  5670.         ptr = p2r;
  5671.         pti = p2i;
  5672.         p2r = p1r - (ckr * ptr - cki * pti);
  5673.         p2i = p1i - (ckr * pti + cki * ptr);
  5674.         p1r = ptr;
  5675.         p1i = pti;
  5676.         ckr += rzr;
  5677.         cki += rzi;
  5678.         ap = z1abs_(&p2r, &p2i);
  5679.         if (ap < tst) {
  5680.             goto L30;
  5681.         }
  5682.         if (itime == 2) {
  5683.             goto L40;
  5684.         }
  5685.         ack = z1abs_(&ckr, &cki);
  5686.         flam = ack + sqrt(ack * ack - 1.);
  5687.         fkap = ap / z1abs_(&p1r, &p1i);
  5688.         rho = min(flam,fkap);
  5689.         tst *= sqrt(rho / (rho * rho - 1.));
  5690.         itime = 2;
  5691. L30:
  5692.         ;
  5693.     }
  5694.     goto L110;
  5695. L40:
  5696. /* -----------------------------------------------------------------------
  5697.  */
  5698. /*     BACKWARD RECURRENCE AND SUM NORMALIZING RELATION */
  5699. /* -----------------------------------------------------------------------
  5700.  */
  5701.     ++k;
  5702. /* Computing MAX */
  5703.     i__1 = i + iaz, i__2 = k + inu;
  5704.     kk = max(i__1,i__2);
  5705.     fkk = (doublereal) ((real) kk);
  5706.     p1r = zeror;
  5707.     p1i = zeroi;
  5708. /* -----------------------------------------------------------------------
  5709.  */
  5710. /*     SCALE P2 AND SUM BY SCLE */
  5711. /* -----------------------------------------------------------------------
  5712.  */
  5713.     p2r = scle;
  5714.     p2i = zeroi;
  5715.     fnf = *fnu - (doublereal) ((real) ifnu);
  5716.     tfnf = fnf + fnf;
  5717.     d__1 = fkk + tfnf + 1.;
  5718.     d__2 = fkk + 1.;
  5719.     d__3 = tfnf + 1.;
  5720.     bk = dgamln_(&d__1, &idum) - dgamln_(&d__2, &idum) - dgamln_(&d__3, &idum)
  5721.             ;
  5722.     bk = exp(bk);
  5723.     sumr = zeror;
  5724.     sumi = zeroi;
  5725.     km = kk - inu;
  5726.     i__1 = km;
  5727.     for (i = 1; i <= i__1; ++i) {
  5728.         ptr = p2r;
  5729.         pti = p2i;
  5730.         p2r = p1r + (fkk + fnf) * (rzr * ptr - rzi * pti);
  5731.         p2i = p1i + (fkk + fnf) * (rzi * ptr + rzr * pti);
  5732.         p1r = ptr;
  5733.         p1i = pti;
  5734.         ak = 1. - tfnf / (fkk + tfnf);
  5735.         ack = bk * ak;
  5736.         sumr += (ack + bk) * p1r;
  5737.         sumi += (ack + bk) * p1i;
  5738.         bk = ack;
  5739.         fkk += -1.;
  5740. /* L50: */
  5741.     }
  5742.     yr[*n] = p2r;
  5743.     yi[*n] = p2i;
  5744.     if (*n == 1) {
  5745.         goto L70;
  5746.     }
  5747.     i__1 = *n;
  5748.     for (i = 2; i <= i__1; ++i) {
  5749.         ptr = p2r;
  5750.         pti = p2i;
  5751.         p2r = p1r + (fkk + fnf) * (rzr * ptr - rzi * pti);
  5752.         p2i = p1i + (fkk + fnf) * (rzi * ptr + rzr * pti);
  5753.         p1r = ptr;
  5754.         p1i = pti;
  5755.         ak = 1. - tfnf / (fkk + tfnf);
  5756.         ack = bk * ak;
  5757.         sumr += (ack + bk) * p1r;
  5758.         sumi += (ack + bk) * p1i;
  5759.         bk = ack;
  5760.         fkk += -1.;
  5761.         m = *n - i + 1;
  5762.         yr[m] = p2r;
  5763.         yi[m] = p2i;
  5764. /* L60: */
  5765.     }
  5766. L70:
  5767.     if (ifnu <= 0) {
  5768.         goto L90;
  5769.     }
  5770.     i__1 = ifnu;
  5771.     for (i = 1; i <= i__1; ++i) {
  5772.         ptr = p2r;
  5773.         pti = p2i;
  5774.         p2r = p1r + (fkk + fnf) * (rzr * ptr - rzi * pti);
  5775.         p2i = p1i + (fkk + fnf) * (rzr * pti + rzi * ptr);
  5776.         p1r = ptr;
  5777.         p1i = pti;
  5778.         ak = 1. - tfnf / (fkk + tfnf);
  5779.         ack = bk * ak;
  5780.         sumr += (ack + bk) * p1r;
  5781.         sumi += (ack + bk) * p1i;
  5782.         bk = ack;
  5783.         fkk += -1.;
  5784. /* L80: */
  5785.     }
  5786. L90:
  5787.     ptr = *zr;
  5788.     pti = *zi;
  5789.     if (*kode == 2) {
  5790.         ptr = zeror;
  5791.     }
  5792.     zlog_(&rzr, &rzi, &str, &sti, &idum);
  5793.     p1r = -fnf * str + ptr;
  5794.     p1i = -fnf * sti + pti;
  5795.     d__1 = fnf + 1.;
  5796.     ap = dgamln_(&d__1, &idum);
  5797.     ptr = p1r - ap;
  5798.     pti = p1i;
  5799. /* -----------------------------------------------------------------------
  5800.  */
  5801. /*     THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW */
  5802. /*     IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES */
  5803. /* -----------------------------------------------------------------------
  5804.  */
  5805.     p2r += sumr;
  5806.     p2i += sumi;
  5807.     ap = z1abs_(&p2r, &p2i);
  5808.     p1r = 1. / ap;
  5809.     zexp_(&ptr, &pti, &str, &sti);
  5810.     ckr = str * p1r;
  5811.     cki = sti * p1r;
  5812.     ptr = p2r * p1r;
  5813.     pti = -p2i * p1r;
  5814.     zmlt_(&ckr, &cki, &ptr, &pti, &cnormr, &cnormi);
  5815.     i__1 = *n;
  5816.     for (i = 1; i <= i__1; ++i) {
  5817.         str = yr[i] * cnormr - yi[i] * cnormi;
  5818.         yi[i] = yr[i] * cnormi + yi[i] * cnormr;
  5819.         yr[i] = str;
  5820. /* L100: */
  5821.     }
  5822.     return 0;
  5823. L110:
  5824.     *nz = -2;
  5825.     return 0;
  5826. } /* zmlri_ */
  5827.  
  5828. /* Subroutine */ int zmlt_(doublereal *ar, doublereal *ai, doublereal *br, 
  5829.         doublereal *bi, doublereal *cr, doublereal *ci)
  5830. {
  5831.     static doublereal ca, cb;
  5832.  
  5833. /* ***BEGIN PROLOGUE  ZMLT */
  5834. /* ***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY */
  5835.  
  5836. /*     DOUBLE PRECISION COMPLEX MULTIPLY, C=A*B. */
  5837.  
  5838. /* ***ROUTINES CALLED  (NONE) */
  5839. /* ***END PROLOGUE  ZMLT */
  5840.     ca = *ar * *br - *ai * *bi;
  5841.     cb = *ar * *bi + *ai * *br;
  5842.     *cr = ca;
  5843.     *ci = cb;
  5844.     return 0;
  5845. } /* zmlt_ */
  5846.  
  5847. /* Subroutine */ int zrati_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  5848.         integer *n, doublereal *cyr, doublereal *cyi, doublereal *tol)
  5849. {
  5850.     /* Initialized data */
  5851.  
  5852.     static doublereal czeror = 0.;
  5853.     static doublereal czeroi = 0.;
  5854.     static doublereal coner = 1.;
  5855.     static doublereal conei = 0.;
  5856.     static doublereal rt2 = 1.41421356237309505;
  5857.  
  5858.     /* System generated locals */
  5859.     integer i__1;
  5860.     doublereal d__1;
  5861.  
  5862.     /* Builtin functions */
  5863.     double sqrt(doublereal);
  5864.  
  5865.     /* Local variables */
  5866.     static doublereal flam, dfnu, fdnu;
  5867.     static integer magz, idnu;
  5868.     static doublereal fnup;
  5869.     extern /* Subroutine */ int zdiv_(doublereal *, doublereal *, doublereal *
  5870.             , doublereal *, doublereal *, doublereal *);
  5871.     static doublereal test;
  5872.     extern doublereal z1abs_(doublereal *, doublereal *);
  5873.     static doublereal test1;
  5874.     static integer i, k;
  5875.     static doublereal amagz;
  5876.     static integer itime;
  5877.     static doublereal ak;
  5878.     static integer id, kk;
  5879.     static doublereal az, cdfnui, cdfnur, ap1, ap2, p1i, p2i, t1i, p1r, p2r, 
  5880.             t1r, arg, rak, rho;
  5881.     static integer inu;
  5882.     static doublereal pti, tti, rzi, ptr, ttr, rzr, rap1;
  5883.  
  5884. /* ***BEGIN PROLOGUE  ZRATI */
  5885. /* ***REFER TO  ZBESI,ZBESK,ZBESH */
  5886.  
  5887. /*     ZRATI COMPUTES RATIOS OF I BESSEL FUNCTIONS BY BACKWARD */
  5888. /*     RECURRENCE.  THE STARTING INDEX IS DETERMINED BY FORWARD */
  5889. /*     RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B, */
  5890. /*     MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973, */
  5891. /*     BESSEL FUNCTIONS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER, */
  5892. /*     BY D. J. SOOKNE. */
  5893.  
  5894. /* ***ROUTINES CALLED  Z1ABS,ZDIV */
  5895. /* ***END PROLOGUE  ZRATI */
  5896. /*     COMPLEX Z,CY(1),CONE,CZERO,P1,P2,T1,RZ,PT,CDFNU */
  5897.     /* Parameter adjustments */
  5898.     --cyi;
  5899.     --cyr;
  5900.  
  5901.     /* Function Body */
  5902.     az = z1abs_(zr, zi);
  5903.     inu = (integer) (*fnu);
  5904.     idnu = inu + *n - 1;
  5905.     magz = (integer) az;
  5906.     amagz = (doublereal) ((real) (magz + 1));
  5907.     fdnu = (doublereal) ((real) idnu);
  5908.     fnup = max(amagz,fdnu);
  5909.     id = idnu - magz - 1;
  5910.     itime = 1;
  5911.     k = 1;
  5912.     ptr = 1. / az;
  5913.     rzr = ptr * (*zr + *zr) * ptr;
  5914.     rzi = -ptr * (*zi + *zi) * ptr;
  5915.     t1r = rzr * fnup;
  5916.     t1i = rzi * fnup;
  5917.     p2r = -t1r;
  5918.     p2i = -t1i;
  5919.     p1r = coner;
  5920.     p1i = conei;
  5921.     t1r += rzr;
  5922.     t1i += rzi;
  5923.     if (id > 0) {
  5924.         id = 0;
  5925.     }
  5926.     ap2 = z1abs_(&p2r, &p2i);
  5927.     ap1 = z1abs_(&p1r, &p1i);
  5928. /* -----------------------------------------------------------------------
  5929.  */
  5930. /*     THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNU */
  5931. /*     GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT */
  5932. /*     P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR */
  5933. /*     PREMATURELY. */
  5934. /* -----------------------------------------------------------------------
  5935.  */
  5936.     arg = (ap2 + ap2) / (ap1 * *tol);
  5937.     test1 = sqrt(arg);
  5938.     test = test1;
  5939.     rap1 = 1. / ap1;
  5940.     p1r *= rap1;
  5941.     p1i *= rap1;
  5942.     p2r *= rap1;
  5943.     p2i *= rap1;
  5944.     ap2 *= rap1;
  5945. L10:
  5946.     ++k;
  5947.     ap1 = ap2;
  5948.     ptr = p2r;
  5949.     pti = p2i;
  5950.     p2r = p1r - (t1r * ptr - t1i * pti);
  5951.     p2i = p1i - (t1r * pti + t1i * ptr);
  5952.     p1r = ptr;
  5953.     p1i = pti;
  5954.     t1r += rzr;
  5955.     t1i += rzi;
  5956.     ap2 = z1abs_(&p2r, &p2i);
  5957.     if (ap1 <= test) {
  5958.         goto L10;
  5959.     }
  5960.     if (itime == 2) {
  5961.         goto L20;
  5962.     }
  5963.     ak = z1abs_(&t1r, &t1i) * .5;
  5964.     flam = ak + sqrt(ak * ak - 1.);
  5965. /* Computing MIN */
  5966.     d__1 = ap2 / ap1;
  5967.     rho = min(d__1,flam);
  5968.     test = test1 * sqrt(rho / (rho * rho - 1.));
  5969.     itime = 2;
  5970.     goto L10;
  5971. L20:
  5972.     kk = k + 1 - id;
  5973.     ak = (doublereal) ((real) kk);
  5974.     t1r = ak;
  5975.     t1i = czeroi;
  5976.     dfnu = *fnu + (doublereal) ((real) (*n - 1));
  5977.     p1r = 1. / ap2;
  5978.     p1i = czeroi;
  5979.     p2r = czeror;
  5980.     p2i = czeroi;
  5981.     i__1 = kk;
  5982.     for (i = 1; i <= i__1; ++i) {
  5983.         ptr = p1r;
  5984.         pti = p1i;
  5985.         rap1 = dfnu + t1r;
  5986.         ttr = rzr * rap1;
  5987.         tti = rzi * rap1;
  5988.         p1r = ptr * ttr - pti * tti + p2r;
  5989.         p1i = ptr * tti + pti * ttr + p2i;
  5990.         p2r = ptr;
  5991.         p2i = pti;
  5992.         t1r -= coner;
  5993. /* L30: */
  5994.     }
  5995.     if (p1r != czeror || p1i != czeroi) {
  5996.         goto L40;
  5997.     }
  5998.     p1r = *tol;
  5999.     p1i = *tol;
  6000. L40:
  6001.     zdiv_(&p2r, &p2i, &p1r, &p1i, &cyr[*n], &cyi[*n]);
  6002.     if (*n == 1) {
  6003.         return 0;
  6004.     }
  6005.     k = *n - 1;
  6006.     ak = (doublereal) ((real) k);
  6007.     t1r = ak;
  6008.     t1i = czeroi;
  6009.     cdfnur = *fnu * rzr;
  6010.     cdfnui = *fnu * rzi;
  6011.     i__1 = *n;
  6012.     for (i = 2; i <= i__1; ++i) {
  6013.         ptr = cdfnur + (t1r * rzr - t1i * rzi) + cyr[k + 1];
  6014.         pti = cdfnui + (t1r * rzi + t1i * rzr) + cyi[k + 1];
  6015.         ak = z1abs_(&ptr, &pti);
  6016.         if (ak != czeror) {
  6017.             goto L50;
  6018.         }
  6019.         ptr = *tol;
  6020.         pti = *tol;
  6021.         ak = *tol * rt2;
  6022. L50:
  6023.         rak = coner / ak;
  6024.         cyr[k] = rak * ptr * rak;
  6025.         cyi[k] = -rak * pti * rak;
  6026.         t1r -= coner;
  6027.         --k;
  6028. /* L60: */
  6029.     }
  6030.     return 0;
  6031. } /* zrati_ */
  6032.  
  6033. /* Subroutine */ int zs1s2_(doublereal *zrr, doublereal *zri, doublereal *s1r,
  6034.          doublereal *s1i, doublereal *s2r, doublereal *s2i, integer *nz, 
  6035.         doublereal *ascle, doublereal *alim, integer *iuf)
  6036. {
  6037.     /* Initialized data */
  6038.  
  6039.     static doublereal zeror = 0.;
  6040.     static doublereal zeroi = 0.;
  6041.  
  6042.     /* Builtin functions */
  6043.     double log(doublereal);
  6044.  
  6045.     /* Local variables */
  6046.     static integer idum;
  6047.     extern /* Subroutine */ int zlog_(doublereal *, doublereal *, doublereal *
  6048.             , doublereal *, integer *), zexp_(doublereal *, doublereal *, 
  6049.             doublereal *, doublereal *);
  6050.     extern doublereal z1abs_(doublereal *, doublereal *);
  6051.     static doublereal aa, c1i, as1, as2, c1r, aln, s1di, s1dr;
  6052.  
  6053. /* ***BEGIN PROLOGUE  ZS1S2 */
  6054. /* ***REFER TO  ZBESK,ZAIRY */
  6055.  
  6056. /*     ZS1S2 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE */
  6057. /*     ADDITION OF THE I AND K FUNCTIONS IN THE ANALYTIC CON- */
  6058. /*     TINUATION FORMULA WHERE S1=K FUNCTION AND S2=I FUNCTION. */
  6059. /*     ON KODE=1 THE I AND K FUNCTIONS ARE DIFFERENT ORDERS OF */
  6060. /*     MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER */
  6061. /*     OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE */
  6062. /*     PRECISION ABOVE THE UNDERFLOW LIMIT. */
  6063.  
  6064. /* ***ROUTINES CALLED  Z1ABS,ZEXP,ZLOG */
  6065. /* ***END PROLOGUE  ZS1S2 */
  6066. /*     COMPLEX CZERO,C1,S1,S1D,S2,ZR */
  6067.     *nz = 0;
  6068.     as1 = z1abs_(s1r, s1i);
  6069.     as2 = z1abs_(s2r, s2i);
  6070.     if (*s1r == 0. && *s1i == 0.) {
  6071.         goto L10;
  6072.     }
  6073.     if (as1 == 0.) {
  6074.         goto L10;
  6075.     }
  6076.     aln = -(*zrr) - *zrr + log(as1);
  6077.     s1dr = *s1r;
  6078.     s1di = *s1i;
  6079.     *s1r = zeror;
  6080.     *s1i = zeroi;
  6081.     as1 = zeror;
  6082.     if (aln < -(*alim)) {
  6083.         goto L10;
  6084.     }
  6085.     zlog_(&s1dr, &s1di, &c1r, &c1i, &idum);
  6086.     c1r = c1r - *zrr - *zrr;
  6087.     c1i = c1i - *zri - *zri;
  6088.     zexp_(&c1r, &c1i, s1r, s1i);
  6089.     as1 = z1abs_(s1r, s1i);
  6090.     ++(*iuf);
  6091. L10:
  6092.     aa = max(as1,as2);
  6093.     if (aa > *ascle) {
  6094.         return 0;
  6095.     }
  6096.     *s1r = zeror;
  6097.     *s1i = zeroi;
  6098.     *s2r = zeror;
  6099.     *s2i = zeroi;
  6100.     *nz = 1;
  6101.     *iuf = 0;
  6102.     return 0;
  6103. } /* zs1s2_ */
  6104.  
  6105. /* Subroutine */ int zseri_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  6106.         integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
  6107.         nz, doublereal *tol, doublereal *elim, doublereal *alim)
  6108. {
  6109.     /* Initialized data */
  6110.  
  6111.     static doublereal zeror = 0.;
  6112.     static doublereal zeroi = 0.;
  6113.     static doublereal coner = 1.;
  6114.     static doublereal conei = 0.;
  6115.  
  6116.     /* System generated locals */
  6117.     integer i__1;
  6118.  
  6119.     /* Builtin functions */
  6120.     double sqrt(doublereal), exp(doublereal), cos(doublereal), sin(doublereal)
  6121.             ;
  6122.  
  6123.     /* Local variables */
  6124.     static doublereal dfnu;
  6125.     static integer idum;
  6126.     static doublereal atol, fnup;
  6127.     extern /* Subroutine */ int zlog_(doublereal *, doublereal *, doublereal *
  6128.             , doublereal *, integer *), zdiv_(doublereal *, doublereal *, 
  6129.             doublereal *, doublereal *, doublereal *, doublereal *), zmlt_(
  6130.             doublereal *, doublereal *, doublereal *, doublereal *, 
  6131.             doublereal *, doublereal *);
  6132.     extern doublereal z1abs_(doublereal *, doublereal *);
  6133.     static integer i, k, l, m, iflag;
  6134.     static doublereal s, coefi, ascle, coefr, crscr;
  6135.     extern /* Subroutine */ int zuchk_(doublereal *, doublereal *, integer *, 
  6136.             doublereal *, doublereal *);
  6137.     extern doublereal d1mach_(integer *);
  6138.     static doublereal aa;
  6139.     static integer ib;
  6140.     static doublereal ak;
  6141.     static integer il;
  6142.     static doublereal az;
  6143.     static integer nn;
  6144.     static doublereal wi[2];
  6145.     extern doublereal dgamln_(doublereal *, integer *);
  6146.     static doublereal rs, ss;
  6147.     static integer nw;
  6148.     static doublereal wr[2], s1i, s2i, s1r, s2r, cki, acz, arm, ckr, czi, hzi,
  6149.              raz, czr, sti, hzr, rzi, str, rzr, ak1i, ak1r, rtr1;
  6150.  
  6151. /* ***BEGIN PROLOGUE  ZSERI */
  6152. /* ***REFER TO  ZBESI,ZBESK */
  6153.  
  6154. /*     ZSERI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY */
  6155. /*     MEANS OF THE POWER SERIES FOR LARGE CABS(Z) IN THE */
  6156. /*     REGION CABS(Z).LE.2*SQRT(FNU+1). NZ=0 IS A NORMAL RETURN. */
  6157. /*     NZ.GT.0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO */
  6158. /*     DUE TO UNDERFLOW. NZ.LT.0 MEANS UNDERFLOW OCCURRED, BUT THE */
  6159. /*     CONDITION CABS(Z).LE.2*SQRT(FNU+1) WAS VIOLATED AND THE */
  6160. /*     COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ). 
  6161. */
  6162.  
  6163. /* ***ROUTINES CALLED  DGAMLN,D1MACH,ZUCHK,Z1ABS,ZDIV,ZLOG,ZMLT */
  6164. /* ***END PROLOGUE  ZSERI */
  6165. /*     COMPLEX AK1,CK,COEF,CONE,CRSC,CSCL,CZ,CZERO,HZ,RZ,S1,S2,Y,Z */
  6166.     /* Parameter adjustments */
  6167.     --yi;
  6168.     --yr;
  6169.  
  6170.     /* Function Body */
  6171.  
  6172.     *nz = 0;
  6173.     az = z1abs_(zr, zi);
  6174.     if (az == 0.) {
  6175.         goto L160;
  6176.     }
  6177.     arm = d1mach_(&c__1) * 1e3;
  6178.     rtr1 = sqrt(arm);
  6179.     crscr = 1.;
  6180.     iflag = 0;
  6181.     if (az < arm) {
  6182.         goto L150;
  6183.     }
  6184.     hzr = *zr * .5;
  6185.     hzi = *zi * .5;
  6186.     czr = zeror;
  6187.     czi = zeroi;
  6188.     if (az <= rtr1) {
  6189.         goto L10;
  6190.     }
  6191.     zmlt_(&hzr, &hzi, &hzr, &hzi, &czr, &czi);
  6192. L10:
  6193.     acz = z1abs_(&czr, &czi);
  6194.     nn = *n;
  6195.     zlog_(&hzr, &hzi, &ckr, &cki, &idum);
  6196. L20:
  6197.     dfnu = *fnu + (doublereal) ((real) (nn - 1));
  6198.     fnup = dfnu + 1.;
  6199. /* -----------------------------------------------------------------------
  6200.  */
  6201. /*     UNDERFLOW TEST */
  6202. /* -----------------------------------------------------------------------
  6203.  */
  6204.     ak1r = ckr * dfnu;
  6205.     ak1i = cki * dfnu;
  6206.     ak = dgamln_(&fnup, &idum);
  6207.     ak1r -= ak;
  6208.     if (*kode == 2) {
  6209.         ak1r -= *zr;
  6210.     }
  6211.     if (ak1r > -(*elim)) {
  6212.         goto L40;
  6213.     }
  6214. L30:
  6215.     ++(*nz);
  6216.     yr[nn] = zeror;
  6217.     yi[nn] = zeroi;
  6218.     if (acz > dfnu) {
  6219.         goto L190;
  6220.     }
  6221.     --nn;
  6222.     if (nn == 0) {
  6223.         return 0;
  6224.     }
  6225.     goto L20;
  6226. L40:
  6227.     if (ak1r > -(*alim)) {
  6228.         goto L50;
  6229.     }
  6230.     iflag = 1;
  6231.     ss = 1. / *tol;
  6232.     crscr = *tol;
  6233.     ascle = arm * ss;
  6234. L50:
  6235.     aa = exp(ak1r);
  6236.     if (iflag == 1) {
  6237.         aa *= ss;
  6238.     }
  6239.     coefr = aa * cos(ak1i);
  6240.     coefi = aa * sin(ak1i);
  6241.     atol = *tol * acz / fnup;
  6242.     il = min(2,nn);
  6243.     i__1 = il;
  6244.     for (i = 1; i <= i__1; ++i) {
  6245.         dfnu = *fnu + (doublereal) ((real) (nn - i));
  6246.         fnup = dfnu + 1.;
  6247.         s1r = coner;
  6248.         s1i = conei;
  6249.         if (acz < *tol * fnup) {
  6250.             goto L70;
  6251.         }
  6252.         ak1r = coner;
  6253.         ak1i = conei;
  6254.         ak = fnup + 2.;
  6255.         s = fnup;
  6256.         aa = 2.;
  6257. L60:
  6258.         rs = 1. / s;
  6259.         str = ak1r * czr - ak1i * czi;
  6260.         sti = ak1r * czi + ak1i * czr;
  6261.         ak1r = str * rs;
  6262.         ak1i = sti * rs;
  6263.         s1r += ak1r;
  6264.         s1i += ak1i;
  6265.         s += ak;
  6266.         ak += 2.;
  6267.         aa = aa * acz * rs;
  6268.         if (aa > atol) {
  6269.             goto L60;
  6270.         }
  6271. L70:
  6272.         s2r = s1r * coefr - s1i * coefi;
  6273.         s2i = s1r * coefi + s1i * coefr;
  6274.         wr[i - 1] = s2r;
  6275.         wi[i - 1] = s2i;
  6276.         if (iflag == 0) {
  6277.             goto L80;
  6278.         }
  6279.         zuchk_(&s2r, &s2i, &nw, &ascle, tol);
  6280.         if (nw != 0) {
  6281.             goto L30;
  6282.         }
  6283. L80:
  6284.         m = nn - i + 1;
  6285.         yr[m] = s2r * crscr;
  6286.         yi[m] = s2i * crscr;
  6287.         if (i == il) {
  6288.             goto L90;
  6289.         }
  6290.         zdiv_(&coefr, &coefi, &hzr, &hzi, &str, &sti);
  6291.         coefr = str * dfnu;
  6292.         coefi = sti * dfnu;
  6293. L90:
  6294.         ;
  6295.     }
  6296.     if (nn <= 2) {
  6297.         return 0;
  6298.     }
  6299.     k = nn - 2;
  6300.     ak = (doublereal) ((real) k);
  6301.     raz = 1. / az;
  6302.     str = *zr * raz;
  6303.     sti = -(*zi) * raz;
  6304.     rzr = (str + str) * raz;
  6305.     rzi = (sti + sti) * raz;
  6306.     if (iflag == 1) {
  6307.         goto L120;
  6308.     }
  6309.     ib = 3;
  6310. L100:
  6311.     i__1 = nn;
  6312.     for (i = ib; i <= i__1; ++i) {
  6313.         yr[k] = (ak + *fnu) * (rzr * yr[k + 1] - rzi * yi[k + 1]) + yr[k + 2];
  6314.  
  6315.         yi[k] = (ak + *fnu) * (rzr * yi[k + 1] + rzi * yr[k + 1]) + yi[k + 2];
  6316.  
  6317.         ak += -1.;
  6318.         --k;
  6319. /* L110: */
  6320.     }
  6321.     return 0;
  6322. /* -----------------------------------------------------------------------
  6323.  */
  6324. /*     RECUR BACKWARD WITH SCALED VALUES */
  6325. /* -----------------------------------------------------------------------
  6326.  */
  6327. L120:
  6328. /* -----------------------------------------------------------------------
  6329.  */
  6330. /*     EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE */
  6331. /*     UNDERFLOW LIMIT = ASCLE = D1MACH(1)*SS*1.0D+3 */
  6332. /* -----------------------------------------------------------------------
  6333.  */
  6334.     s1r = wr[0];
  6335.     s1i = wi[0];
  6336.     s2r = wr[1];
  6337.     s2i = wi[1];
  6338.     i__1 = nn;
  6339.     for (l = 3; l <= i__1; ++l) {
  6340.         ckr = s2r;
  6341.         cki = s2i;
  6342.         s2r = s1r + (ak + *fnu) * (rzr * ckr - rzi * cki);
  6343.         s2i = s1i + (ak + *fnu) * (rzr * cki + rzi * ckr);
  6344.         s1r = ckr;
  6345.         s1i = cki;
  6346.         ckr = s2r * crscr;
  6347.         cki = s2i * crscr;
  6348.         yr[k] = ckr;
  6349.         yi[k] = cki;
  6350.         ak += -1.;
  6351.         --k;
  6352.         if (z1abs_(&ckr, &cki) > ascle) {
  6353.             goto L140;
  6354.         }
  6355. /* L130: */
  6356.     }
  6357.     return 0;
  6358. L140:
  6359.     ib = l + 1;
  6360.     if (ib > nn) {
  6361.         return 0;
  6362.     }
  6363.     goto L100;
  6364. L150:
  6365.     *nz = *n;
  6366.     if (*fnu == 0.) {
  6367.         --(*nz);
  6368.     }
  6369. L160:
  6370.     yr[1] = zeror;
  6371.     yi[1] = zeroi;
  6372.     if (*fnu != 0.) {
  6373.         goto L170;
  6374.     }
  6375.     yr[1] = coner;
  6376.     yi[1] = conei;
  6377. L170:
  6378.     if (*n == 1) {
  6379.         return 0;
  6380.     }
  6381.     i__1 = *n;
  6382.     for (i = 2; i <= i__1; ++i) {
  6383.         yr[i] = zeror;
  6384.         yi[i] = zeroi;
  6385. /* L180: */
  6386.     }
  6387.     return 0;
  6388. /* -----------------------------------------------------------------------
  6389.  */
  6390. /*     RETURN WITH NZ.LT.0 IF CABS(Z*Z/4).GT.FNU+N-NZ-1 COMPLETE */
  6391. /*     THE CALCULATION IN CBINU WITH N=N-IABS(NZ) */
  6392. /* -----------------------------------------------------------------------
  6393.  */
  6394. L190:
  6395.     *nz = -(*nz);
  6396.     return 0;
  6397. } /* zseri_ */
  6398.  
  6399. /* Subroutine */ int zshch_(doublereal *zr, doublereal *zi, doublereal *cshr, 
  6400.         doublereal *cshi, doublereal *cchr, doublereal *cchi)
  6401. {
  6402.     /* Builtin functions */
  6403.     double sinh(doublereal), cosh(doublereal), sin(doublereal), cos(
  6404.             doublereal);
  6405.  
  6406.     /* Local variables */
  6407.     static doublereal ch, cn, sh, sn;
  6408.  
  6409. /* ***BEGIN PROLOGUE  ZSHCH */
  6410. /* ***REFER TO  ZBESK,ZBESH */
  6411.  
  6412. /*     ZSHCH COMPUTES THE COMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y) */
  6413. /*     AND CCH=COSH(X+I*Y), WHERE I**2=-1. */
  6414.  
  6415. /* ***ROUTINES CALLED  (NONE) */
  6416. /* ***END PROLOGUE  ZSHCH */
  6417.  
  6418.     sh = sinh(*zr);
  6419.     ch = cosh(*zr);
  6420.     sn = sin(*zi);
  6421.     cn = cos(*zi);
  6422.     *cshr = sh * cn;
  6423.     *cshi = ch * sn;
  6424.     *cchr = ch * cn;
  6425.     *cchi = sh * sn;
  6426.     return 0;
  6427. } /* zshch_ */
  6428.  
  6429. /* funz5.f -- translated by f2c (version of 16 May 1991  13:06:06).
  6430.    You must link the resulting object file with the libraries:
  6431.         -link <S|C|M|L>f2c.lib   (in that order)
  6432. */
  6433.  
  6434.  
  6435.  
  6436. /* Table of constant values */
  6437. static integer c__0 = 0;
  6438. /*
  6439. static integer c__1 = 1;
  6440. static integer c__2 = 2;
  6441. */
  6442. /* Subroutine */ int zsqrt_(doublereal *ar, doublereal *ai, doublereal *br, 
  6443.         doublereal *bi)
  6444. {
  6445.     /* Initialized data */
  6446.  
  6447.     static doublereal drt = .7071067811865475244008443621;
  6448.     static doublereal dpi = 3.141592653589793238462643383;
  6449.  
  6450.     /* Builtin functions */
  6451.     double sqrt(doublereal), atan(doublereal), cos(doublereal), sin(
  6452.             doublereal);
  6453.  
  6454.     /* Local variables */
  6455.     extern doublereal z1abs_(doublereal *, doublereal *);
  6456.     static doublereal zm, dtheta;
  6457.  
  6458. /* ***BEGIN PROLOGUE  ZSQRT */
  6459. /* ***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY */
  6460.  
  6461. /*     DOUBLE PRECISION COMPLEX SQUARE ROOT, B=CSQRT(A) */
  6462.  
  6463. /* ***ROUTINES CALLED  Z1ABS */
  6464. /* ***END PROLOGUE  ZSQRT */
  6465.     zm = z1abs_(ar, ai);
  6466.     zm = sqrt(zm);
  6467.     if (*ar == 0.) {
  6468.         goto L10;
  6469.     }
  6470.     if (*ai == 0.) {
  6471.         goto L20;
  6472.     }
  6473.     dtheta = atan(*ai / *ar);
  6474.     if (dtheta <= 0.) {
  6475.         goto L40;
  6476.     }
  6477.     if (*ar < 0.) {
  6478.         dtheta -= dpi;
  6479.     }
  6480.     goto L50;
  6481. L10:
  6482.     if (*ai > 0.) {
  6483.         goto L60;
  6484.     }
  6485.     if (*ai < 0.) {
  6486.         goto L70;
  6487.     }
  6488.     *br = 0.;
  6489.     *bi = 0.;
  6490.     return 0;
  6491. L20:
  6492.     if (*ar > 0.) {
  6493.         goto L30;
  6494.     }
  6495.     *br = 0.;
  6496.     *bi = sqrt((abs(*ar)));
  6497.     return 0;
  6498. L30:
  6499.     *br = sqrt(*ar);
  6500.     *bi = 0.;
  6501.     return 0;
  6502. L40:
  6503.     if (*ar < 0.) {
  6504.         dtheta += dpi;
  6505.     }
  6506. L50:
  6507.     dtheta *= .5;
  6508.     *br = zm * cos(dtheta);
  6509.     *bi = zm * sin(dtheta);
  6510.     return 0;
  6511. L60:
  6512.     *br = zm * drt;
  6513.     *bi = zm * drt;
  6514.     return 0;
  6515. L70:
  6516.     *br = zm * drt;
  6517.     *bi = -zm * drt;
  6518.     return 0;
  6519. } /* zsqrt_ */
  6520.  
  6521. /* Subroutine */ int zuchk_(doublereal *yr, doublereal *yi, integer *nz, 
  6522.         doublereal *ascle, doublereal *tol)
  6523. {
  6524.     static doublereal wi, ss, st, wr;
  6525.  
  6526. /* ***BEGIN PROLOGUE  ZUCHK */
  6527. /* ***REFER TO ZSERI,ZUOIK,ZUNK1,ZUNK2,ZUNI1,ZUNI2,ZKSCL */
  6528.  
  6529. /*      Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN */
  6530. /*      EXP(-ALIM)=ASCLE=1.0E+3*D1MACH(1)/TOL. THE TEST IS MADE TO SEE */
  6531. /*      IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDERFLOW */
  6532. /*      WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED */
  6533. /*      IF THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE */
  6534. /*      OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE 
  6535. */
  6536. /*      ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED. */
  6537.  
  6538. /* ***ROUTINES CALLED  (NONE) */
  6539. /* ***END PROLOGUE  ZUCHK */
  6540.  
  6541. /*     COMPLEX Y */
  6542.     *nz = 0;
  6543.     wr = abs(*yr);
  6544.     wi = abs(*yi);
  6545.     st = min(wr,wi);
  6546.     if (st > *ascle) {
  6547.         return 0;
  6548.     }
  6549.     ss = max(wr,wi);
  6550.     st /= *tol;
  6551.     if (ss < st) {
  6552.         *nz = 1;
  6553.     }
  6554.     return 0;
  6555. } /* zuchk_ */
  6556.  
  6557. /* Subroutine */ int zunhj_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  6558.         integer *ipmtr, doublereal *tol, doublereal *phir, doublereal *phii, 
  6559.         doublereal *argr, doublereal *argi, doublereal *zeta1r, doublereal *
  6560.         zeta1i, doublereal *zeta2r, doublereal *zeta2i, doublereal *asumr, 
  6561.         doublereal *asumi, doublereal *bsumr, doublereal *bsumi)
  6562. {
  6563.     /* Initialized data */
  6564.  
  6565.     static doublereal br[14] = { 1.,-.145833333333333333,
  6566.             -.0987413194444444444,-.143312053915895062,-.317227202678413548,
  6567.             -.942429147957120249,-3.51120304082635426,-15.7272636203680451,
  6568.             -82.2814390971859444,-492.355370523670524,-3316.21856854797251,
  6569.             -24827.6742452085896,-204526.587315129788,-1838444.9170682099 };
  6570.     static doublereal c[105] = { 1.,-.208333333333333333,.125,
  6571.             .334201388888888889,-.401041666666666667,.0703125,
  6572.             -1.02581259645061728,1.84646267361111111,-.8912109375,.0732421875,
  6573.             4.66958442342624743,-11.2070026162229938,8.78912353515625,
  6574.             -2.3640869140625,.112152099609375,-28.2120725582002449,
  6575.             84.6362176746007346,-91.8182415432400174,42.5349987453884549,
  6576.             -7.3687943594796317,.227108001708984375,212.570130039217123,
  6577.             -765.252468141181642,1059.99045252799988,-699.579627376132541,
  6578.             218.19051174421159,-26.4914304869515555,.572501420974731445,
  6579.             -1919.457662318407,8061.72218173730938,-13586.5500064341374,
  6580.             11655.3933368645332,-5305.64697861340311,1200.90291321635246,
  6581.             -108.090919788394656,1.7277275025844574,20204.2913309661486,
  6582.             -96980.5983886375135,192547.001232531532,-203400.177280415534,
  6583.             122200.46498301746,-41192.6549688975513,7109.51430248936372,
  6584.             -493.915304773088012,6.07404200127348304,-242919.187900551333,
  6585.             1311763.6146629772,-2998015.91853810675,3763271.297656404,
  6586.             -2813563.22658653411,1268365.27332162478,-331645.172484563578,
  6587.             45218.7689813627263,-2499.83048181120962,24.3805296995560639,
  6588.             3284469.85307203782,-19706819.1184322269,50952602.4926646422,
  6589.             -74105148.2115326577,66344512.2747290267,-37567176.6607633513,
  6590.             13288767.1664218183,-2785618.12808645469,308186.404612662398,
  6591.             -13886.0897537170405,110.017140269246738,-49329253.664509962,
  6592.             325573074.185765749,-939462359.681578403,1553596899.57058006,
  6593.             -1621080552.10833708,1106842816.82301447,-495889784.275030309,
  6594.             142062907.797533095,-24474062.7257387285,2243768.17792244943,
  6595.             -84005.4336030240853,551.335896122020586,814789096.118312115,
  6596.             -5866481492.05184723,18688207509.2958249,-34632043388.1587779,
  6597.             41280185579.753974,-33026599749.8007231,17954213731.1556001,
  6598.             -6563293792.61928433,1559279864.87925751,-225105661.889415278,
  6599.             17395107.5539781645,-549842.327572288687,3038.09051092238427,
  6600.             -14679261247.6956167,114498237732.02581,-399096175224.466498,
  6601.             819218669548.577329,-1098375156081.22331,1008158106865.38209,
  6602.             -645364869245.376503,287900649906.150589,-87867072178.0232657,
  6603.             17634730606.8349694,-2167164983.22379509,143157876.718888981,
  6604.             -3871833.44257261262,18257.7554742931747 };
  6605.     static doublereal alfa[180] = { -.00444444444444444444,
  6606.             -9.22077922077922078e-4,-8.84892884892884893e-5,
  6607.             1.65927687832449737e-4,2.4669137274179291e-4,
  6608.             2.6599558934625478e-4,2.61824297061500945e-4,
  6609.             2.48730437344655609e-4,2.32721040083232098e-4,
  6610.             2.16362485712365082e-4,2.00738858762752355e-4,
  6611.             1.86267636637545172e-4,1.73060775917876493e-4,
  6612.             1.61091705929015752e-4,1.50274774160908134e-4,
  6613.             1.40503497391269794e-4,1.31668816545922806e-4,
  6614.             1.23667445598253261e-4,1.16405271474737902e-4,
  6615.             1.09798298372713369e-4,1.03772410422992823e-4,
  6616.             9.82626078369363448e-5,9.32120517249503256e-5,
  6617.             8.85710852478711718e-5,8.42963105715700223e-5,
  6618.             8.03497548407791151e-5,7.66981345359207388e-5,
  6619.             7.33122157481777809e-5,7.01662625163141333e-5,
  6620.             6.72375633790160292e-5,6.93735541354588974e-4,
  6621.             2.32241745182921654e-4,-1.41986273556691197e-5,
  6622.             -1.1644493167204864e-4,-1.50803558053048762e-4,
  6623.             -1.55121924918096223e-4,-1.46809756646465549e-4,
  6624.             -1.33815503867491367e-4,-1.19744975684254051e-4,
  6625.             -1.0618431920797402e-4,-9.37699549891194492e-5,
  6626.             -8.26923045588193274e-5,-7.29374348155221211e-5,
  6627.             -6.44042357721016283e-5,-5.69611566009369048e-5,
  6628.             -5.04731044303561628e-5,-4.48134868008882786e-5,
  6629.             -3.98688727717598864e-5,-3.55400532972042498e-5,
  6630.             -3.1741425660902248e-5,-2.83996793904174811e-5,
  6631.             -2.54522720634870566e-5,-2.28459297164724555e-5,
  6632.             -2.05352753106480604e-5,-1.84816217627666085e-5,
  6633.             -1.66519330021393806e-5,-1.50179412980119482e-5,
  6634.             -1.35554031379040526e-5,-1.22434746473858131e-5,
  6635.             -1.10641884811308169e-5,-3.54211971457743841e-4,
  6636.             -1.56161263945159416e-4,3.0446550359493641e-5,
  6637.             1.30198655773242693e-4,1.67471106699712269e-4,
  6638.             1.70222587683592569e-4,1.56501427608594704e-4,
  6639.             1.3633917097744512e-4,1.14886692029825128e-4,
  6640.             9.45869093034688111e-5,7.64498419250898258e-5,
  6641.             6.07570334965197354e-5,4.74394299290508799e-5,
  6642.             3.62757512005344297e-5,2.69939714979224901e-5,
  6643.             1.93210938247939253e-5,1.30056674793963203e-5,
  6644.             7.82620866744496661e-6,3.59257485819351583e-6,
  6645.             1.44040049814251817e-7,-2.65396769697939116e-6,
  6646.             -4.9134686709848591e-6,-6.72739296091248287e-6,
  6647.             -8.17269379678657923e-6,-9.31304715093561232e-6,
  6648.             -1.02011418798016441e-5,-1.0880596251059288e-5,
  6649.             -1.13875481509603555e-5,-1.17519675674556414e-5,
  6650.             -1.19987364870944141e-5,3.78194199201772914e-4,
  6651.             2.02471952761816167e-4,-6.37938506318862408e-5,
  6652.             -2.38598230603005903e-4,-3.10916256027361568e-4,
  6653.             -3.13680115247576316e-4,-2.78950273791323387e-4,
  6654.             -2.28564082619141374e-4,-1.75245280340846749e-4,
  6655.             -1.25544063060690348e-4,-8.22982872820208365e-5,
  6656.             -4.62860730588116458e-5,-1.72334302366962267e-5,
  6657.             5.60690482304602267e-6,2.313954431482868e-5,
  6658.             3.62642745856793957e-5,4.58006124490188752e-5,
  6659.             5.2459529495911405e-5,5.68396208545815266e-5,
  6660.             5.94349820393104052e-5,6.06478527578421742e-5,
  6661.             6.08023907788436497e-5,6.01577894539460388e-5,
  6662.             5.891996573446985e-5,5.72515823777593053e-5,
  6663.             5.52804375585852577e-5,5.3106377380288017e-5,
  6664.             5.08069302012325706e-5,4.84418647620094842e-5,
  6665.             4.6056858160747537e-5,-6.91141397288294174e-4,
  6666.             -4.29976633058871912e-4,1.83067735980039018e-4,
  6667.             6.60088147542014144e-4,8.75964969951185931e-4,
  6668.             8.77335235958235514e-4,7.49369585378990637e-4,
  6669.             5.63832329756980918e-4,3.68059319971443156e-4,
  6670.             1.88464535514455599e-4,3.70663057664904149e-5,
  6671.             -8.28520220232137023e-5,-1.72751952869172998e-4,
  6672.             -2.36314873605872983e-4,-2.77966150694906658e-4,
  6673.             -3.02079514155456919e-4,-3.12594712643820127e-4,
  6674.             -3.12872558758067163e-4,-3.05678038466324377e-4,
  6675.             -2.93226470614557331e-4,-2.77255655582934777e-4,
  6676.             -2.59103928467031709e-4,-2.39784014396480342e-4,
  6677.             -2.20048260045422848e-4,-2.00443911094971498e-4,
  6678.             -1.81358692210970687e-4,-1.63057674478657464e-4,
  6679.             -1.45712672175205844e-4,-1.29425421983924587e-4,
  6680.             -1.14245691942445952e-4,.00192821964248775885,
  6681.             .00135592576302022234,-7.17858090421302995e-4,
  6682.             -.00258084802575270346,-.00349271130826168475,
  6683.             -.00346986299340960628,-.00282285233351310182,
  6684.             -.00188103076404891354,-8.895317183839476e-4,
  6685.             3.87912102631035228e-6,7.28688540119691412e-4,
  6686.             .00126566373053457758,.00162518158372674427,.00183203153216373172,
  6687.             .00191588388990527909,.00190588846755546138,.00182798982421825727,
  6688.             .0017038950642112153,.00155097127171097686,.00138261421852276159,
  6689.             .00120881424230064774,.00103676532638344962,
  6690.             8.71437918068619115e-4,7.16080155297701002e-4,
  6691.             5.72637002558129372e-4,4.42089819465802277e-4,
  6692.             3.24724948503090564e-4,2.20342042730246599e-4,
  6693.             1.28412898401353882e-4,4.82005924552095464e-5 };
  6694.     static doublereal beta[210] = { .0179988721413553309,
  6695.             .00559964911064388073,.00288501402231132779,.00180096606761053941,
  6696.             .00124753110589199202,9.22878876572938311e-4,
  6697.             7.14430421727287357e-4,5.71787281789704872e-4,
  6698.             4.69431007606481533e-4,3.93232835462916638e-4,
  6699.             3.34818889318297664e-4,2.88952148495751517e-4,
  6700.             2.52211615549573284e-4,2.22280580798883327e-4,
  6701.             1.97541838033062524e-4,1.76836855019718004e-4,
  6702.             1.59316899661821081e-4,1.44347930197333986e-4,
  6703.             1.31448068119965379e-4,1.20245444949302884e-4,
  6704.             1.10449144504599392e-4,1.01828770740567258e-4,
  6705.             9.41998224204237509e-5,8.74130545753834437e-5,
  6706.             8.13466262162801467e-5,7.59002269646219339e-5,
  6707.             7.09906300634153481e-5,6.65482874842468183e-5,
  6708.             6.25146958969275078e-5,5.88403394426251749e-5,
  6709.             -.00149282953213429172,-8.78204709546389328e-4,
  6710.             -5.02916549572034614e-4,-2.94822138512746025e-4,
  6711.             -1.75463996970782828e-4,-1.04008550460816434e-4,
  6712.             -5.96141953046457895e-5,-3.1203892907609834e-5,
  6713.             -1.26089735980230047e-5,-2.42892608575730389e-7,
  6714.             8.05996165414273571e-6,1.36507009262147391e-5,
  6715.             1.73964125472926261e-5,1.9867297884213378e-5,
  6716.             2.14463263790822639e-5,2.23954659232456514e-5,
  6717.             2.28967783814712629e-5,2.30785389811177817e-5,
  6718.             2.30321976080909144e-5,2.28236073720348722e-5,
  6719.             2.25005881105292418e-5,2.20981015361991429e-5,
  6720.             2.16418427448103905e-5,2.11507649256220843e-5,
  6721.             2.06388749782170737e-5,2.01165241997081666e-5,
  6722.             1.95913450141179244e-5,1.9068936791043674e-5,
  6723.             1.85533719641636667e-5,1.80475722259674218e-5,
  6724.             5.5221307672129279e-4,4.47932581552384646e-4,
  6725.             2.79520653992020589e-4,1.52468156198446602e-4,
  6726.             6.93271105657043598e-5,1.76258683069991397e-5,
  6727.             -1.35744996343269136e-5,-3.17972413350427135e-5,
  6728.             -4.18861861696693365e-5,-4.69004889379141029e-5,
  6729.             -4.87665447413787352e-5,-4.87010031186735069e-5,
  6730.             -4.74755620890086638e-5,-4.55813058138628452e-5,
  6731.             -4.33309644511266036e-5,-4.09230193157750364e-5,
  6732.             -3.84822638603221274e-5,-3.60857167535410501e-5,
  6733.             -3.37793306123367417e-5,-3.15888560772109621e-5,
  6734.             -2.95269561750807315e-5,-2.75978914828335759e-5,
  6735.             -2.58006174666883713e-5,-2.413083567612802e-5,
  6736.             -2.25823509518346033e-5,-2.11479656768912971e-5,
  6737.             -1.98200638885294927e-5,-1.85909870801065077e-5,
  6738.             -1.74532699844210224e-5,-1.63997823854497997e-5,
  6739.             -4.74617796559959808e-4,-4.77864567147321487e-4,
  6740.             -3.20390228067037603e-4,-1.61105016119962282e-4,
  6741.             -4.25778101285435204e-5,3.44571294294967503e-5,
  6742.             7.97092684075674924e-5,1.031382367082722e-4,
  6743.             1.12466775262204158e-4,1.13103642108481389e-4,
  6744.             1.08651634848774268e-4,1.01437951597661973e-4,
  6745.             9.29298396593363896e-5,8.40293133016089978e-5,
  6746.             7.52727991349134062e-5,6.69632521975730872e-5,
  6747.             5.92564547323194704e-5,5.22169308826975567e-5,
  6748.             4.58539485165360646e-5,4.01445513891486808e-5,
  6749.             3.50481730031328081e-5,3.05157995034346659e-5,
  6750.             2.64956119950516039e-5,2.29363633690998152e-5,
  6751.             1.97893056664021636e-5,1.70091984636412623e-5,
  6752.             1.45547428261524004e-5,1.23886640995878413e-5,
  6753.             1.04775876076583236e-5,8.79179954978479373e-6,
  6754.             7.36465810572578444e-4,8.72790805146193976e-4,
  6755.             6.22614862573135066e-4,2.85998154194304147e-4,
  6756.             3.84737672879366102e-6,-1.87906003636971558e-4,
  6757.             -2.97603646594554535e-4,-3.45998126832656348e-4,
  6758.             -3.53382470916037712e-4,-3.35715635775048757e-4,
  6759.             -3.04321124789039809e-4,-2.66722723047612821e-4,
  6760.             -2.27654214122819527e-4,-1.89922611854562356e-4,
  6761.             -1.5505891859909387e-4,-1.2377824076187363e-4,
  6762.             -9.62926147717644187e-5,-7.25178327714425337e-5,
  6763.             -5.22070028895633801e-5,-3.50347750511900522e-5,
  6764.             -2.06489761035551757e-5,-8.70106096849767054e-6,
  6765.             1.1369868667510029e-6,9.16426474122778849e-6,
  6766.             1.5647778542887262e-5,2.08223629482466847e-5,
  6767.             2.48923381004595156e-5,2.80340509574146325e-5,
  6768.             3.03987774629861915e-5,3.21156731406700616e-5,
  6769.             -.00180182191963885708,-.00243402962938042533,
  6770.             -.00183422663549856802,-7.62204596354009765e-4,
  6771.             2.39079475256927218e-4,9.49266117176881141e-4,
  6772.             .00134467449701540359,.00148457495259449178,.00144732339830617591,
  6773.             .00130268261285657186,.00110351597375642682,
  6774.             8.86047440419791759e-4,6.73073208165665473e-4,
  6775.             4.77603872856582378e-4,3.05991926358789362e-4,
  6776.             1.6031569459472163e-4,4.00749555270613286e-5,
  6777.             -5.66607461635251611e-5,-1.32506186772982638e-4,
  6778.             -1.90296187989614057e-4,-2.32811450376937408e-4,
  6779.             -2.62628811464668841e-4,-2.82050469867598672e-4,
  6780.             -2.93081563192861167e-4,-2.97435962176316616e-4,
  6781.             -2.96557334239348078e-4,-2.91647363312090861e-4,
  6782.             -2.83696203837734166e-4,-2.73512317095673346e-4,
  6783.             -2.6175015580676858e-4,.00638585891212050914,
  6784.             .00962374215806377941,.00761878061207001043,.00283219055545628054,
  6785.             -.0020984135201272009,-.00573826764216626498,
  6786.             -.0077080424449541462,-.00821011692264844401,
  6787.             -.00765824520346905413,-.00647209729391045177,
  6788.             -.00499132412004966473,-.0034561228971313328,
  6789.             -.00201785580014170775,-7.59430686781961401e-4,
  6790.             2.84173631523859138e-4,.00110891667586337403,
  6791.             .00172901493872728771,.00216812590802684701,.00245357710494539735,
  6792.             .00261281821058334862,.00267141039656276912,.0026520307339598043,
  6793.             .00257411652877287315,.00245389126236094427,.00230460058071795494,
  6794.             .00213684837686712662,.00195896528478870911,.00177737008679454412,
  6795.             .00159690280765839059,.00142111975664438546 };
  6796.     static doublereal gama[30] = { .629960524947436582,.251984209978974633,
  6797.             .154790300415655846,.110713062416159013,.0857309395527394825,
  6798.             .0697161316958684292,.0586085671893713576,.0504698873536310685,
  6799.             .0442600580689154809,.0393720661543509966,.0354283195924455368,
  6800.             .0321818857502098231,.0294646240791157679,.0271581677112934479,
  6801.             .0251768272973861779,.0234570755306078891,.0219508390134907203,
  6802.             .020621082823564624,.0194388240897880846,.0183810633800683158,
  6803.             .0174293213231963172,.0165685837786612353,.0157865285987918445,
  6804.             .0150729501494095594,.0144193250839954639,.0138184805735341786,
  6805.             .0132643378994276568,.0127517121970498651,.0122761545318762767,
  6806.             .0118338262398482403 };
  6807.     static doublereal ex1 = .333333333333333333;
  6808.     static doublereal ex2 = .666666666666666667;
  6809.     static doublereal hpi = 1.57079632679489662;
  6810.     static doublereal gpi = 3.14159265358979324;
  6811.     static doublereal thpi = 4.71238898038468986;
  6812.     static doublereal zeror = 0.;
  6813.     static doublereal zeroi = 0.;
  6814.     static doublereal coner = 1.;
  6815.     static doublereal conei = 0.;
  6816.     static doublereal ar[14] = { 1.,.104166666666666667,.0835503472222222222,
  6817.             .12822657455632716,.291849026464140464,.881627267443757652,
  6818.             3.32140828186276754,14.9957629868625547,78.9230130115865181,
  6819.             474.451538868264323,3207.49009089066193,24086.5496408740049,
  6820.             198923.119169509794,1791902.00777534383 };
  6821.  
  6822.     /* System generated locals */
  6823.     integer i__1, i__2;
  6824.     doublereal d__1;
  6825.  
  6826.     /* Builtin functions */
  6827.     double log(doublereal), pow_dd(doublereal *, doublereal *), atan(
  6828.             doublereal), cos(doublereal), sin(doublereal), sqrt(doublereal);
  6829.  
  6830.     /* Local variables */
  6831.     static doublereal rfn13;
  6832.     static integer idum;
  6833.     static doublereal atol, btol, tfni;
  6834.     static integer kmax;
  6835.     static doublereal azth, tzai, tfnr, rfnu;
  6836.     extern /* Subroutine */ int zlog_(doublereal *, doublereal *, doublereal *
  6837.             , doublereal *, integer *), zdiv_(doublereal *, doublereal *, 
  6838.             doublereal *, doublereal *, doublereal *, doublereal *);
  6839.     static doublereal zthi, test, tzar, zthr;
  6840.     extern doublereal z1abs_(doublereal *, doublereal *);
  6841.     static doublereal rfnu2;
  6842.     static integer j, k, l, m;
  6843.     static doublereal zetai, ptfni, sumai, sumbi, zetar, ptfnr, razth, sumar, 
  6844.             sumbr, rzthi;
  6845.     extern doublereal d1mach_(integer *);
  6846.     static integer l1, l2;
  6847.     static doublereal rzthr, rtzti;
  6848.     extern /* Subroutine */ int zsqrt_(doublereal *, doublereal *, doublereal 
  6849.             *, doublereal *);
  6850.     static doublereal rtztr, ac, ap[30], pi[30];
  6851.     static integer is, jr, ks, ju;
  6852.     static doublereal pp, wi, pr[30];
  6853.     static integer lr;
  6854.     static doublereal wr, aw2;
  6855.     static integer kp1;
  6856.     static doublereal przthi, t2i, w2i, t2r, przthr, w2r, ang, fn13, fn23;
  6857.     static integer ias;
  6858.     static doublereal cri[14], dri[14];
  6859.     static integer ibs;
  6860.     static doublereal zai, zbi, zci, crr[14], drr[14], raw, zar, upi[14], sti,
  6861.              zbr, zcr, upr[14], str, raw2;
  6862.     static integer lrp1;
  6863.  
  6864. /* ***BEGIN PROLOGUE  ZUNHJ */
  6865. /* ***REFER TO  ZBESI,ZBESK */
  6866.  
  6867. /*     REFERENCES */
  6868. /*         HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ AND I.A. */
  6869.  
  6870. /*         STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9. 
  6871. */
  6872.  
  6873. /*         ASYMPTOTICS AND SPECIAL FUNCTIONS BY F.W.J. OLVER, ACADEMIC */
  6874. /*         PRESS, N.Y., 1974, PAGE 420 */
  6875.  
  6876. /*     ABSTRACT */
  6877. /*         ZUNHJ COMPUTES PARAMETERS FOR BESSEL FUNCTIONS C(FNU,Z) = */
  6878. /*         J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU */
  6879. /*         BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION */
  6880.  
  6881. /*         C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) ) */
  6882.  
  6883. /*         FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS */
  6884. /*         AN AIRY FUNCTION AND DAIRY IS ITS DERIVATIVE. */
  6885.  
  6886. /*               (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2, */
  6887.  
  6888. /*         ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING */
  6889. /*         PURPOSES IN AIRY FUNCTIONS FROM CAIRY OR CBIRY. */
  6890.  
  6891. /*         MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND */
  6892. /*         MUST BE SPECIFIED. IPMTR=0 RETURNS ALL PARAMETERS. IPMTR= */
  6893. /*         1 COMPUTES ALL EXCEPT ASUM AND BSUM. */
  6894.  
  6895. /* ***ROUTINES CALLED  Z1ABS,ZDIV,ZLOG,ZSQRT,D1MACH */
  6896. /* ***END PROLOGUE  ZUNHJ */
  6897. /*     COMPLEX ARG,ASUM,BSUM,CFNU,CONE,CR,CZERO,DR,P,PHI,PRZTH,PTFN, */
  6898. /*    *RFN13,RTZTA,RZTH,SUMA,SUMB,TFN,T2,UP,W,W2,Z,ZA,ZB,ZC,ZETA,ZETA1, */
  6899.  
  6900. /*    *ZETA2,ZTH */
  6901.  
  6902.     rfnu = 1. / *fnu;
  6903. /* -----------------------------------------------------------------------
  6904.  */
  6905. /*     OVERFLOW TEST (Z/FNU TOO SMALL) */
  6906. /* -----------------------------------------------------------------------
  6907.  */
  6908.     test = d1mach_(&c__1) * 1e3;
  6909.     ac = *fnu * test;
  6910.     if (abs(*zr) > ac || abs(*zi) > ac) {
  6911.         goto L15;
  6912.     }
  6913.     *zeta1r = (d__1 = log(test), abs(d__1)) * 2. + *fnu;
  6914.     *zeta1i = 0.;
  6915.     *zeta2r = *fnu;
  6916.     *zeta2i = 0.;
  6917.     *phir = 1.;
  6918.     *phii = 0.;
  6919.     *argr = 1.;
  6920.     *argi = 0.;
  6921.     return 0;
  6922. L15:
  6923.     zbr = *zr * rfnu;
  6924.     zbi = *zi * rfnu;
  6925.     rfnu2 = rfnu * rfnu;
  6926. /* -----------------------------------------------------------------------
  6927.  */
  6928. /*     COMPUTE IN THE FOURTH QUADRANT */
  6929. /* -----------------------------------------------------------------------
  6930.  */
  6931.     fn13 = pow_dd(fnu, &ex1);
  6932.     fn23 = fn13 * fn13;
  6933.     rfn13 = 1. / fn13;
  6934.     w2r = coner - zbr * zbr + zbi * zbi;
  6935.     w2i = conei - zbr * zbi - zbr * zbi;
  6936.     aw2 = z1abs_(&w2r, &w2i);
  6937.     if (aw2 > .25) {
  6938.         goto L130;
  6939.     }
  6940. /* -----------------------------------------------------------------------
  6941.  */
  6942. /*     POWER SERIES FOR CABS(W2).LE.0.25D0 */
  6943. /* -----------------------------------------------------------------------
  6944.  */
  6945.     k = 1;
  6946.     pr[0] = coner;
  6947.     pi[0] = conei;
  6948.     sumar = gama[0];
  6949.     sumai = zeroi;
  6950.     ap[0] = 1.;
  6951.     if (aw2 < *tol) {
  6952.         goto L20;
  6953.     }
  6954.     for (k = 2; k <= 30; ++k) {
  6955.         pr[k - 1] = pr[k - 2] * w2r - pi[k - 2] * w2i;
  6956.         pi[k - 1] = pr[k - 2] * w2i + pi[k - 2] * w2r;
  6957.         sumar += pr[k - 1] * gama[k - 1];
  6958.         sumai += pi[k - 1] * gama[k - 1];
  6959.         ap[k - 1] = ap[k - 2] * aw2;
  6960.         if (ap[k - 1] < *tol) {
  6961.             goto L20;
  6962.         }
  6963. /* L10: */
  6964.     }
  6965.     k = 30;
  6966. L20:
  6967.     kmax = k;
  6968.     zetar = w2r * sumar - w2i * sumai;
  6969.     zetai = w2r * sumai + w2i * sumar;
  6970.     *argr = zetar * fn23;
  6971.     *argi = zetai * fn23;
  6972.     zsqrt_(&sumar, &sumai, &zar, &zai);
  6973.     zsqrt_(&w2r, &w2i, &str, &sti);
  6974.     *zeta2r = str * *fnu;
  6975.     *zeta2i = sti * *fnu;
  6976.     str = coner + ex2 * (zetar * zar - zetai * zai);
  6977.     sti = conei + ex2 * (zetar * zai + zetai * zar);
  6978.     *zeta1r = str * *zeta2r - sti * *zeta2i;
  6979.     *zeta1i = str * *zeta2i + sti * *zeta2r;
  6980.     zar += zar;
  6981.     zai += zai;
  6982.     zsqrt_(&zar, &zai, &str, &sti);
  6983.     *phir = str * rfn13;
  6984.     *phii = sti * rfn13;
  6985.     if (*ipmtr == 1) {
  6986.         goto L120;
  6987.     }
  6988. /* -----------------------------------------------------------------------
  6989.  */
  6990. /*     SUM SERIES FOR ASUM AND BSUM */
  6991. /* -----------------------------------------------------------------------
  6992.  */
  6993.     sumbr = zeror;
  6994.     sumbi = zeroi;
  6995.     i__1 = kmax;
  6996.     for (k = 1; k <= i__1; ++k) {
  6997.         sumbr += pr[k - 1] * beta[k - 1];
  6998.         sumbi += pi[k - 1] * beta[k - 1];
  6999. /* L30: */
  7000.     }
  7001.     *asumr = zeror;
  7002.     *asumi = zeroi;
  7003.     *bsumr = sumbr;
  7004.     *bsumi = sumbi;
  7005.     l1 = 0;
  7006.     l2 = 30;
  7007.     btol = *tol * (abs(*bsumr) + abs(*bsumi));
  7008.     atol = *tol;
  7009.     pp = 1.;
  7010.     ias = 0;
  7011.     ibs = 0;
  7012.     if (rfnu2 < *tol) {
  7013.         goto L110;
  7014.     }
  7015.     for (is = 2; is <= 7; ++is) {
  7016.         atol /= rfnu2;
  7017.         pp *= rfnu2;
  7018.         if (ias == 1) {
  7019.             goto L60;
  7020.         }
  7021.         sumar = zeror;
  7022.         sumai = zeroi;
  7023.         i__1 = kmax;
  7024.         for (k = 1; k <= i__1; ++k) {
  7025.             m = l1 + k;
  7026.             sumar += pr[k - 1] * alfa[m - 1];
  7027.             sumai += pi[k - 1] * alfa[m - 1];
  7028.             if (ap[k - 1] < atol) {
  7029.                 goto L50;
  7030.             }
  7031. /* L40: */
  7032.         }
  7033. L50:
  7034.         *asumr += sumar * pp;
  7035.         *asumi += sumai * pp;
  7036.         if (pp < *tol) {
  7037.             ias = 1;
  7038.         }
  7039. L60:
  7040.         if (ibs == 1) {
  7041.             goto L90;
  7042.         }
  7043.         sumbr = zeror;
  7044.         sumbi = zeroi;
  7045.         i__1 = kmax;
  7046.         for (k = 1; k <= i__1; ++k) {
  7047.             m = l2 + k;
  7048.             sumbr += pr[k - 1] * beta[m - 1];
  7049.             sumbi += pi[k - 1] * beta[m - 1];
  7050.             if (ap[k - 1] < atol) {
  7051.                 goto L80;
  7052.             }
  7053. /* L70: */
  7054.         }
  7055. L80:
  7056.         *bsumr += sumbr * pp;
  7057.         *bsumi += sumbi * pp;
  7058.         if (pp < btol) {
  7059.             ibs = 1;
  7060.         }
  7061. L90:
  7062.         if (ias == 1 && ibs == 1) {
  7063.             goto L110;
  7064.         }
  7065.         l1 += 30;
  7066.         l2 += 30;
  7067. /* L100: */
  7068.     }
  7069. L110:
  7070.     *asumr += coner;
  7071.     pp = rfnu * rfn13;
  7072.     *bsumr *= pp;
  7073.     *bsumi *= pp;
  7074. L120:
  7075.     return 0;
  7076. /* -----------------------------------------------------------------------
  7077.  */
  7078. /*     CABS(W2).GT.0.25D0 */
  7079. /* -----------------------------------------------------------------------
  7080.  */
  7081. L130:
  7082.     zsqrt_(&w2r, &w2i, &wr, &wi);
  7083.     if (wr < 0.) {
  7084.         wr = 0.;
  7085.     }
  7086.     if (wi < 0.) {
  7087.         wi = 0.;
  7088.     }
  7089.     str = coner + wr;
  7090.     sti = wi;
  7091.     zdiv_(&str, &sti, &zbr, &zbi, &zar, &zai);
  7092.     zlog_(&zar, &zai, &zcr, &zci, &idum);
  7093.     if (zci < 0.) {
  7094.         zci = 0.;
  7095.     }
  7096.     if (zci > hpi) {
  7097.         zci = hpi;
  7098.     }
  7099.     if (zcr < 0.) {
  7100.         zcr = 0.;
  7101.     }
  7102.     zthr = (zcr - wr) * 1.5;
  7103.     zthi = (zci - wi) * 1.5;
  7104.     *zeta1r = zcr * *fnu;
  7105.     *zeta1i = zci * *fnu;
  7106.     *zeta2r = wr * *fnu;
  7107.     *zeta2i = wi * *fnu;
  7108.     azth = z1abs_(&zthr, &zthi);
  7109.     ang = thpi;
  7110.     if (zthr >= 0. && zthi < 0.) {
  7111.         goto L140;
  7112.     }
  7113.     ang = hpi;
  7114.     if (zthr == 0.) {
  7115.         goto L140;
  7116.     }
  7117.     ang = atan(zthi / zthr);
  7118.     if (zthr < 0.) {
  7119.         ang += gpi;
  7120.     }
  7121. L140:
  7122.     pp = pow_dd(&azth, &ex2);
  7123.     ang *= ex2;
  7124.     zetar = pp * cos(ang);
  7125.     zetai = pp * sin(ang);
  7126.     if (zetai < 0.) {
  7127.         zetai = 0.;
  7128.     }
  7129.     *argr = zetar * fn23;
  7130.     *argi = zetai * fn23;
  7131.     zdiv_(&zthr, &zthi, &zetar, &zetai, &rtztr, &rtzti);
  7132.     zdiv_(&rtztr, &rtzti, &wr, &wi, &zar, &zai);
  7133.     tzar = zar + zar;
  7134.     tzai = zai + zai;
  7135.     zsqrt_(&tzar, &tzai, &str, &sti);
  7136.     *phir = str * rfn13;
  7137.     *phii = sti * rfn13;
  7138.     if (*ipmtr == 1) {
  7139.         goto L120;
  7140.     }
  7141.     raw = 1. / sqrt(aw2);
  7142.     str = wr * raw;
  7143.     sti = -wi * raw;
  7144.     tfnr = str * rfnu * raw;
  7145.     tfni = sti * rfnu * raw;
  7146.     razth = 1. / azth;
  7147.     str = zthr * razth;
  7148.     sti = -zthi * razth;
  7149.     rzthr = str * razth * rfnu;
  7150.     rzthi = sti * razth * rfnu;
  7151.     zcr = rzthr * ar[1];
  7152.     zci = rzthi * ar[1];
  7153.     raw2 = 1. / aw2;
  7154.     str = w2r * raw2;
  7155.     sti = -w2i * raw2;
  7156.     t2r = str * raw2;
  7157.     t2i = sti * raw2;
  7158.     str = t2r * c[1] + c[2];
  7159.     sti = t2i * c[1];
  7160.     upr[1] = str * tfnr - sti * tfni;
  7161.     upi[1] = str * tfni + sti * tfnr;
  7162.     *bsumr = upr[1] + zcr;
  7163.     *bsumi = upi[1] + zci;
  7164.     *asumr = zeror;
  7165.     *asumi = zeroi;
  7166.     if (rfnu < *tol) {
  7167.         goto L220;
  7168.     }
  7169.     przthr = rzthr;
  7170.     przthi = rzthi;
  7171.     ptfnr = tfnr;
  7172.     ptfni = tfni;
  7173.     upr[0] = coner;
  7174.     upi[0] = conei;
  7175.     pp = 1.;
  7176.     btol = *tol * (abs(*bsumr) + abs(*bsumi));
  7177.     ks = 0;
  7178.     kp1 = 2;
  7179.     l = 3;
  7180.     ias = 0;
  7181.     ibs = 0;
  7182.     for (lr = 2; lr <= 12; lr += 2) {
  7183.         lrp1 = lr + 1;
  7184. /* ------------------------------------------------------------------
  7185. ----- */
  7186. /*     COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE TERMS IN */
  7187. /*     NEXT SUMA AND SUMB */
  7188. /* ------------------------------------------------------------------
  7189. ----- */
  7190.         i__1 = lrp1;
  7191.         for (k = lr; k <= i__1; ++k) {
  7192.             ++ks;
  7193.             ++kp1;
  7194.             ++l;
  7195.             zar = c[l - 1];
  7196.             zai = zeroi;
  7197.             i__2 = kp1;
  7198.             for (j = 2; j <= i__2; ++j) {
  7199.                 ++l;
  7200.                 str = zar * t2r - t2i * zai + c[l - 1];
  7201.                 zai = zar * t2i + zai * t2r;
  7202.                 zar = str;
  7203. /* L150: */
  7204.             }
  7205.             str = ptfnr * tfnr - ptfni * tfni;
  7206.             ptfni = ptfnr * tfni + ptfni * tfnr;
  7207.             ptfnr = str;
  7208.             upr[kp1 - 1] = ptfnr * zar - ptfni * zai;
  7209.             upi[kp1 - 1] = ptfni * zar + ptfnr * zai;
  7210.             crr[ks - 1] = przthr * br[ks];
  7211.             cri[ks - 1] = przthi * br[ks];
  7212.             str = przthr * rzthr - przthi * rzthi;
  7213.             przthi = przthr * rzthi + przthi * rzthr;
  7214.             przthr = str;
  7215.             drr[ks - 1] = przthr * ar[ks + 1];
  7216.             dri[ks - 1] = przthi * ar[ks + 1];
  7217. /* L160: */
  7218.         }
  7219.         pp *= rfnu2;
  7220.         if (ias == 1) {
  7221.             goto L180;
  7222.         }
  7223.         sumar = upr[lrp1 - 1];
  7224.         sumai = upi[lrp1 - 1];
  7225.         ju = lrp1;
  7226.         i__1 = lr;
  7227.         for (jr = 1; jr <= i__1; ++jr) {
  7228.             --ju;
  7229.             sumar = sumar + crr[jr - 1] * upr[ju - 1] - cri[jr - 1] * upi[ju 
  7230.                     - 1];
  7231.             sumai = sumai + crr[jr - 1] * upi[ju - 1] + cri[jr - 1] * upr[ju 
  7232.                     - 1];
  7233. /* L170: */
  7234.         }
  7235.         *asumr += sumar;
  7236.         *asumi += sumai;
  7237.         test = abs(sumar) + abs(sumai);
  7238.         if (pp < *tol && test < *tol) {
  7239.             ias = 1;
  7240.         }
  7241. L180:
  7242.         if (ibs == 1) {
  7243.             goto L200;
  7244.         }
  7245.         sumbr = upr[lr + 1] + upr[lrp1 - 1] * zcr - upi[lrp1 - 1] * zci;
  7246.         sumbi = upi[lr + 1] + upr[lrp1 - 1] * zci + upi[lrp1 - 1] * zcr;
  7247.         ju = lrp1;
  7248.         i__1 = lr;
  7249.         for (jr = 1; jr <= i__1; ++jr) {
  7250.             --ju;
  7251.             sumbr = sumbr + drr[jr - 1] * upr[ju - 1] - dri[jr - 1] * upi[ju 
  7252.                     - 1];
  7253.             sumbi = sumbi + drr[jr - 1] * upi[ju - 1] + dri[jr - 1] * upr[ju 
  7254.                     - 1];
  7255. /* L190: */
  7256.         }
  7257.         *bsumr += sumbr;
  7258.         *bsumi += sumbi;
  7259.         test = abs(sumbr) + abs(sumbi);
  7260.         if (pp < btol && test < btol) {
  7261.             ibs = 1;
  7262.         }
  7263. L200:
  7264.         if (ias == 1 && ibs == 1) {
  7265.             goto L220;
  7266.         }
  7267. /* L210: */
  7268.     }
  7269. L220:
  7270.     *asumr += coner;
  7271.     str = -(*bsumr) * rfn13;
  7272.     sti = -(*bsumi) * rfn13;
  7273.     zdiv_(&str, &sti, &rtztr, &rtzti, bsumr, bsumi);
  7274.     goto L120;
  7275. } /* zunhj_ */
  7276.  
  7277. /* Subroutine */ int zuni1_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  7278.         integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
  7279.         nz, integer *nlast, doublereal *fnul, doublereal *tol, doublereal *
  7280.         elim, doublereal *alim)
  7281. {
  7282.     /* Initialized data */
  7283.  
  7284.     static doublereal zeror = 0.;
  7285.     static doublereal zeroi = 0.;
  7286.     static doublereal coner = 1.;
  7287.  
  7288.     /* System generated locals */
  7289.     integer i__1;
  7290.  
  7291.     /* Builtin functions */
  7292.     double log(doublereal), exp(doublereal), cos(doublereal), sin(doublereal);
  7293.  
  7294.  
  7295.     /* Local variables */
  7296.     static doublereal aphi, cscl, phii, crsc, phir;
  7297.     static integer init;
  7298.     static doublereal csrr[3], cssr[3], rast, sumi, sumr;
  7299.     extern doublereal z1abs_(doublereal *, doublereal *);
  7300.     static integer i, k, m, iflag;
  7301.     static doublereal ascle, cwrki[16];
  7302.     extern /* Subroutine */ int zuchk_(doublereal *, doublereal *, integer *, 
  7303.             doublereal *, doublereal *);
  7304.     static doublereal cwrkr[16];
  7305.     extern doublereal d1mach_(integer *);
  7306.     extern /* Subroutine */ int zunik_(doublereal *, doublereal *, doublereal 
  7307.             *, integer *, integer *, doublereal *, integer *, doublereal *, 
  7308.             doublereal *, doublereal *, doublereal *, doublereal *, 
  7309.             doublereal *, doublereal *, doublereal *, doublereal *, 
  7310.             doublereal *), zuoik_(doublereal *, doublereal *, doublereal *, 
  7311.             integer *, integer *, integer *, doublereal *, doublereal *, 
  7312.             integer *, doublereal *, doublereal *, doublereal *);
  7313.     static doublereal zeta1i, zeta2i, zeta1r, zeta2r;
  7314.     static integer nd;
  7315.     static doublereal fn;
  7316.     static integer nn, nw;
  7317.     static doublereal c2i, c2m, c1r, c2r, s1i, s2i, rs1, s1r, s2r, cyi[2];
  7318.     static integer nuf;
  7319.     static doublereal bry[3], cyr[2], sti, rzi, str, rzr;
  7320.  
  7321. /* ***BEGIN PROLOGUE  ZUNI1 */
  7322. /* ***REFER TO  ZBESI,ZBESK */
  7323.  
  7324. /*     ZUNI1 COMPUTES I(FNU,Z)  BY MEANS OF THE UNIFORM ASYMPTOTIC */
  7325. /*     EXPANSION FOR I(FNU,Z) IN -PI/3.LE.ARG Z.LE.PI/3. */
  7326.  
  7327. /*     FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC */
  7328. /*     EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. */
  7329. /*     NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER */
  7330. /*     FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. 
  7331. */
  7332. /*     Y(I)=CZERO FOR I=NLAST+1,N */
  7333.  
  7334. /* ***ROUTINES CALLED  ZUCHK,ZUNIK,ZUOIK,D1MACH,Z1ABS */
  7335. /* ***END PROLOGUE  ZUNI1 */
  7336. /*     COMPLEX CFN,CONE,CRSC,CSCL,CSR,CSS,CWRK,CZERO,C1,C2,PHI,RZ,SUM,S1, 
  7337. */
  7338. /*    *S2,Y,Z,ZETA1,ZETA2 */
  7339.     /* Parameter adjustments */
  7340.     --yi;
  7341.     --yr;
  7342.  
  7343.     /* Function Body */
  7344.  
  7345.     *nz = 0;
  7346.     nd = *n;
  7347.     *nlast = 0;
  7348. /* -----------------------------------------------------------------------
  7349.  */
  7350. /*     COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- */
  7351. /*     NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, */
  7352. /*     EXP(ALIM)=EXP(ELIM)*TOL */
  7353. /* -----------------------------------------------------------------------
  7354.  */
  7355.     cscl = 1. / *tol;
  7356.     crsc = *tol;
  7357.     cssr[0] = cscl;
  7358.     cssr[1] = coner;
  7359.     cssr[2] = crsc;
  7360.     csrr[0] = crsc;
  7361.     csrr[1] = coner;
  7362.     csrr[2] = cscl;
  7363.     bry[0] = d1mach_(&c__1) * 1e3 / *tol;
  7364. /* -----------------------------------------------------------------------
  7365.  */
  7366. /*     CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER */
  7367. /* -----------------------------------------------------------------------
  7368.  */
  7369.     fn = max(*fnu,1.);
  7370.     init = 0;
  7371.     zunik_(zr, zi, &fn, &c__1, &c__1, tol, &init, &phir, &phii, &zeta1r, &
  7372.             zeta1i, &zeta2r, &zeta2i, &sumr, &sumi, cwrkr, cwrki);
  7373.     if (*kode == 1) {
  7374.         goto L10;
  7375.     }
  7376.     str = *zr + zeta2r;
  7377.     sti = *zi + zeta2i;
  7378.     rast = fn / z1abs_(&str, &sti);
  7379.     str = str * rast * rast;
  7380.     sti = -sti * rast * rast;
  7381.     s1r = -zeta1r + str;
  7382.     s1i = -zeta1i + sti;
  7383.     goto L20;
  7384. L10:
  7385.     s1r = -zeta1r + zeta2r;
  7386.     s1i = -zeta1i + zeta2i;
  7387. L20:
  7388.     rs1 = s1r;
  7389.     if (abs(rs1) > *elim) {
  7390.         goto L130;
  7391.     }
  7392. L30:
  7393.     nn = min(2,nd);
  7394.     i__1 = nn;
  7395.     for (i = 1; i <= i__1; ++i) {
  7396.         fn = *fnu + (doublereal) ((real) (nd - i));
  7397.         init = 0;
  7398.         zunik_(zr, zi, &fn, &c__1, &c__0, tol, &init, &phir, &phii, &zeta1r, &
  7399.                 zeta1i, &zeta2r, &zeta2i, &sumr, &sumi, cwrkr, cwrki);
  7400.         if (*kode == 1) {
  7401.             goto L40;
  7402.         }
  7403.         str = *zr + zeta2r;
  7404.         sti = *zi + zeta2i;
  7405.         rast = fn / z1abs_(&str, &sti);
  7406.         str = str * rast * rast;
  7407.         sti = -sti * rast * rast;
  7408.         s1r = -zeta1r + str;
  7409.         s1i = -zeta1i + sti + *zi;
  7410.         goto L50;
  7411. L40:
  7412.         s1r = -zeta1r + zeta2r;
  7413.         s1i = -zeta1i + zeta2i;
  7414. L50:
  7415. /* ------------------------------------------------------------------
  7416. ----- */
  7417. /*     TEST FOR UNDERFLOW AND OVERFLOW */
  7418. /* ------------------------------------------------------------------
  7419. ----- */
  7420.         rs1 = s1r;
  7421.         if (abs(rs1) > *elim) {
  7422.             goto L110;
  7423.         }
  7424.         if (i == 1) {
  7425.             iflag = 2;
  7426.         }
  7427.         if (abs(rs1) < *alim) {
  7428.             goto L60;
  7429.         }
  7430. /* ------------------------------------------------------------------
  7431. ----- */
  7432. /*     REFINE  TEST AND SCALE */
  7433. /* ------------------------------------------------------------------
  7434. ----- */
  7435.         aphi = z1abs_(&phir, &phii);
  7436.         rs1 += log(aphi);
  7437.         if (abs(rs1) > *elim) {
  7438.             goto L110;
  7439.         }
  7440.         if (i == 1) {
  7441.             iflag = 1;
  7442.         }
  7443.         if (rs1 < 0.) {
  7444.             goto L60;
  7445.         }
  7446.         if (i == 1) {
  7447.             iflag = 3;
  7448.         }
  7449. L60:
  7450. /* ------------------------------------------------------------------
  7451. ----- */
  7452. /*     SCALE S1 IF CABS(S1).LT.ASCLE */
  7453. /* ------------------------------------------------------------------
  7454. ----- */
  7455.         s2r = phir * sumr - phii * sumi;
  7456.         s2i = phir * sumi + phii * sumr;
  7457.         str = exp(s1r) * cssr[iflag - 1];
  7458.         s1r = str * cos(s1i);
  7459.         s1i = str * sin(s1i);
  7460.         str = s2r * s1r - s2i * s1i;
  7461.         s2i = s2r * s1i + s2i * s1r;
  7462.         s2r = str;
  7463.         if (iflag != 1) {
  7464.             goto L70;
  7465.         }
  7466.         zuchk_(&s2r, &s2i, &nw, bry, tol);
  7467.         if (nw != 0) {
  7468.             goto L110;
  7469.         }
  7470. L70:
  7471.         cyr[i - 1] = s2r;
  7472.         cyi[i - 1] = s2i;
  7473.         m = nd - i + 1;
  7474.         yr[m] = s2r * csrr[iflag - 1];
  7475.         yi[m] = s2i * csrr[iflag - 1];
  7476. /* L80: */
  7477.     }
  7478.     if (nd <= 2) {
  7479.         goto L100;
  7480.     }
  7481.     rast = 1. / z1abs_(zr, zi);
  7482.     str = *zr * rast;
  7483.     sti = -(*zi) * rast;
  7484.     rzr = (str + str) * rast;
  7485.     rzi = (sti + sti) * rast;
  7486.     bry[1] = 1. / bry[0];
  7487.     bry[2] = d1mach_(&c__2);
  7488.     s1r = cyr[0];
  7489.     s1i = cyi[0];
  7490.     s2r = cyr[1];
  7491.     s2i = cyi[1];
  7492.     c1r = csrr[iflag - 1];
  7493.     ascle = bry[iflag - 1];
  7494.     k = nd - 2;
  7495.     fn = (doublereal) ((real) k);
  7496.     i__1 = nd;
  7497.     for (i = 3; i <= i__1; ++i) {
  7498.         c2r = s2r;
  7499.         c2i = s2i;
  7500.         s2r = s1r + (*fnu + fn) * (rzr * c2r - rzi * c2i);
  7501.         s2i = s1i + (*fnu + fn) * (rzr * c2i + rzi * c2r);
  7502.         s1r = c2r;
  7503.         s1i = c2i;
  7504.         c2r = s2r * c1r;
  7505.         c2i = s2i * c1r;
  7506.         yr[k] = c2r;
  7507.         yi[k] = c2i;
  7508.         --k;
  7509.         fn += -1.;
  7510.         if (iflag >= 3) {
  7511.             goto L90;
  7512.         }
  7513.         str = abs(c2r);
  7514.         sti = abs(c2i);
  7515.         c2m = max(str,sti);
  7516.         if (c2m <= ascle) {
  7517.             goto L90;
  7518.         }
  7519.         ++iflag;
  7520.         ascle = bry[iflag - 1];
  7521.         s1r *= c1r;
  7522.         s1i *= c1r;
  7523.         s2r = c2r;
  7524.         s2i = c2i;
  7525.         s1r *= cssr[iflag - 1];
  7526.         s1i *= cssr[iflag - 1];
  7527.         s2r *= cssr[iflag - 1];
  7528.         s2i *= cssr[iflag - 1];
  7529.         c1r = csrr[iflag - 1];
  7530. L90:
  7531.         ;
  7532.     }
  7533. L100:
  7534.     return 0;
  7535. /* -----------------------------------------------------------------------
  7536.  */
  7537. /*     SET UNDERFLOW AND UPDATE PARAMETERS */
  7538. /* -----------------------------------------------------------------------
  7539.  */
  7540. L110:
  7541.     if (rs1 > 0.) {
  7542.         goto L120;
  7543.     }
  7544.     yr[nd] = zeror;
  7545.     yi[nd] = zeroi;
  7546.     ++(*nz);
  7547.     --nd;
  7548.     if (nd == 0) {
  7549.         goto L100;
  7550.     }
  7551.     zuoik_(zr, zi, fnu, kode, &c__1, &nd, &yr[1], &yi[1], &nuf, tol, elim, 
  7552.             alim);
  7553.     if (nuf < 0) {
  7554.         goto L120;
  7555.     }
  7556.     nd -= nuf;
  7557.     *nz += nuf;
  7558.     if (nd == 0) {
  7559.         goto L100;
  7560.     }
  7561.     fn = *fnu + (doublereal) ((real) (nd - 1));
  7562.     if (fn >= *fnul) {
  7563.         goto L30;
  7564.     }
  7565.     *nlast = nd;
  7566.     return 0;
  7567. L120:
  7568.     *nz = -1;
  7569.     return 0;
  7570. L130:
  7571.     if (rs1 > 0.) {
  7572.         goto L120;
  7573.     }
  7574.     *nz = *n;
  7575.     i__1 = *n;
  7576.     for (i = 1; i <= i__1; ++i) {
  7577.         yr[i] = zeror;
  7578.         yi[i] = zeroi;
  7579. /* L140: */
  7580.     }
  7581.     return 0;
  7582. } /* zuni1_ */
  7583.  
  7584. /* Subroutine */ int zuni2_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  7585.         integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
  7586.         nz, integer *nlast, doublereal *fnul, doublereal *tol, doublereal *
  7587.         elim, doublereal *alim)
  7588. {
  7589.     /* Initialized data */
  7590.  
  7591.     static doublereal zeror = 0.;
  7592.     static doublereal zeroi = 0.;
  7593.     static doublereal coner = 1.;
  7594.     static doublereal cipr[4] = { 1.,0.,-1.,0. };
  7595.     static doublereal cipi[4] = { 0.,1.,0.,-1. };
  7596.     static doublereal hpi = 1.57079632679489662;
  7597.     static doublereal aic = 1.265512123484645396;
  7598.  
  7599.     /* System generated locals */
  7600.     integer i__1;
  7601.  
  7602.     /* Builtin functions */
  7603.     double cos(doublereal), sin(doublereal), log(doublereal), exp(doublereal);
  7604.  
  7605.  
  7606.     /* Local variables */
  7607.     static doublereal daii, cidi, aarg;
  7608.     static integer ndai;
  7609.     static doublereal dair, aphi, argi, cscl, phii, crsc, argr;
  7610.     static integer idum;
  7611.     static doublereal phir, csrr[3], cssr[3], rast;
  7612.     extern doublereal z1abs_(doublereal *, doublereal *);
  7613.     static integer i, j, k, iflag;
  7614.     static doublereal ascle, asumi, bsumi;
  7615.     extern /* Subroutine */ int zuchk_(doublereal *, doublereal *, integer *, 
  7616.             doublereal *, doublereal *);
  7617.     static doublereal asumr, bsumr;
  7618.     extern doublereal d1mach_(integer *);
  7619.     extern /* Subroutine */ int zunhj_(doublereal *, doublereal *, doublereal 
  7620.             *, integer *, doublereal *, doublereal *, doublereal *, 
  7621.             doublereal *, doublereal *, doublereal *, doublereal *, 
  7622.             doublereal *, doublereal *, doublereal *, doublereal *, 
  7623.             doublereal *, doublereal *), zairy_(doublereal *, doublereal *, 
  7624.             integer *, integer *, doublereal *, doublereal *, integer *, 
  7625.             integer *), zuoik_(doublereal *, doublereal *, doublereal *, 
  7626.             integer *, integer *, integer *, doublereal *, doublereal *, 
  7627.             integer *, doublereal *, doublereal *, doublereal *);
  7628.     static doublereal zeta1i, zeta2i, zeta1r, zeta2r;
  7629.     static integer nd;
  7630.     static doublereal fn;
  7631.     static integer in, nn, nw;
  7632.     static doublereal c2i, c2m, c1r, c2r, s1i, s2i, rs1, s1r, s2r, aii, ang, 
  7633.             car;
  7634.     static integer nai;
  7635.     static doublereal air, zbi, cyi[2], sar;
  7636.     static integer nuf, inu;
  7637.     static doublereal bry[3], raz, sti, zbr, zni, cyr[2], rzi, str, znr, rzr;
  7638.  
  7639. /* ***BEGIN PROLOGUE  ZUNI2 */
  7640. /* ***REFER TO  ZBESI,ZBESK */
  7641.  
  7642. /*     ZUNI2 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF */
  7643. /*     UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I */
  7644. /*     OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO. */
  7645.  
  7646. /*     FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC */
  7647. /*     EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. */
  7648. /*     NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER */
  7649. /*     FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. 
  7650. */
  7651. /*     Y(I)=CZERO FOR I=NLAST+1,N */
  7652.  
  7653. /* ***ROUTINES CALLED  ZAIRY,ZUCHK,ZUNHJ,ZUOIK,D1MACH,Z1ABS */
  7654. /* ***END PROLOGUE  ZUNI2 */
  7655. /*     COMPLEX AI,ARG,ASUM,BSUM,CFN,CI,CID,CIP,CONE,CRSC,CSCL,CSR,CSS, */
  7656. /*    *CZERO,C1,C2,DAI,PHI,RZ,S1,S2,Y,Z,ZB,ZETA1,ZETA2,ZN */
  7657.     /* Parameter adjustments */
  7658.     --yi;
  7659.     --yr;
  7660.  
  7661.     /* Function Body */
  7662.  
  7663.     *nz = 0;
  7664.     nd = *n;
  7665.     *nlast = 0;
  7666. /* -----------------------------------------------------------------------
  7667.  */
  7668. /*     COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- */
  7669. /*     NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, */
  7670. /*     EXP(ALIM)=EXP(ELIM)*TOL */
  7671. /* -----------------------------------------------------------------------
  7672.  */
  7673.     cscl = 1. / *tol;
  7674.     crsc = *tol;
  7675.     cssr[0] = cscl;
  7676.     cssr[1] = coner;
  7677.     cssr[2] = crsc;
  7678.     csrr[0] = crsc;
  7679.     csrr[1] = coner;
  7680.     csrr[2] = cscl;
  7681.     bry[0] = d1mach_(&c__1) * 1e3 / *tol;
  7682. /* -----------------------------------------------------------------------
  7683.  */
  7684. /*     ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI */
  7685. /* -----------------------------------------------------------------------
  7686.  */
  7687.     znr = *zi;
  7688.     zni = -(*zr);
  7689.     zbr = *zr;
  7690.     zbi = *zi;
  7691.     cidi = -coner;
  7692.     inu = (integer) (*fnu);
  7693.     ang = hpi * (*fnu - (doublereal) ((real) inu));
  7694.     c2r = cos(ang);
  7695.     c2i = sin(ang);
  7696.     car = c2r;
  7697.     sar = c2i;
  7698.     in = inu + *n - 1;
  7699.     in = in % 4 + 1;
  7700.     str = c2r * cipr[in - 1] - c2i * cipi[in - 1];
  7701.     c2i = c2r * cipi[in - 1] + c2i * cipr[in - 1];
  7702.     c2r = str;
  7703.     if (*zi > 0.) {
  7704.         goto L10;
  7705.     }
  7706.     znr = -znr;
  7707.     zbi = -zbi;
  7708.     cidi = -cidi;
  7709.     c2i = -c2i;
  7710. L10:
  7711. /* -----------------------------------------------------------------------
  7712.  */
  7713. /*     CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER */
  7714. /* -----------------------------------------------------------------------
  7715.  */
  7716.     fn = max(*fnu,1.);
  7717.     zunhj_(&znr, &zni, &fn, &c__1, tol, &phir, &phii, &argr, &argi, &zeta1r, &
  7718.             zeta1i, &zeta2r, &zeta2i, &asumr, &asumi, &bsumr, &bsumi);
  7719.     if (*kode == 1) {
  7720.         goto L20;
  7721.     }
  7722.     str = zbr + zeta2r;
  7723.     sti = zbi + zeta2i;
  7724.     rast = fn / z1abs_(&str, &sti);
  7725.     str = str * rast * rast;
  7726.     sti = -sti * rast * rast;
  7727.     s1r = -zeta1r + str;
  7728.     s1i = -zeta1i + sti;
  7729.     goto L30;
  7730. L20:
  7731.     s1r = -zeta1r + zeta2r;
  7732.     s1i = -zeta1i + zeta2i;
  7733. L30:
  7734.     rs1 = s1r;
  7735.     if (abs(rs1) > *elim) {
  7736.         goto L150;
  7737.     }
  7738. L40:
  7739.     nn = min(2,nd);
  7740.     i__1 = nn;
  7741.     for (i = 1; i <= i__1; ++i) {
  7742.         fn = *fnu + (doublereal) ((real) (nd - i));
  7743.         zunhj_(&znr, &zni, &fn, &c__0, tol, &phir, &phii, &argr, &argi, &
  7744.                 zeta1r, &zeta1i, &zeta2r, &zeta2i, &asumr, &asumi, &bsumr, &
  7745.                 bsumi);
  7746.         if (*kode == 1) {
  7747.             goto L50;
  7748.         }
  7749.         str = zbr + zeta2r;
  7750.         sti = zbi + zeta2i;
  7751.         rast = fn / z1abs_(&str, &sti);
  7752.         str = str * rast * rast;
  7753.         sti = -sti * rast * rast;
  7754.         s1r = -zeta1r + str;
  7755.         s1i = -zeta1i + sti + abs(*zi);
  7756.         goto L60;
  7757. L50:
  7758.         s1r = -zeta1r + zeta2r;
  7759.         s1i = -zeta1i + zeta2i;
  7760. L60:
  7761. /* ------------------------------------------------------------------
  7762. ----- */
  7763. /*     TEST FOR UNDERFLOW AND OVERFLOW */
  7764. /* ------------------------------------------------------------------
  7765. ----- */
  7766.         rs1 = s1r;
  7767.         if (abs(rs1) > *elim) {
  7768.             goto L120;
  7769.         }
  7770.         if (i == 1) {
  7771.             iflag = 2;
  7772.         }
  7773.         if (abs(rs1) < *alim) {
  7774.             goto L70;
  7775.         }
  7776. /* ------------------------------------------------------------------
  7777. ----- */
  7778. /*     REFINE  TEST AND SCALE */
  7779. /* ------------------------------------------------------------------
  7780. ----- */
  7781. /* ------------------------------------------------------------------
  7782. ----- */
  7783.         aphi = z1abs_(&phir, &phii);
  7784.         aarg = z1abs_(&argr, &argi);
  7785.         rs1 = rs1 + log(aphi) - log(aarg) * .25 - aic;
  7786.         if (abs(rs1) > *elim) {
  7787.             goto L120;
  7788.         }
  7789.         if (i == 1) {
  7790.             iflag = 1;
  7791.         }
  7792.         if (rs1 < 0.) {
  7793.             goto L70;
  7794.         }
  7795.         if (i == 1) {
  7796.             iflag = 3;
  7797.         }
  7798. L70:
  7799. /* ------------------------------------------------------------------
  7800. ----- */
  7801. /*     SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR */
  7802. /*     EXPONENT EXTREMES */
  7803. /* ------------------------------------------------------------------
  7804. ----- */
  7805.         zairy_(&argr, &argi, &c__0, &c__2, &air, &aii, &nai, &idum);
  7806.         zairy_(&argr, &argi, &c__1, &c__2, &dair, &daii, &ndai, &idum);
  7807.         str = dair * bsumr - daii * bsumi;
  7808.         sti = dair * bsumi + daii * bsumr;
  7809.         str += air * asumr - aii * asumi;
  7810.         sti += air * asumi + aii * asumr;
  7811.         s2r = phir * str - phii * sti;
  7812.         s2i = phir * sti + phii * str;
  7813.         str = exp(s1r) * cssr[iflag - 1];
  7814.         s1r = str * cos(s1i);
  7815.         s1i = str * sin(s1i);
  7816.         str = s2r * s1r - s2i * s1i;
  7817.         s2i = s2r * s1i + s2i * s1r;
  7818.         s2r = str;
  7819.         if (iflag != 1) {
  7820.             goto L80;
  7821.         }
  7822.         zuchk_(&s2r, &s2i, &nw, bry, tol);
  7823.         if (nw != 0) {
  7824.             goto L120;
  7825.         }
  7826. L80:
  7827.         if (*zi <= 0.) {
  7828.             s2i = -s2i;
  7829.         }
  7830.         str = s2r * c2r - s2i * c2i;
  7831.         s2i = s2r * c2i + s2i * c2r;
  7832.         s2r = str;
  7833.         cyr[i - 1] = s2r;
  7834.         cyi[i - 1] = s2i;
  7835.         j = nd - i + 1;
  7836.         yr[j] = s2r * csrr[iflag - 1];
  7837.         yi[j] = s2i * csrr[iflag - 1];
  7838.         str = -c2i * cidi;
  7839.         c2i = c2r * cidi;
  7840.         c2r = str;
  7841. /* L90: */
  7842.     }
  7843.     if (nd <= 2) {
  7844.         goto L110;
  7845.     }
  7846.     raz = 1. / z1abs_(zr, zi);
  7847.     str = *zr * raz;
  7848.     sti = -(*zi) * raz;
  7849.     rzr = (str + str) * raz;
  7850.     rzi = (sti + sti) * raz;
  7851.     bry[1] = 1. / bry[0];
  7852.     bry[2] = d1mach_(&c__2);
  7853.     s1r = cyr[0];
  7854.     s1i = cyi[0];
  7855.     s2r = cyr[1];
  7856.     s2i = cyi[1];
  7857.     c1r = csrr[iflag - 1];
  7858.     ascle = bry[iflag - 1];
  7859.     k = nd - 2;
  7860.     fn = (doublereal) ((real) k);
  7861.     i__1 = nd;
  7862.     for (i = 3; i <= i__1; ++i) {
  7863.         c2r = s2r;
  7864.         c2i = s2i;
  7865.         s2r = s1r + (*fnu + fn) * (rzr * c2r - rzi * c2i);
  7866.         s2i = s1i + (*fnu + fn) * (rzr * c2i + rzi * c2r);
  7867.         s1r = c2r;
  7868.         s1i = c2i;
  7869.         c2r = s2r * c1r;
  7870.         c2i = s2i * c1r;
  7871.         yr[k] = c2r;
  7872.         yi[k] = c2i;
  7873.         --k;
  7874.         fn += -1.;
  7875.         if (iflag >= 3) {
  7876.             goto L100;
  7877.         }
  7878.         str = abs(c2r);
  7879.         sti = abs(c2i);
  7880.         c2m = max(str,sti);
  7881.         if (c2m <= ascle) {
  7882.             goto L100;
  7883.         }
  7884.         ++iflag;
  7885.         ascle = bry[iflag - 1];
  7886.         s1r *= c1r;
  7887.         s1i *= c1r;
  7888.         s2r = c2r;
  7889.         s2i = c2i;
  7890.         s1r *= cssr[iflag - 1];
  7891.         s1i *= cssr[iflag - 1];
  7892.         s2r *= cssr[iflag - 1];
  7893.         s2i *= cssr[iflag - 1];
  7894.         c1r = csrr[iflag - 1];
  7895. L100:
  7896.         ;
  7897.     }
  7898. L110:
  7899.     return 0;
  7900. L120:
  7901.     if (rs1 > 0.) {
  7902.         goto L140;
  7903.     }
  7904. /* -----------------------------------------------------------------------
  7905.  */
  7906. /*     SET UNDERFLOW AND UPDATE PARAMETERS */
  7907. /* -----------------------------------------------------------------------
  7908.  */
  7909.     yr[nd] = zeror;
  7910.     yi[nd] = zeroi;
  7911.     ++(*nz);
  7912.     --nd;
  7913.     if (nd == 0) {
  7914.         goto L110;
  7915.     }
  7916.     zuoik_(zr, zi, fnu, kode, &c__1, &nd, &yr[1], &yi[1], &nuf, tol, elim, 
  7917.             alim);
  7918.     if (nuf < 0) {
  7919.         goto L140;
  7920.     }
  7921.     nd -= nuf;
  7922.     *nz += nuf;
  7923.     if (nd == 0) {
  7924.         goto L110;
  7925.     }
  7926.     fn = *fnu + (doublereal) ((real) (nd - 1));
  7927.     if (fn < *fnul) {
  7928.         goto L130;
  7929.     }
  7930. /*      FN = CIDI */
  7931. /*      J = NUF + 1 */
  7932. /*      K = MOD(J,4) + 1 */
  7933. /*      S1R = CIPR(K) */
  7934. /*      S1I = CIPI(K) */
  7935. /*      IF (FN.LT.0.0D0) S1I = -S1I */
  7936. /*      STR = C2R*S1R - C2I*S1I */
  7937. /*      C2I = C2R*S1I + C2I*S1R */
  7938. /*      C2R = STR */
  7939.     in = inu + nd - 1;
  7940.     in = in % 4 + 1;
  7941.     c2r = car * cipr[in - 1] - sar * cipi[in - 1];
  7942.     c2i = car * cipi[in - 1] + sar * cipr[in - 1];
  7943.     if (*zi <= 0.) {
  7944.         c2i = -c2i;
  7945.     }
  7946.     goto L40;
  7947. L130:
  7948.     *nlast = nd;
  7949.     return 0;
  7950. L140:
  7951.     *nz = -1;
  7952.     return 0;
  7953. L150:
  7954.     if (rs1 > 0.) {
  7955.         goto L140;
  7956.     }
  7957.     *nz = *n;
  7958.     i__1 = *n;
  7959.     for (i = 1; i <= i__1; ++i) {
  7960.         yr[i] = zeror;
  7961.         yi[i] = zeroi;
  7962. /* L160: */
  7963.     }
  7964.     return 0;
  7965. } /* zuni2_ */
  7966.  
  7967. /* funz.f -- translated by f2c (version of 16 May 1991  13:06:06).
  7968.    You must link the resulting object file with the libraries:
  7969.         -link <S|C|M|L>f2c.lib   (in that order)
  7970. */
  7971.  
  7972.  
  7973.  
  7974. /* Table of constant values */
  7975. /*
  7976. static integer c__1 = 1;
  7977. static integer c__2 = 2;
  7978. static integer c__0 = 0;
  7979. */
  7980. /* Subroutine */ int zunik_(doublereal *zrr, doublereal *zri, doublereal *fnu,
  7981.          integer *ikflg, integer *ipmtr, doublereal *tol, integer *init, 
  7982.         doublereal *phir, doublereal *phii, doublereal *zeta1r, doublereal *
  7983.         zeta1i, doublereal *zeta2r, doublereal *zeta2i, doublereal *sumr, 
  7984.         doublereal *sumi, doublereal *cwrkr, doublereal *cwrki)
  7985. {
  7986.     /* Initialized data */
  7987.  
  7988.     static doublereal zeror = 0.;
  7989.     static doublereal zeroi = 0.;
  7990.     static doublereal coner = 1.;
  7991.     static doublereal conei = 0.;
  7992.     static doublereal con[2] = { .398942280401432678,1.25331413731550025 };
  7993.     static doublereal c[120] = { 1.,-.208333333333333333,.125,
  7994.             .334201388888888889,-.401041666666666667,.0703125,
  7995.             -1.02581259645061728,1.84646267361111111,-.8912109375,.0732421875,
  7996.             4.66958442342624743,-11.2070026162229938,8.78912353515625,
  7997.             -2.3640869140625,.112152099609375,-28.2120725582002449,
  7998.             84.6362176746007346,-91.8182415432400174,42.5349987453884549,
  7999.             -7.3687943594796317,.227108001708984375,212.570130039217123,
  8000.             -765.252468141181642,1059.99045252799988,-699.579627376132541,
  8001.             218.19051174421159,-26.4914304869515555,.572501420974731445,
  8002.             -1919.457662318407,8061.72218173730938,-13586.5500064341374,
  8003.             11655.3933368645332,-5305.64697861340311,1200.90291321635246,
  8004.             -108.090919788394656,1.7277275025844574,20204.2913309661486,
  8005.             -96980.5983886375135,192547.001232531532,-203400.177280415534,
  8006.             122200.46498301746,-41192.6549688975513,7109.51430248936372,
  8007.             -493.915304773088012,6.07404200127348304,-242919.187900551333,
  8008.             1311763.6146629772,-2998015.91853810675,3763271.297656404,
  8009.             -2813563.22658653411,1268365.27332162478,-331645.172484563578,
  8010.             45218.7689813627263,-2499.83048181120962,24.3805296995560639,
  8011.             3284469.85307203782,-19706819.1184322269,50952602.4926646422,
  8012.             -74105148.2115326577,66344512.2747290267,-37567176.6607633513,
  8013.             13288767.1664218183,-2785618.12808645469,308186.404612662398,
  8014.             -13886.0897537170405,110.017140269246738,-49329253.664509962,
  8015.             325573074.185765749,-939462359.681578403,1553596899.57058006,
  8016.             -1621080552.10833708,1106842816.82301447,-495889784.275030309,
  8017.             142062907.797533095,-24474062.7257387285,2243768.17792244943,
  8018.             -84005.4336030240853,551.335896122020586,814789096.118312115,
  8019.             -5866481492.05184723,18688207509.2958249,-34632043388.1587779,
  8020.             41280185579.753974,-33026599749.8007231,17954213731.1556001,
  8021.             -6563293792.61928433,1559279864.87925751,-225105661.889415278,
  8022.             17395107.5539781645,-549842.327572288687,3038.09051092238427,
  8023.             -14679261247.6956167,114498237732.02581,-399096175224.466498,
  8024.             819218669548.577329,-1098375156081.22331,1008158106865.38209,
  8025.             -645364869245.376503,287900649906.150589,-87867072178.0232657,
  8026.             17634730606.8349694,-2167164983.22379509,143157876.718888981,
  8027.             -3871833.44257261262,18257.7554742931747,286464035717.679043,
  8028.             -2406297900028.50396,9109341185239.89896,-20516899410934.4374,
  8029.             30565125519935.3206,-31667088584785.1584,23348364044581.8409,
  8030.             -12320491305598.2872,4612725780849.13197,-1196552880196.1816,
  8031.             205914503232.410016,-21822927757.5292237,1247009293.51271032,
  8032.             -29188388.1222208134,118838.426256783253 };
  8033.  
  8034.     /* System generated locals */
  8035.     integer i__1;
  8036.     doublereal d__1, d__2;
  8037.  
  8038.     /* Builtin functions */
  8039.     double log(doublereal);
  8040.  
  8041.     /* Local variables */
  8042.     static integer idum;
  8043.     extern /* Subroutine */ int zlog_(doublereal *, doublereal *, doublereal *
  8044.             , doublereal *, integer *), zdiv_(doublereal *, doublereal *, 
  8045.             doublereal *, doublereal *, doublereal *, doublereal *);
  8046.     static doublereal test;
  8047.     static integer i, j, k, l;
  8048.     static doublereal crfni, crfnr;
  8049.     extern doublereal d1mach_(integer *);
  8050.     extern /* Subroutine */ int zsqrt_(doublereal *, doublereal *, doublereal 
  8051.             *, doublereal *);
  8052.     static doublereal ac, si, ti, sr, tr, t2i, t2r, rfn, sri, sti, zni, srr, 
  8053.             str, znr;
  8054.  
  8055. /* ***BEGIN PROLOGUE  ZUNIK */
  8056. /* ***REFER TO  ZBESI,ZBESK */
  8057.  
  8058. /*        ZUNIK COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC */
  8059. /*        EXPANSIONS OF THE I AND K FUNCTIONS ON IKFLG= 1 OR 2 */
  8060. /*        RESPECTIVELY BY */
  8061.  
  8062. /*        W(FNU,ZR) = PHI*EXP(ZETA)*SUM */
  8063.  
  8064. /*        WHERE       ZETA=-ZETA1 + ZETA2       OR */
  8065. /*                          ZETA1 - ZETA2 */
  8066.  
  8067. /*        THE FIRST CALL MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE */
  8068. /*        SAME ZR AND FNU WILL RETURN THE I OR K FUNCTION ON IKFLG= */
  8069. /*        1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK */
  8070. /*        ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI, */
  8071.  
  8072. /*        ZETA1,ZETA2. */
  8073.  
  8074. /* ***ROUTINES CALLED  ZDIV,ZLOG,ZSQRT,D1MACH */
  8075. /* ***END PROLOGUE  ZUNIK */
  8076. /*     COMPLEX CFN,CON,CONE,CRFN,CWRK,CZERO,PHI,S,SR,SUM,T,T2,ZETA1, */
  8077. /*    *ZETA2,ZN,ZR */
  8078.     /* Parameter adjustments */
  8079.     --cwrki;
  8080.     --cwrkr;
  8081.  
  8082.     /* Function Body */
  8083.  
  8084.     if (*init != 0) {
  8085.         goto L40;
  8086.     }
  8087. /* -----------------------------------------------------------------------
  8088.  */
  8089. /*     INITIALIZE ALL VARIABLES */
  8090. /* -----------------------------------------------------------------------
  8091.  */
  8092.     rfn = 1. / *fnu;
  8093. /* -----------------------------------------------------------------------
  8094.  */
  8095. /*     OVERFLOW TEST (ZR/FNU TOO SMALL) */
  8096. /* -----------------------------------------------------------------------
  8097.  */
  8098.     test = d1mach_(&c__1) * 1e3;
  8099.     ac = *fnu * test;
  8100.     if (abs(*zrr) > ac || abs(*zri) > ac) {
  8101.         goto L15;
  8102.     }
  8103.     *zeta1r = (d__1 = log(test), abs(d__1)) * 2. + *fnu;
  8104.     *zeta1i = 0.;
  8105.     *zeta2r = *fnu;
  8106.     *zeta2i = 0.;
  8107.     *phir = 1.;
  8108.     *phii = 0.;
  8109.     return 0;
  8110. L15:
  8111.     tr = *zrr * rfn;
  8112.     ti = *zri * rfn;
  8113.     sr = coner + (tr * tr - ti * ti);
  8114.     si = conei + (tr * ti + ti * tr);
  8115.     zsqrt_(&sr, &si, &srr, &sri);
  8116.     str = coner + srr;
  8117.     sti = conei + sri;
  8118.     zdiv_(&str, &sti, &tr, &ti, &znr, &zni);
  8119.     zlog_(&znr, &zni, &str, &sti, &idum);
  8120.     *zeta1r = *fnu * str;
  8121.     *zeta1i = *fnu * sti;
  8122.     *zeta2r = *fnu * srr;
  8123.     *zeta2i = *fnu * sri;
  8124.     zdiv_(&coner, &conei, &srr, &sri, &tr, &ti);
  8125.     srr = tr * rfn;
  8126.     sri = ti * rfn;
  8127.     zsqrt_(&srr, &sri, &cwrkr[16], &cwrki[16]);
  8128.     *phir = cwrkr[16] * con[*ikflg - 1];
  8129.     *phii = cwrki[16] * con[*ikflg - 1];
  8130.     if (*ipmtr != 0) {
  8131.         return 0;
  8132.     }
  8133.     zdiv_(&coner, &conei, &sr, &si, &t2r, &t2i);
  8134.     cwrkr[1] = coner;
  8135.     cwrki[1] = conei;
  8136.     crfnr = coner;
  8137.     crfni = conei;
  8138.     ac = 1.;
  8139.     l = 1;
  8140.     for (k = 2; k <= 15; ++k) {
  8141.         sr = zeror;
  8142.         si = zeroi;
  8143.         i__1 = k;
  8144.         for (j = 1; j <= i__1; ++j) {
  8145.             ++l;
  8146.             str = sr * t2r - si * t2i + c[l - 1];
  8147.             si = sr * t2i + si * t2r;
  8148.             sr = str;
  8149. /* L10: */
  8150.         }
  8151.         str = crfnr * srr - crfni * sri;
  8152.         crfni = crfnr * sri + crfni * srr;
  8153.         crfnr = str;
  8154.         cwrkr[k] = crfnr * sr - crfni * si;
  8155.         cwrki[k] = crfnr * si + crfni * sr;
  8156.         ac *= rfn;
  8157.         test = (d__1 = cwrkr[k], abs(d__1)) + (d__2 = cwrki[k], abs(d__2));
  8158.         if (ac < *tol && test < *tol) {
  8159.             goto L30;
  8160.         }
  8161. /* L20: */
  8162.     }
  8163.     k = 15;
  8164. L30:
  8165.     *init = k;
  8166. L40:
  8167.     if (*ikflg == 2) {
  8168.         goto L60;
  8169.     }
  8170. /* -----------------------------------------------------------------------
  8171.  */
  8172. /*     COMPUTE SUM FOR THE I FUNCTION */
  8173. /* -----------------------------------------------------------------------
  8174.  */
  8175.     sr = zeror;
  8176.     si = zeroi;
  8177.     i__1 = *init;
  8178.     for (i = 1; i <= i__1; ++i) {
  8179.         sr += cwrkr[i];
  8180.         si += cwrki[i];
  8181. /* L50: */
  8182.     }
  8183.     *sumr = sr;
  8184.     *sumi = si;
  8185.     *phir = cwrkr[16] * con[0];
  8186.     *phii = cwrki[16] * con[0];
  8187.     return 0;
  8188. L60:
  8189. /* -----------------------------------------------------------------------
  8190.  */
  8191. /*     COMPUTE SUM FOR THE K FUNCTION */
  8192. /* -----------------------------------------------------------------------
  8193.  */
  8194.     sr = zeror;
  8195.     si = zeroi;
  8196.     tr = coner;
  8197.     i__1 = *init;
  8198.     for (i = 1; i <= i__1; ++i) {
  8199.         sr += tr * cwrkr[i];
  8200.         si += tr * cwrki[i];
  8201.         tr = -tr;
  8202. /* L70: */
  8203.     }
  8204.     *sumr = sr;
  8205.     *sumi = si;
  8206.     *phir = cwrkr[16] * con[1];
  8207.     *phii = cwrki[16] * con[1];
  8208.     return 0;
  8209. } /* zunik_ */
  8210.  
  8211. /* Subroutine */ int zunk1_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  8212.         integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *
  8213.         yi, integer *nz, doublereal *tol, doublereal *elim, doublereal *alim)
  8214. {
  8215.     /* Initialized data */
  8216.  
  8217.     static doublereal zeror = 0.;
  8218.     static doublereal zeroi = 0.;
  8219.     static doublereal coner = 1.;
  8220.     static doublereal pi = 3.14159265358979324;
  8221.  
  8222.     /* System generated locals */
  8223.     integer i__1;
  8224.  
  8225.     /* Builtin functions */
  8226.     double log(doublereal), exp(doublereal), cos(doublereal), sin(doublereal),
  8227.              d_sign(doublereal *, doublereal *);
  8228.  
  8229.     /* Local variables */
  8230.     static doublereal aphi, cscl, phii[2], crsc, phir[2];
  8231.     static integer init[2];
  8232.     static doublereal csrr[3], cssr[3], rast, sumi[2], razr;
  8233.     extern /* Subroutine */ int zs1s2_(doublereal *, doublereal *, doublereal 
  8234.             *, doublereal *, doublereal *, doublereal *, integer *, 
  8235.             doublereal *, doublereal *, integer *);
  8236.     static doublereal sumr[2];
  8237.     extern doublereal z1abs_(doublereal *, doublereal *);
  8238.     static integer i, j, k, m, iflag, kflag;
  8239.     static doublereal ascle;
  8240.     static integer kdflg;
  8241.     static doublereal phidi;
  8242.     static integer ipard;
  8243.     static doublereal csgni, phidr;
  8244.     static integer initd;
  8245.     static doublereal cspni, cwrki[48]  /* was [16][3] */, sumdi;
  8246.     extern /* Subroutine */ int zuchk_(doublereal *, doublereal *, integer *, 
  8247.             doublereal *, doublereal *);
  8248.     static doublereal cspnr, cwrkr[48]  /* was [16][3] */, sumdr;
  8249.     extern doublereal d1mach_(integer *);
  8250.     extern /* Subroutine */ int zunik_(doublereal *, doublereal *, doublereal 
  8251.             *, integer *, integer *, doublereal *, integer *, doublereal *, 
  8252.             doublereal *, doublereal *, doublereal *, doublereal *, 
  8253.             doublereal *, doublereal *, doublereal *, doublereal *, 
  8254.             doublereal *);
  8255.     static doublereal zeta1i[2], zeta2i[2], zet1di, zet2di, zeta1r[2], zeta2r[
  8256.             2], zet1dr, zet2dr;
  8257.     static integer ib, ic;
  8258.     static doublereal fn;
  8259.     static integer il, kk, nw;
  8260.     static doublereal c1i, c2i, c2m, c1r, c2r, s1i, s2i, rs1, s1r, s2r, ang, 
  8261.             asc, cki, fnf;
  8262.     static integer ifn;
  8263.     static doublereal ckr;
  8264.     static integer iuf;
  8265.     static doublereal cyi[2], fmr, csr, sgn;
  8266.     static integer inu;
  8267.     static doublereal bry[3], cyr[2], sti, rzi, zri, str, rzr, zrr;
  8268.  
  8269. /* ***BEGIN PROLOGUE  ZUNK1 */
  8270. /* ***REFER TO  ZBESK */
  8271.  
  8272. /*     ZUNK1 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE */
  8273. /*     RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE */
  8274. /*     UNIFORM ASYMPTOTIC EXPANSION. */
  8275. /*     MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. 
  8276. */
  8277. /*     NZ=-1 MEANS AN OVERFLOW WILL OCCUR */
  8278.  
  8279. /* ***ROUTINES CALLED  ZKSCL,ZS1S2,ZUCHK,ZUNIK,D1MACH,Z1ABS */
  8280. /* ***END PROLOGUE  ZUNK1 */
  8281. /*     COMPLEX CFN,CK,CONE,CRSC,CS,CSCL,CSGN,CSPN,CSR,CSS,CWRK,CY,CZERO, 
  8282. */
  8283. /*    *C1,C2,PHI,PHID,RZ,SUM,SUMD,S1,S2,Y,Z,ZETA1,ZETA1D,ZETA2,ZETA2D,ZR 
  8284. */
  8285.     /* Parameter adjustments */
  8286.     --yi;
  8287.     --yr;
  8288.  
  8289.     /* Function Body */
  8290.  
  8291.     kdflg = 1;
  8292.     *nz = 0;
  8293. /* -----------------------------------------------------------------------
  8294.  */
  8295. /*     EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN */
  8296. /*     THE UNDERFLOW LIMIT */
  8297. /* -----------------------------------------------------------------------
  8298.  */
  8299.     cscl = 1. / *tol;
  8300.     crsc = *tol;
  8301.     cssr[0] = cscl;
  8302.     cssr[1] = coner;
  8303.     cssr[2] = crsc;
  8304.     csrr[0] = crsc;
  8305.     csrr[1] = coner;
  8306.     csrr[2] = cscl;
  8307.     bry[0] = d1mach_(&c__1) * 1e3 / *tol;
  8308.     bry[1] = 1. / bry[0];
  8309.     bry[2] = d1mach_(&c__2);
  8310.     zrr = *zr;
  8311.     zri = *zi;
  8312.     if (*zr >= 0.) {
  8313.         goto L10;
  8314.     }
  8315.     zrr = -(*zr);
  8316.     zri = -(*zi);
  8317. L10:
  8318.     j = 2;
  8319.     i__1 = *n;
  8320.     for (i = 1; i <= i__1; ++i) {
  8321. /* ------------------------------------------------------------------
  8322. ----- */
  8323. /*     J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J */
  8324. /* ------------------------------------------------------------------
  8325. ----- */
  8326.         j = 3 - j;
  8327.         fn = *fnu + (doublereal) ((real) (i - 1));
  8328.         init[j - 1] = 0;
  8329.         zunik_(&zrr, &zri, &fn, &c__2, &c__0, tol, &init[j - 1], &phir[j - 1],
  8330.                  &phii[j - 1], &zeta1r[j - 1], &zeta1i[j - 1], &zeta2r[j - 1],
  8331.                  &zeta2i[j - 1], &sumr[j - 1], &sumi[j - 1], &cwrkr[(j << 4) 
  8332.                 - 16], &cwrki[(j << 4) - 16]);
  8333.         if (*kode == 1) {
  8334.             goto L20;
  8335.         }
  8336.         str = zrr + zeta2r[j - 1];
  8337.         sti = zri + zeta2i[j - 1];
  8338.         rast = fn / z1abs_(&str, &sti);
  8339.         str = str * rast * rast;
  8340.         sti = -sti * rast * rast;
  8341.         s1r = zeta1r[j - 1] - str;
  8342.         s1i = zeta1i[j - 1] - sti;
  8343.         goto L30;
  8344. L20:
  8345.         s1r = zeta1r[j - 1] - zeta2r[j - 1];
  8346.         s1i = zeta1i[j - 1] - zeta2i[j - 1];
  8347. L30:
  8348.         rs1 = s1r;
  8349. /* ------------------------------------------------------------------
  8350. ----- */
  8351. /*     TEST FOR UNDERFLOW AND OVERFLOW */
  8352. /* ------------------------------------------------------------------
  8353. ----- */
  8354.         if (abs(rs1) > *elim) {
  8355.             goto L60;
  8356.         }
  8357.         if (kdflg == 1) {
  8358.             kflag = 2;
  8359.         }
  8360.         if (abs(rs1) < *alim) {
  8361.             goto L40;
  8362.         }
  8363. /* ------------------------------------------------------------------
  8364. ----- */
  8365. /*     REFINE  TEST AND SCALE */
  8366. /* ------------------------------------------------------------------
  8367. ----- */
  8368.         aphi = z1abs_(&phir[j - 1], &phii[j - 1]);
  8369.         rs1 += log(aphi);
  8370.         if (abs(rs1) > *elim) {
  8371.             goto L60;
  8372.         }
  8373.         if (kdflg == 1) {
  8374.             kflag = 1;
  8375.         }
  8376.         if (rs1 < 0.) {
  8377.             goto L40;
  8378.         }
  8379.         if (kdflg == 1) {
  8380.             kflag = 3;
  8381.         }
  8382. L40:
  8383. /* ------------------------------------------------------------------
  8384. ----- */
  8385. /*     SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR */
  8386. /*     EXPONENT EXTREMES */
  8387. /* ------------------------------------------------------------------
  8388. ----- */
  8389.         s2r = phir[j - 1] * sumr[j - 1] - phii[j - 1] * sumi[j - 1];
  8390.         s2i = phir[j - 1] * sumi[j - 1] + phii[j - 1] * sumr[j - 1];
  8391.         str = exp(s1r) * cssr[kflag - 1];
  8392.         s1r = str * cos(s1i);
  8393.         s1i = str * sin(s1i);
  8394.         str = s2r * s1r - s2i * s1i;
  8395.         s2i = s1r * s2i + s2r * s1i;
  8396.         s2r = str;
  8397.         if (kflag != 1) {
  8398.             goto L50;
  8399.         }
  8400.         zuchk_(&s2r, &s2i, &nw, bry, tol);
  8401.         if (nw != 0) {
  8402.             goto L60;
  8403.         }
  8404. L50:
  8405.         cyr[kdflg - 1] = s2r;
  8406.         cyi[kdflg - 1] = s2i;
  8407.         yr[i] = s2r * csrr[kflag - 1];
  8408.         yi[i] = s2i * csrr[kflag - 1];
  8409.         if (kdflg == 2) {
  8410.             goto L75;
  8411.         }
  8412.         kdflg = 2;
  8413.         goto L70;
  8414. L60:
  8415.         if (rs1 > 0.) {
  8416.             goto L300;
  8417.         }
  8418. /* ------------------------------------------------------------------
  8419. ----- */
  8420. /*     FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW */
  8421. /* ------------------------------------------------------------------
  8422. ----- */
  8423.         if (*zr < 0.) {
  8424.             goto L300;
  8425.         }
  8426.         kdflg = 1;
  8427.         yr[i] = zeror;
  8428.         yi[i] = zeroi;
  8429.         ++(*nz);
  8430.         if (i == 1) {
  8431.             goto L70;
  8432.         }
  8433.         if (yr[i - 1] == zeror && yi[i - 1] == zeroi) {
  8434.             goto L70;
  8435.         }
  8436.         yr[i - 1] = zeror;
  8437.         yi[i - 1] = zeroi;
  8438.         ++(*nz);
  8439. L70:
  8440.         ;
  8441.     }
  8442.     i = *n;
  8443. L75:
  8444.     razr = 1. / z1abs_(&zrr, &zri);
  8445.     str = zrr * razr;
  8446.     sti = -zri * razr;
  8447.     rzr = (str + str) * razr;
  8448.     rzi = (sti + sti) * razr;
  8449.     ckr = fn * rzr;
  8450.     cki = fn * rzi;
  8451.     ib = i + 1;
  8452.     if (*n < ib) {
  8453.         goto L160;
  8454.     }
  8455. /* -----------------------------------------------------------------------
  8456.  */
  8457. /*     TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO 
  8458. */
  8459. /*     ON UNDERFLOW. */
  8460. /* -----------------------------------------------------------------------
  8461.  */
  8462.     fn = *fnu + (doublereal) ((real) (*n - 1));
  8463.     ipard = 1;
  8464.     if (*mr != 0) {
  8465.         ipard = 0;
  8466.     }
  8467.     initd = 0;
  8468.     zunik_(&zrr, &zri, &fn, &c__2, &ipard, tol, &initd, &phidr, &phidi, &
  8469.             zet1dr, &zet1di, &zet2dr, &zet2di, &sumdr, &sumdi, &cwrkr[32], &
  8470.             cwrki[32]);
  8471.     if (*kode == 1) {
  8472.         goto L80;
  8473.     }
  8474.     str = zrr + zet2dr;
  8475.     sti = zri + zet2di;
  8476.     rast = fn / z1abs_(&str, &sti);
  8477.     str = str * rast * rast;
  8478.     sti = -sti * rast * rast;
  8479.     s1r = zet1dr - str;
  8480.     s1i = zet1di - sti;
  8481.     goto L90;
  8482. L80:
  8483.     s1r = zet1dr - zet2dr;
  8484.     s1i = zet1di - zet2di;
  8485. L90:
  8486.     rs1 = s1r;
  8487.     if (abs(rs1) > *elim) {
  8488.         goto L95;
  8489.     }
  8490.     if (abs(rs1) < *alim) {
  8491.         goto L100;
  8492.     }
  8493. /*-----------------------------------------------------------------------
  8494. -----*/
  8495. /*     REFINE ESTIMATE AND TEST */
  8496. /*-----------------------------------------------------------------------
  8497. --*/
  8498.     aphi = z1abs_(&phidr, &phidi);
  8499.     rs1 += log(aphi);
  8500.     if (abs(rs1) < *elim) {
  8501.         goto L100;
  8502.     }
  8503. L95:
  8504.     if (abs(rs1) > 0.) {
  8505.         goto L300;
  8506.     }
  8507. /* -----------------------------------------------------------------------
  8508.  */
  8509. /*     FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW */
  8510. /* -----------------------------------------------------------------------
  8511.  */
  8512.     if (*zr < 0.) {
  8513.         goto L300;
  8514.     }
  8515.     *nz = *n;
  8516.     i__1 = *n;
  8517.     for (i = 1; i <= i__1; ++i) {
  8518.         yr[i] = zeror;
  8519.         yi[i] = zeroi;
  8520. /* L96: */
  8521.     }
  8522.     return 0;
  8523. /*-----------------------------------------------------------------------
  8524. ----*/
  8525. /*     FORWARD RECUR FOR REMAINDER OF THE SEQUENCE */
  8526. /*-----------------------------------------------------------------------
  8527. -----*/
  8528. L100:
  8529.     s1r = cyr[0];
  8530.     s1i = cyi[0];
  8531.     s2r = cyr[1];
  8532.     s2i = cyi[1];
  8533.     c1r = csrr[kflag - 1];
  8534.     ascle = bry[kflag - 1];
  8535.     i__1 = *n;
  8536.     for (i = ib; i <= i__1; ++i) {
  8537.         c2r = s2r;
  8538.         c2i = s2i;
  8539.         s2r = ckr * c2r - cki * c2i + s1r;
  8540.         s2i = ckr * c2i + cki * c2r + s1i;
  8541.         s1r = c2r;
  8542.         s1i = c2i;
  8543.         ckr += rzr;
  8544.         cki += rzi;
  8545.         c2r = s2r * c1r;
  8546.         c2i = s2i * c1r;
  8547.         yr[i] = c2r;
  8548.         yi[i] = c2i;
  8549.         if (kflag >= 3) {
  8550.             goto L120;
  8551.         }
  8552.         str = abs(c2r);
  8553.         sti = abs(c2i);
  8554.         c2m = max(str,sti);
  8555.         if (c2m <= ascle) {
  8556.             goto L120;
  8557.         }
  8558.         ++kflag;
  8559.         ascle = bry[kflag - 1];
  8560.         s1r *= c1r;
  8561.         s1i *= c1r;
  8562.         s2r = c2r;
  8563.         s2i = c2i;
  8564.         s1r *= cssr[kflag - 1];
  8565.         s1i *= cssr[kflag - 1];
  8566.         s2r *= cssr[kflag - 1];
  8567.         s2i *= cssr[kflag - 1];
  8568.         c1r = csrr[kflag - 1];
  8569. L120:
  8570.         ;
  8571.     }
  8572. L160:
  8573.     if (*mr == 0) {
  8574.         return 0;
  8575.     }
  8576. /* -----------------------------------------------------------------------
  8577.  */
  8578. /*     ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0 */
  8579. /* -----------------------------------------------------------------------
  8580.  */
  8581.     *nz = 0;
  8582.     fmr = (doublereal) ((real) (*mr));
  8583.     sgn = -d_sign(&pi, &fmr);
  8584. /* -----------------------------------------------------------------------
  8585.  */
  8586. /*     CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. */
  8587. /* -----------------------------------------------------------------------
  8588.  */
  8589.     csgni = sgn;
  8590.     inu = (integer) (*fnu);
  8591.     fnf = *fnu - (doublereal) ((real) inu);
  8592.     ifn = inu + *n - 1;
  8593.     ang = fnf * sgn;
  8594.     cspnr = cos(ang);
  8595.     cspni = sin(ang);
  8596.     if (ifn % 2 == 0) {
  8597.         goto L170;
  8598.     }
  8599.     cspnr = -cspnr;
  8600.     cspni = -cspni;
  8601. L170:
  8602.     asc = bry[0];
  8603.     iuf = 0;
  8604.     kk = *n;
  8605.     kdflg = 1;
  8606.     --ib;
  8607.     ic = ib - 1;
  8608.     i__1 = *n;
  8609.     for (k = 1; k <= i__1; ++k) {
  8610.         fn = *fnu + (doublereal) ((real) (kk - 1));
  8611. /* ------------------------------------------------------------------
  8612. ----- */
  8613. /*     LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K */
  8614. /*     FUNCTION ABOVE */
  8615. /* ------------------------------------------------------------------
  8616. ----- */
  8617.         m = 3;
  8618.         if (*n > 2) {
  8619.             goto L175;
  8620.         }
  8621. L172:
  8622.         initd = init[j - 1];
  8623.         phidr = phir[j - 1];
  8624.         phidi = phii[j - 1];
  8625.         zet1dr = zeta1r[j - 1];
  8626.         zet1di = zeta1i[j - 1];
  8627.         zet2dr = zeta2r[j - 1];
  8628.         zet2di = zeta2i[j - 1];
  8629.         sumdr = sumr[j - 1];
  8630.         sumdi = sumi[j - 1];
  8631.         m = j;
  8632.         j = 3 - j;
  8633.         goto L180;
  8634. L175:
  8635.         if (kk == *n && ib < *n) {
  8636.             goto L180;
  8637.         }
  8638.         if (kk == ib || kk == ic) {
  8639.             goto L172;
  8640.         }
  8641.         initd = 0;
  8642. L180:
  8643.         zunik_(&zrr, &zri, &fn, &c__1, &c__0, tol, &initd, &phidr, &phidi, &
  8644.                 zet1dr, &zet1di, &zet2dr, &zet2di, &sumdr, &sumdi, &cwrkr[(m 
  8645.                 << 4) - 16], &cwrki[(m << 4) - 16]);
  8646.         if (*kode == 1) {
  8647.             goto L200;
  8648.         }
  8649.         str = zrr + zet2dr;
  8650.         sti = zri + zet2di;
  8651.         rast = fn / z1abs_(&str, &sti);
  8652.         str = str * rast * rast;
  8653.         sti = -sti * rast * rast;
  8654.         s1r = -zet1dr + str;
  8655.         s1i = -zet1di + sti;
  8656.         goto L210;
  8657. L200:
  8658.         s1r = -zet1dr + zet2dr;
  8659.         s1i = -zet1di + zet2di;
  8660. L210:
  8661. /* ------------------------------------------------------------------
  8662. ----- */
  8663. /*     TEST FOR UNDERFLOW AND OVERFLOW */
  8664. /* ------------------------------------------------------------------
  8665. ----- */
  8666.         rs1 = s1r;
  8667.         if (abs(rs1) > *elim) {
  8668.             goto L260;
  8669.         }
  8670.         if (kdflg == 1) {
  8671.             iflag = 2;
  8672.         }
  8673.         if (abs(rs1) < *alim) {
  8674.             goto L220;
  8675.         }
  8676. /* ------------------------------------------------------------------
  8677. ----- */
  8678. /*     REFINE  TEST AND SCALE */
  8679. /* ------------------------------------------------------------------
  8680. ----- */
  8681.         aphi = z1abs_(&phidr, &phidi);
  8682.         rs1 += log(aphi);
  8683.         if (abs(rs1) > *elim) {
  8684.             goto L260;
  8685.         }
  8686.         if (kdflg == 1) {
  8687.             iflag = 1;
  8688.         }
  8689.         if (rs1 < 0.) {
  8690.             goto L220;
  8691.         }
  8692.         if (kdflg == 1) {
  8693.             iflag = 3;
  8694.         }
  8695. L220:
  8696.         str = phidr * sumdr - phidi * sumdi;
  8697.         sti = phidr * sumdi + phidi * sumdr;
  8698.         s2r = -csgni * sti;
  8699.         s2i = csgni * str;
  8700.         str = exp(s1r) * cssr[iflag - 1];
  8701.         s1r = str * cos(s1i);
  8702.         s1i = str * sin(s1i);
  8703.         str = s2r * s1r - s2i * s1i;
  8704.         s2i = s2r * s1i + s2i * s1r;
  8705.         s2r = str;
  8706.         if (iflag != 1) {
  8707.             goto L230;
  8708.         }
  8709.         zuchk_(&s2r, &s2i, &nw, bry, tol);
  8710.         if (nw == 0) {
  8711.             goto L230;
  8712.         }
  8713.         s2r = zeror;
  8714.         s2i = zeroi;
  8715. L230:
  8716.         cyr[kdflg - 1] = s2r;
  8717.         cyi[kdflg - 1] = s2i;
  8718.         c2r = s2r;
  8719.         c2i = s2i;
  8720.         s2r *= csrr[iflag - 1];
  8721.         s2i *= csrr[iflag - 1];
  8722. /* ------------------------------------------------------------------
  8723. ----- */
  8724. /*     ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N */
  8725. /* ------------------------------------------------------------------
  8726. ----- */
  8727.         s1r = yr[kk];
  8728.         s1i = yi[kk];
  8729.         if (*kode == 1) {
  8730.             goto L250;
  8731.         }
  8732.         zs1s2_(&zrr, &zri, &s1r, &s1i, &s2r, &s2i, &nw, &asc, alim, &iuf);
  8733.         *nz += nw;
  8734. L250:
  8735.         yr[kk] = s1r * cspnr - s1i * cspni + s2r;
  8736.         yi[kk] = cspnr * s1i + cspni * s1r + s2i;
  8737.         --kk;
  8738.         cspnr = -cspnr;
  8739.         cspni = -cspni;
  8740.         if (c2r != 0. || c2i != 0.) {
  8741.             goto L255;
  8742.         }
  8743.         kdflg = 1;
  8744.         goto L270;
  8745. L255:
  8746.         if (kdflg == 2) {
  8747.             goto L275;
  8748.         }
  8749.         kdflg = 2;
  8750.         goto L270;
  8751. L260:
  8752.         if (rs1 > 0.) {
  8753.             goto L300;
  8754.         }
  8755.         s2r = zeror;
  8756.         s2i = zeroi;
  8757.         goto L230;
  8758. L270:
  8759.         ;
  8760.     }
  8761.     k = *n;
  8762. L275:
  8763.     il = *n - k;
  8764.     if (il == 0) {
  8765.         return 0;
  8766.     }
  8767. /* -----------------------------------------------------------------------
  8768.  */
  8769. /*     RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE */
  8770. /*     K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP */
  8771. /*     INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. */
  8772. /* -----------------------------------------------------------------------
  8773.  */
  8774.     s1r = cyr[0];
  8775.     s1i = cyi[0];
  8776.     s2r = cyr[1];
  8777.     s2i = cyi[1];
  8778.     csr = csrr[iflag - 1];
  8779.     ascle = bry[iflag - 1];
  8780.     fn = (doublereal) ((real) (inu + il));
  8781.     i__1 = il;
  8782.     for (i = 1; i <= i__1; ++i) {
  8783.         c2r = s2r;
  8784.         c2i = s2i;
  8785.         s2r = s1r + (fn + fnf) * (rzr * c2r - rzi * c2i);
  8786.         s2i = s1i + (fn + fnf) * (rzr * c2i + rzi * c2r);
  8787.         s1r = c2r;
  8788.         s1i = c2i;
  8789.         fn += -1.;
  8790.         c2r = s2r * csr;
  8791.         c2i = s2i * csr;
  8792.         ckr = c2r;
  8793.         cki = c2i;
  8794.         c1r = yr[kk];
  8795.         c1i = yi[kk];
  8796.         if (*kode == 1) {
  8797.             goto L280;
  8798.         }
  8799.         zs1s2_(&zrr, &zri, &c1r, &c1i, &c2r, &c2i, &nw, &asc, alim, &iuf);
  8800.         *nz += nw;
  8801. L280:
  8802.         yr[kk] = c1r * cspnr - c1i * cspni + c2r;
  8803.         yi[kk] = c1r * cspni + c1i * cspnr + c2i;
  8804.         --kk;
  8805.         cspnr = -cspnr;
  8806.         cspni = -cspni;
  8807.         if (iflag >= 3) {
  8808.             goto L290;
  8809.         }
  8810.         c2r = abs(ckr);
  8811.         c2i = abs(cki);
  8812.         c2m = max(c2r,c2i);
  8813.         if (c2m <= ascle) {
  8814.             goto L290;
  8815.         }
  8816.         ++iflag;
  8817.         ascle = bry[iflag - 1];
  8818.         s1r *= csr;
  8819.         s1i *= csr;
  8820.         s2r = ckr;
  8821.         s2i = cki;
  8822.         s1r *= cssr[iflag - 1];
  8823.         s1i *= cssr[iflag - 1];
  8824.         s2r *= cssr[iflag - 1];
  8825.         s2i *= cssr[iflag - 1];
  8826.         csr = csrr[iflag - 1];
  8827. L290:
  8828.         ;
  8829.     }
  8830.     return 0;
  8831. L300:
  8832.     *nz = -1;
  8833.     return 0;
  8834. } /* zunk1_ */
  8835.  
  8836. /* Subroutine */ int zunk2_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  8837.         integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *
  8838.         yi, integer *nz, doublereal *tol, doublereal *elim, doublereal *alim)
  8839. {
  8840.     /* Initialized data */
  8841.  
  8842.     static doublereal zeror = 0.;
  8843.     static doublereal zeroi = 0.;
  8844.     static doublereal coner = 1.;
  8845.     static doublereal cr1r = 1.;
  8846.     static doublereal cr1i = 1.73205080756887729;
  8847.     static doublereal cr2r = -.5;
  8848.     static doublereal cr2i = -.866025403784438647;
  8849.     static doublereal hpi = 1.57079632679489662;
  8850.     static doublereal pi = 3.14159265358979324;
  8851.     static doublereal aic = 1.26551212348464539;
  8852.     static doublereal cipr[4] = { 1.,0.,-1.,0. };
  8853.     static doublereal cipi[4] = { 0.,-1.,0.,1. };
  8854.  
  8855.     /* System generated locals */
  8856.     integer i__1;
  8857.  
  8858.     /* Builtin functions */
  8859.     double cos(doublereal), sin(doublereal), log(doublereal), exp(doublereal),
  8860.              d_sign(doublereal *, doublereal *);
  8861.  
  8862.     /* Local variables */
  8863.     static doublereal daii, aarg;
  8864.     static integer ndai;
  8865.     static doublereal dair, aphi, argi[2], cscl, phii[2], crsc, argr[2];
  8866.     static integer idum;
  8867.     static doublereal phir[2], csrr[3], cssr[3], rast, razr;
  8868.     extern /* Subroutine */ int zs1s2_(doublereal *, doublereal *, doublereal 
  8869.             *, doublereal *, doublereal *, doublereal *, integer *, 
  8870.             doublereal *, doublereal *, integer *);
  8871.     extern doublereal z1abs_(doublereal *, doublereal *);
  8872.     static integer i, k, j, iflag, kflag;
  8873.     static doublereal argdi, ascle;
  8874.     static integer kdflg;
  8875.     static doublereal phidi, argdr;
  8876.     static integer ipard;
  8877.     static doublereal csgni, phidr, cspni, asumi[2], bsumi[2];
  8878.     extern /* Subroutine */ int zuchk_(doublereal *, doublereal *, integer *, 
  8879.             doublereal *, doublereal *);
  8880.     static doublereal cspnr, asumr[2], bsumr[2];
  8881.     extern doublereal d1mach_(integer *);
  8882.     extern /* Subroutine */ int zunhj_(doublereal *, doublereal *, doublereal 
  8883.             *, integer *, doublereal *, doublereal *, doublereal *, 
  8884.             doublereal *, doublereal *, doublereal *, doublereal *, 
  8885.             doublereal *, doublereal *, doublereal *, doublereal *, 
  8886.             doublereal *, doublereal *), zairy_(doublereal *, doublereal *, 
  8887.             integer *, integer *, doublereal *, doublereal *, integer *, 
  8888.             integer *);
  8889.     static doublereal zeta1i[2], zeta2i[2], zet1di, zet2di, zeta1r[2], zeta2r[
  8890.             2], zet1dr, zet2dr;
  8891.     static integer ib, ic;
  8892.     static doublereal fn;
  8893.     static integer il, kk, in, nw;
  8894.     static doublereal asumdi, bsumdi, yy, asumdr, bsumdr, c1i, c2i, c2m, c1r, 
  8895.             c2r, s1i, s2i, rs1, s1r, s2r, aii, ang, asc, car, cki, fnf;
  8896.     static integer nai;
  8897.     static doublereal air;
  8898.     static integer ifn;
  8899.     static doublereal csi, ckr;
  8900.     static integer iuf;
  8901.     static doublereal cyi[2], fmr, sar, csr, sgn, zbi;
  8902.     static integer inu;
  8903.     static doublereal bry[3], cyr[2], pti, sti, zbr, zni, rzi, ptr, zri, str, 
  8904.             znr, rzr, zrr;
  8905.  
  8906. /* ***BEGIN PROLOGUE  ZUNK2 */
  8907. /* ***REFER TO  ZBESK */
  8908.  
  8909. /*     ZUNK2 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE */
  8910. /*     RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE */
  8911. /*     UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN) */
  8912. /*     WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR */
  8913. /*     -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z IF Z IS IN THE RIGHT */
  8914. /*     HALF PLANE OR ZR=-Z IF Z IS IN THE LEFT HALF PLANE. MR INDIC- */
  8915. /*     ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. */
  8916. /*     NZ=-1 MEANS AN OVERFLOW WILL OCCUR */
  8917.  
  8918. /* ***ROUTINES CALLED  ZAIRY,ZKSCL,ZS1S2,ZUCHK,ZUNHJ,D1MACH,Z1ABS */
  8919. /* ***END PROLOGUE  ZUNK2 */
  8920. /*     COMPLEX AI,ARG,ARGD,ASUM,ASUMD,BSUM,BSUMD,CFN,CI,CIP,CK,CONE,CRSC, 
  8921. */
  8922. /*    *CR1,CR2,CS,CSCL,CSGN,CSPN,CSR,CSS,CY,CZERO,C1,C2,DAI,PHI,PHID,RZ, 
  8923. */
  8924. /*    *S1,S2,Y,Z,ZB,ZETA1,ZETA1D,ZETA2,ZETA2D,ZN,ZR */
  8925.     /* Parameter adjustments */
  8926.     --yi;
  8927.     --yr;
  8928.  
  8929.     /* Function Body */
  8930.  
  8931.     kdflg = 1;
  8932.     *nz = 0;
  8933. /* -----------------------------------------------------------------------
  8934.  */
  8935. /*     EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN */
  8936. /*     THE UNDERFLOW LIMIT */
  8937. /* -----------------------------------------------------------------------
  8938.  */
  8939.     cscl = 1. / *tol;
  8940.     crsc = *tol;
  8941.     cssr[0] = cscl;
  8942.     cssr[1] = coner;
  8943.     cssr[2] = crsc;
  8944.     csrr[0] = crsc;
  8945.     csrr[1] = coner;
  8946.     csrr[2] = cscl;
  8947.     bry[0] = d1mach_(&c__1) * 1e3 / *tol;
  8948.     bry[1] = 1. / bry[0];
  8949.     bry[2] = d1mach_(&c__2);
  8950.     zrr = *zr;
  8951.     zri = *zi;
  8952.     if (*zr >= 0.) {
  8953.         goto L10;
  8954.     }
  8955.     zrr = -(*zr);
  8956.     zri = -(*zi);
  8957. L10:
  8958.     yy = zri;
  8959.     znr = zri;
  8960.     zni = -zrr;
  8961.     zbr = zrr;
  8962.     zbi = zri;
  8963.     inu = (integer) (*fnu);
  8964.     fnf = *fnu - (doublereal) ((real) inu);
  8965.     ang = -hpi * fnf;
  8966.     car = cos(ang);
  8967.     sar = sin(ang);
  8968.     c2r = hpi * sar;
  8969.     c2i = -hpi * car;
  8970.     kk = inu % 4 + 1;
  8971.     str = c2r * cipr[kk - 1] - c2i * cipi[kk - 1];
  8972.     sti = c2r * cipi[kk - 1] + c2i * cipr[kk - 1];
  8973.     csr = cr1r * str - cr1i * sti;
  8974.     csi = cr1r * sti + cr1i * str;
  8975.     if (yy > 0.) {
  8976.         goto L20;
  8977.     }
  8978.     znr = -znr;
  8979.     zbi = -zbi;
  8980. L20:
  8981. /* -----------------------------------------------------------------------
  8982.  */
  8983. /*     K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST */
  8984. /*     QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY */
  8985. /*     CONJUGATION SINCE THE K FUNCTION IS REAL ON THE POSITIVE REAL AXIS 
  8986. */
  8987. /* -----------------------------------------------------------------------
  8988.  */
  8989.     j = 2;
  8990.     i__1 = *n;
  8991.     for (i = 1; i <= i__1; ++i) {
  8992. /* ------------------------------------------------------------------
  8993. ----- */
  8994. /*     J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J */
  8995. /* ------------------------------------------------------------------
  8996. ----- */
  8997.         j = 3 - j;
  8998.         fn = *fnu + (doublereal) ((real) (i - 1));
  8999.         zunhj_(&znr, &zni, &fn, &c__0, tol, &phir[j - 1], &phii[j - 1], &argr[
  9000.                 j - 1], &argi[j - 1], &zeta1r[j - 1], &zeta1i[j - 1], &zeta2r[
  9001.                 j - 1], &zeta2i[j - 1], &asumr[j - 1], &asumi[j - 1], &bsumr[
  9002.                 j - 1], &bsumi[j - 1]);
  9003.         if (*kode == 1) {
  9004.             goto L30;
  9005.         }
  9006.         str = zbr + zeta2r[j - 1];
  9007.         sti = zbi + zeta2i[j - 1];
  9008.         rast = fn / z1abs_(&str, &sti);
  9009.         str = str * rast * rast;
  9010.         sti = -sti * rast * rast;
  9011.         s1r = zeta1r[j - 1] - str;
  9012.         s1i = zeta1i[j - 1] - sti;
  9013.         goto L40;
  9014. L30:
  9015.         s1r = zeta1r[j - 1] - zeta2r[j - 1];
  9016.         s1i = zeta1i[j - 1] - zeta2i[j - 1];
  9017. L40:
  9018. /* ------------------------------------------------------------------
  9019. ----- */
  9020. /*     TEST FOR UNDERFLOW AND OVERFLOW */
  9021. /* ------------------------------------------------------------------
  9022. ----- */
  9023.         rs1 = s1r;
  9024.         if (abs(rs1) > *elim) {
  9025.             goto L70;
  9026.         }
  9027.         if (kdflg == 1) {
  9028.             kflag = 2;
  9029.         }
  9030.         if (abs(rs1) < *alim) {
  9031.             goto L50;
  9032.         }
  9033. /* ------------------------------------------------------------------
  9034. ----- */
  9035. /*     REFINE  TEST AND SCALE */
  9036. /* ------------------------------------------------------------------
  9037. ----- */
  9038.         aphi = z1abs_(&phir[j - 1], &phii[j - 1]);
  9039.         aarg = z1abs_(&argr[j - 1], &argi[j - 1]);
  9040.         rs1 = rs1 + log(aphi) - log(aarg) * .25 - aic;
  9041.         if (abs(rs1) > *elim) {
  9042.             goto L70;
  9043.         }
  9044.         if (kdflg == 1) {
  9045.             kflag = 1;
  9046.         }
  9047.         if (rs1 < 0.) {
  9048.             goto L50;
  9049.         }
  9050.         if (kdflg == 1) {
  9051.             kflag = 3;
  9052.         }
  9053. L50:
  9054. /* ------------------------------------------------------------------
  9055. ----- */
  9056. /*     SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR */
  9057. /*     EXPONENT EXTREMES */
  9058. /* ------------------------------------------------------------------
  9059. ----- */
  9060.         c2r = argr[j - 1] * cr2r - argi[j - 1] * cr2i;
  9061.         c2i = argr[j - 1] * cr2i + argi[j - 1] * cr2r;
  9062.         zairy_(&c2r, &c2i, &c__0, &c__2, &air, &aii, &nai, &idum);
  9063.         zairy_(&c2r, &c2i, &c__1, &c__2, &dair, &daii, &ndai, &idum);
  9064.         str = dair * bsumr[j - 1] - daii * bsumi[j - 1];
  9065.         sti = dair * bsumi[j - 1] + daii * bsumr[j - 1];
  9066.         ptr = str * cr2r - sti * cr2i;
  9067.         pti = str * cr2i + sti * cr2r;
  9068.         str = ptr + (air * asumr[j - 1] - aii * asumi[j - 1]);
  9069.         sti = pti + (air * asumi[j - 1] + aii * asumr[j - 1]);
  9070.         ptr = str * phir[j - 1] - sti * phii[j - 1];
  9071.         pti = str * phii[j - 1] + sti * phir[j - 1];
  9072.         s2r = ptr * csr - pti * csi;
  9073.         s2i = ptr * csi + pti * csr;
  9074.         str = exp(s1r) * cssr[kflag - 1];
  9075.         s1r = str * cos(s1i);
  9076.         s1i = str * sin(s1i);
  9077.         str = s2r * s1r - s2i * s1i;
  9078.         s2i = s1r * s2i + s2r * s1i;
  9079.         s2r = str;
  9080.         if (kflag != 1) {
  9081.             goto L60;
  9082.         }
  9083.         zuchk_(&s2r, &s2i, &nw, bry, tol);
  9084.         if (nw != 0) {
  9085.             goto L70;
  9086.         }
  9087. L60:
  9088.         if (yy <= 0.) {
  9089.             s2i = -s2i;
  9090.         }
  9091.         cyr[kdflg - 1] = s2r;
  9092.         cyi[kdflg - 1] = s2i;
  9093.         yr[i] = s2r * csrr[kflag - 1];
  9094.         yi[i] = s2i * csrr[kflag - 1];
  9095.         str = csi;
  9096.         csi = -csr;
  9097.         csr = str;
  9098.         if (kdflg == 2) {
  9099.             goto L85;
  9100.         }
  9101.         kdflg = 2;
  9102.         goto L80;
  9103. L70:
  9104.         if (rs1 > 0.) {
  9105.             goto L320;
  9106.         }
  9107. /* ------------------------------------------------------------------
  9108. ----- */
  9109. /*     FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW */
  9110. /* ------------------------------------------------------------------
  9111. ----- */
  9112.         if (*zr < 0.) {
  9113.             goto L320;
  9114.         }
  9115.         kdflg = 1;
  9116.         yr[i] = zeror;
  9117.         yi[i] = zeroi;
  9118.         ++(*nz);
  9119.         str = csi;
  9120.         csi = -csr;
  9121.         csr = str;
  9122.         if (i == 1) {
  9123.             goto L80;
  9124.         }
  9125.         if (yr[i - 1] == zeror && yi[i - 1] == zeroi) {
  9126.             goto L80;
  9127.         }
  9128.         yr[i - 1] = zeror;
  9129.         yi[i - 1] = zeroi;
  9130.         ++(*nz);
  9131. L80:
  9132.         ;
  9133.     }
  9134.     i = *n;
  9135. L85:
  9136.     razr = 1. / z1abs_(&zrr, &zri);
  9137.     str = zrr * razr;
  9138.     sti = -zri * razr;
  9139.     rzr = (str + str) * razr;
  9140.     rzi = (sti + sti) * razr;
  9141.     ckr = fn * rzr;
  9142.     cki = fn * rzi;
  9143.     ib = i + 1;
  9144.     if (*n < ib) {
  9145.         goto L180;
  9146.     }
  9147. /* -----------------------------------------------------------------------
  9148.  */
  9149. /*     TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO 
  9150. */
  9151. /*     ON UNDERFLOW. */
  9152. /* -----------------------------------------------------------------------
  9153.  */
  9154.     fn = *fnu + (doublereal) ((real) (*n - 1));
  9155.     ipard = 1;
  9156.     if (*mr != 0) {
  9157.         ipard = 0;
  9158.     }
  9159.     zunhj_(&znr, &zni, &fn, &ipard, tol, &phidr, &phidi, &argdr, &argdi, &
  9160.             zet1dr, &zet1di, &zet2dr, &zet2di, &asumdr, &asumdi, &bsumdr, &
  9161.             bsumdi);
  9162.     if (*kode == 1) {
  9163.         goto L90;
  9164.     }
  9165.     str = zbr + zet2dr;
  9166.     sti = zbi + zet2di;
  9167.     rast = fn / z1abs_(&str, &sti);
  9168.     str = str * rast * rast;
  9169.     sti = -sti * rast * rast;
  9170.     s1r = zet1dr - str;
  9171.     s1i = zet1di - sti;
  9172.     goto L100;
  9173. L90:
  9174.     s1r = zet1dr - zet2dr;
  9175.     s1i = zet1di - zet2di;
  9176. L100:
  9177.     rs1 = s1r;
  9178.     if (abs(rs1) > *elim) {
  9179.         goto L105;
  9180.     }
  9181.     if (abs(rs1) < *alim) {
  9182.         goto L120;
  9183.     }
  9184. /*-----------------------------------------------------------------------
  9185. -----*/
  9186. /*     REFINE ESTIMATE AND TEST */
  9187. /*-----------------------------------------------------------------------
  9188. --*/
  9189.     aphi = z1abs_(&phidr, &phidi);
  9190.     rs1 += log(aphi);
  9191.     if (abs(rs1) < *elim) {
  9192.         goto L120;
  9193.     }
  9194. L105:
  9195.     if (rs1 > 0.) {
  9196.         goto L320;
  9197.     }
  9198. /* -----------------------------------------------------------------------
  9199.  */
  9200. /*     FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW */
  9201. /* -----------------------------------------------------------------------
  9202.  */
  9203.     if (*zr < 0.) {
  9204.         goto L320;
  9205.     }
  9206.     *nz = *n;
  9207.     i__1 = *n;
  9208.     for (i = 1; i <= i__1; ++i) {
  9209.         yr[i] = zeror;
  9210.         yi[i] = zeroi;
  9211. /* L106: */
  9212.     }
  9213.     return 0;
  9214. L120:
  9215.     s1r = cyr[0];
  9216.     s1i = cyi[0];
  9217.     s2r = cyr[1];
  9218.     s2i = cyi[1];
  9219.     c1r = csrr[kflag - 1];
  9220.     ascle = bry[kflag - 1];
  9221.     i__1 = *n;
  9222.     for (i = ib; i <= i__1; ++i) {
  9223.         c2r = s2r;
  9224.         c2i = s2i;
  9225.         s2r = ckr * c2r - cki * c2i + s1r;
  9226.         s2i = ckr * c2i + cki * c2r + s1i;
  9227.         s1r = c2r;
  9228.         s1i = c2i;
  9229.         ckr += rzr;
  9230.         cki += rzi;
  9231.         c2r = s2r * c1r;
  9232.         c2i = s2i * c1r;
  9233.         yr[i] = c2r;
  9234.         yi[i] = c2i;
  9235.         if (kflag >= 3) {
  9236.             goto L130;
  9237.         }
  9238.         str = abs(c2r);
  9239.         sti = abs(c2i);
  9240.         c2m = max(str,sti);
  9241.         if (c2m <= ascle) {
  9242.             goto L130;
  9243.         }
  9244.         ++kflag;
  9245.         ascle = bry[kflag - 1];
  9246.         s1r *= c1r;
  9247.         s1i *= c1r;
  9248.         s2r = c2r;
  9249.         s2i = c2i;
  9250.         s1r *= cssr[kflag - 1];
  9251.         s1i *= cssr[kflag - 1];
  9252.         s2r *= cssr[kflag - 1];
  9253.         s2i *= cssr[kflag - 1];
  9254.         c1r = csrr[kflag - 1];
  9255. L130:
  9256.         ;
  9257.     }
  9258. L180:
  9259.     if (*mr == 0) {
  9260.         return 0;
  9261.     }
  9262. /* -----------------------------------------------------------------------
  9263.  */
  9264. /*     ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0 */
  9265. /* -----------------------------------------------------------------------
  9266.  */
  9267.     *nz = 0;
  9268.     fmr = (doublereal) ((real) (*mr));
  9269.     sgn = -d_sign(&pi, &fmr);
  9270. /* -----------------------------------------------------------------------
  9271.  */
  9272. /*     CSPN AND CSGN ARE COEFF OF K AND I FUNCIONS RESP. */
  9273. /* -----------------------------------------------------------------------
  9274.  */
  9275.     csgni = sgn;
  9276.     if (yy <= 0.) {
  9277.         csgni = -csgni;
  9278.     }
  9279.     ifn = inu + *n - 1;
  9280.     ang = fnf * sgn;
  9281.     cspnr = cos(ang);
  9282.     cspni = sin(ang);
  9283.     if (ifn % 2 == 0) {
  9284.         goto L190;
  9285.     }
  9286.     cspnr = -cspnr;
  9287.     cspni = -cspni;
  9288. L190:
  9289. /* -----------------------------------------------------------------------
  9290.  */
  9291. /*     CS=COEFF OF THE J FUNCTION TO GET THE I FUNCTION. I(FNU,Z) IS */
  9292. /*     COMPUTED FROM EXP(I*FNU*HPI)*J(FNU,-I*Z) WHERE Z IS IN THE FIRST */
  9293.  
  9294. /*     QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY */
  9295. /*     CONJUGATION SINCE THE I FUNCTION IS REAL ON THE POSITIVE REAL AXIS 
  9296. */
  9297. /* -----------------------------------------------------------------------
  9298.  */
  9299.     csr = sar * csgni;
  9300.     csi = car * csgni;
  9301.     in = ifn % 4 + 1;
  9302.     c2r = cipr[in - 1];
  9303.     c2i = cipi[in - 1];
  9304.     str = csr * c2r + csi * c2i;
  9305.     csi = -csr * c2i + csi * c2r;
  9306.     csr = str;
  9307.     asc = bry[0];
  9308.     iuf = 0;
  9309.     kk = *n;
  9310.     kdflg = 1;
  9311.     --ib;
  9312.     ic = ib - 1;
  9313.     i__1 = *n;
  9314.     for (k = 1; k <= i__1; ++k) {
  9315.         fn = *fnu + (doublereal) ((real) (kk - 1));
  9316. /* ------------------------------------------------------------------
  9317. ----- */
  9318. /*     LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K */
  9319. /*     FUNCTION ABOVE */
  9320. /* ------------------------------------------------------------------
  9321. ----- */
  9322.         if (*n > 2) {
  9323.             goto L175;
  9324.         }
  9325. L172:
  9326.         phidr = phir[j - 1];
  9327.         phidi = phii[j - 1];
  9328.         argdr = argr[j - 1];
  9329.         argdi = argi[j - 1];
  9330.         zet1dr = zeta1r[j - 1];
  9331.         zet1di = zeta1i[j - 1];
  9332.         zet2dr = zeta2r[j - 1];
  9333.         zet2di = zeta2i[j - 1];
  9334.         asumdr = asumr[j - 1];
  9335.         asumdi = asumi[j - 1];
  9336.         bsumdr = bsumr[j - 1];
  9337.         bsumdi = bsumi[j - 1];
  9338.         j = 3 - j;
  9339.         goto L210;
  9340. L175:
  9341.         if (kk == *n && ib < *n) {
  9342.             goto L210;
  9343.         }
  9344.         if (kk == ib || kk == ic) {
  9345.             goto L172;
  9346.         }
  9347.         zunhj_(&znr, &zni, &fn, &c__0, tol, &phidr, &phidi, &argdr, &argdi, &
  9348.                 zet1dr, &zet1di, &zet2dr, &zet2di, &asumdr, &asumdi, &bsumdr, 
  9349.                 &bsumdi);
  9350. L210:
  9351.         if (*kode == 1) {
  9352.             goto L220;
  9353.         }
  9354.         str = zbr + zet2dr;
  9355.         sti = zbi + zet2di;
  9356.         rast = fn / z1abs_(&str, &sti);
  9357.         str = str * rast * rast;
  9358.         sti = -sti * rast * rast;
  9359.         s1r = -zet1dr + str;
  9360.         s1i = -zet1di + sti;
  9361.         goto L230;
  9362. L220:
  9363.         s1r = -zet1dr + zet2dr;
  9364.         s1i = -zet1di + zet2di;
  9365. L230:
  9366. /* ------------------------------------------------------------------
  9367. ----- */
  9368. /*     TEST FOR UNDERFLOW AND OVERFLOW */
  9369. /* ------------------------------------------------------------------
  9370. ----- */
  9371.         rs1 = s1r;
  9372.         if (abs(rs1) > *elim) {
  9373.             goto L280;
  9374.         }
  9375.         if (kdflg == 1) {
  9376.             iflag = 2;
  9377.         }
  9378.         if (abs(rs1) < *alim) {
  9379.             goto L240;
  9380.         }
  9381. /* ------------------------------------------------------------------
  9382. ----- */
  9383. /*     REFINE  TEST AND SCALE */
  9384. /* ------------------------------------------------------------------
  9385. ----- */
  9386.         aphi = z1abs_(&phidr, &phidi);
  9387.         aarg = z1abs_(&argdr, &argdi);
  9388.         rs1 = rs1 + log(aphi) - log(aarg) * .25 - aic;
  9389.         if (abs(rs1) > *elim) {
  9390.             goto L280;
  9391.         }
  9392.         if (kdflg == 1) {
  9393.             iflag = 1;
  9394.         }
  9395.         if (rs1 < 0.) {
  9396.             goto L240;
  9397.         }
  9398.         if (kdflg == 1) {
  9399.             iflag = 3;
  9400.         }
  9401. L240:
  9402.         zairy_(&argdr, &argdi, &c__0, &c__2, &air, &aii, &nai, &idum);
  9403.         zairy_(&argdr, &argdi, &c__1, &c__2, &dair, &daii, &ndai, &idum);
  9404.         str = dair * bsumdr - daii * bsumdi;
  9405.         sti = dair * bsumdi + daii * bsumdr;
  9406.         str += air * asumdr - aii * asumdi;
  9407.         sti += air * asumdi + aii * asumdr;
  9408.         ptr = str * phidr - sti * phidi;
  9409.         pti = str * phidi + sti * phidr;
  9410.         s2r = ptr * csr - pti * csi;
  9411.         s2i = ptr * csi + pti * csr;
  9412.         str = exp(s1r) * cssr[iflag - 1];
  9413.         s1r = str * cos(s1i);
  9414.         s1i = str * sin(s1i);
  9415.         str = s2r * s1r - s2i * s1i;
  9416.         s2i = s2r * s1i + s2i * s1r;
  9417.         s2r = str;
  9418.         if (iflag != 1) {
  9419.             goto L250;
  9420.         }
  9421.         zuchk_(&s2r, &s2i, &nw, bry, tol);
  9422.         if (nw == 0) {
  9423.             goto L250;
  9424.         }
  9425.         s2r = zeror;
  9426.         s2i = zeroi;
  9427. L250:
  9428.         if (yy <= 0.) {
  9429.             s2i = -s2i;
  9430.         }
  9431.         cyr[kdflg - 1] = s2r;
  9432.         cyi[kdflg - 1] = s2i;
  9433.         c2r = s2r;
  9434.         c2i = s2i;
  9435.         s2r *= csrr[iflag - 1];
  9436.         s2i *= csrr[iflag - 1];
  9437. /* ------------------------------------------------------------------
  9438. ----- */
  9439. /*     ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N */
  9440. /* ------------------------------------------------------------------
  9441. ----- */
  9442.         s1r = yr[kk];
  9443.         s1i = yi[kk];
  9444.         if (*kode == 1) {
  9445.             goto L270;
  9446.         }
  9447.         zs1s2_(&zrr, &zri, &s1r, &s1i, &s2r, &s2i, &nw, &asc, alim, &iuf);
  9448.         *nz += nw;
  9449. L270:
  9450.         yr[kk] = s1r * cspnr - s1i * cspni + s2r;
  9451.         yi[kk] = s1r * cspni + s1i * cspnr + s2i;
  9452.         --kk;
  9453.         cspnr = -cspnr;
  9454.         cspni = -cspni;
  9455.         str = csi;
  9456.         csi = -csr;
  9457.         csr = str;
  9458.         if (c2r != 0. || c2i != 0.) {
  9459.             goto L255;
  9460.         }
  9461.         kdflg = 1;
  9462.         goto L290;
  9463. L255:
  9464.         if (kdflg == 2) {
  9465.             goto L295;
  9466.         }
  9467.         kdflg = 2;
  9468.         goto L290;
  9469. L280:
  9470.         if (rs1 > 0.) {
  9471.             goto L320;
  9472.         }
  9473.         s2r = zeror;
  9474.         s2i = zeroi;
  9475.         goto L250;
  9476. L290:
  9477.         ;
  9478.     }
  9479.     k = *n;
  9480. L295:
  9481.     il = *n - k;
  9482.     if (il == 0) {
  9483.         return 0;
  9484.     }
  9485. /* -----------------------------------------------------------------------
  9486.  */
  9487. /*     RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE */
  9488. /*     K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP */
  9489. /*     INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. */
  9490. /* -----------------------------------------------------------------------
  9491.  */
  9492.     s1r = cyr[0];
  9493.     s1i = cyi[0];
  9494.     s2r = cyr[1];
  9495.     s2i = cyi[1];
  9496.     csr = csrr[iflag - 1];
  9497.     ascle = bry[iflag - 1];
  9498.     fn = (doublereal) ((real) (inu + il));
  9499.     i__1 = il;
  9500.     for (i = 1; i <= i__1; ++i) {
  9501.         c2r = s2r;
  9502.         c2i = s2i;
  9503.         s2r = s1r + (fn + fnf) * (rzr * c2r - rzi * c2i);
  9504.         s2i = s1i + (fn + fnf) * (rzr * c2i + rzi * c2r);
  9505.         s1r = c2r;
  9506.         s1i = c2i;
  9507.         fn += -1.;
  9508.         c2r = s2r * csr;
  9509.         c2i = s2i * csr;
  9510.         ckr = c2r;
  9511.         cki = c2i;
  9512.         c1r = yr[kk];
  9513.         c1i = yi[kk];
  9514.         if (*kode == 1) {
  9515.             goto L300;
  9516.         }
  9517.         zs1s2_(&zrr, &zri, &c1r, &c1i, &c2r, &c2i, &nw, &asc, alim, &iuf);
  9518.         *nz += nw;
  9519. L300:
  9520.         yr[kk] = c1r * cspnr - c1i * cspni + c2r;
  9521.         yi[kk] = c1r * cspni + c1i * cspnr + c2i;
  9522.         --kk;
  9523.         cspnr = -cspnr;
  9524.         cspni = -cspni;
  9525.         if (iflag >= 3) {
  9526.             goto L310;
  9527.         }
  9528.         c2r = abs(ckr);
  9529.         c2i = abs(cki);
  9530.         c2m = max(c2r,c2i);
  9531.         if (c2m <= ascle) {
  9532.             goto L310;
  9533.         }
  9534.         ++iflag;
  9535.         ascle = bry[iflag - 1];
  9536.         s1r *= csr;
  9537.         s1i *= csr;
  9538.         s2r = ckr;
  9539.         s2i = cki;
  9540.         s1r *= cssr[iflag - 1];
  9541.         s1i *= cssr[iflag - 1];
  9542.         s2r *= cssr[iflag - 1];
  9543.         s2i *= cssr[iflag - 1];
  9544.         csr = csrr[iflag - 1];
  9545. L310:
  9546.         ;
  9547.     }
  9548.     return 0;
  9549. L320:
  9550.     *nz = -1;
  9551.     return 0;
  9552. } /* zunk2_ */
  9553.  
  9554. /* Subroutine */ int zuoik_(doublereal *zr, doublereal *zi, doublereal *fnu, 
  9555.         integer *kode, integer *ikflg, integer *n, doublereal *yr, doublereal 
  9556.         *yi, integer *nuf, doublereal *tol, doublereal *elim, doublereal *
  9557.         alim)
  9558. {
  9559.     /* Initialized data */
  9560.  
  9561.     static doublereal zeror = 0.;
  9562.     static doublereal zeroi = 0.;
  9563.     static doublereal aic = 1.265512123484645396;
  9564.  
  9565.     /* System generated locals */
  9566.     integer i__1;
  9567.  
  9568.     /* Builtin functions */
  9569.     double log(doublereal), exp(doublereal), cos(doublereal), sin(doublereal);
  9570.  
  9571.  
  9572.     /* Local variables */
  9573.     static doublereal aarg, aphi, argi, phii, argr;
  9574.     static integer idum;
  9575.     static doublereal phir;
  9576.     static integer init;
  9577.     extern /* Subroutine */ int zlog_(doublereal *, doublereal *, doublereal *
  9578.             , doublereal *, integer *);
  9579.     static doublereal sumi, sumr;
  9580.     extern doublereal z1abs_(doublereal *, doublereal *);
  9581.     static integer i;
  9582.     static doublereal ascle;
  9583.     static integer iform;
  9584.     static doublereal asumi, bsumi, cwrki[16];
  9585.     extern /* Subroutine */ int zuchk_(doublereal *, doublereal *, integer *, 
  9586.             doublereal *, doublereal *);
  9587.     static doublereal asumr, bsumr, cwrkr[16];
  9588.     extern doublereal d1mach_(integer *);
  9589.     extern /* Subroutine */ int zunhj_(doublereal *, doublereal *, doublereal 
  9590.             *, integer *, doublereal *, doublereal *, doublereal *, 
  9591.             doublereal *, doublereal *, doublereal *, doublereal *, 
  9592.             doublereal *, doublereal *, doublereal *, doublereal *, 
  9593.             doublereal *, doublereal *), zunik_(doublereal *, doublereal *, 
  9594.             doublereal *, integer *, integer *, doublereal *, integer *, 
  9595.             doublereal *, doublereal *, doublereal *, doublereal *, 
  9596.             doublereal *, doublereal *, doublereal *, doublereal *, 
  9597.             doublereal *, doublereal *);
  9598.     static doublereal zeta1i, zeta2i, zeta1r, zeta2r, ax, ay;
  9599.     static integer nn, nw;
  9600.     static doublereal fnn, gnn, zbi, czi, gnu, zbr, czr, rcz, sti, zni, zri, 
  9601.             str, znr, zrr;
  9602.  
  9603. /* ***BEGIN PROLOGUE  ZUOIK */
  9604. /* ***REFER TO  ZBESI,ZBESK,ZBESH */
  9605.  
  9606. /*     ZUOIK COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC */
  9607. /*     EXPANSIONS FOR THE I AND K FUNCTIONS AND COMPARES THEM */
  9608. /*     (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW */
  9609. /*     WHERE ALIM.LT.ELIM. IF THE MAGNITUDE, BASED ON THE LEADING */
  9610. /*     EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN */
  9611. /*     THE RESULT IS ON SCALE. IF NOT, THEN A REFINED TEST USING OTHER */
  9612. /*     MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE */
  9613. /*     EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)= */
  9614. /*     EXP(-ELIM)/TOL */
  9615.  
  9616. /*     IKFLG=1 MEANS THE I SEQUENCE IS TESTED */
  9617. /*          =2 MEANS THE K SEQUENCE IS TESTED */
  9618. /*     NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE */
  9619. /*         =-1 MEANS AN OVERFLOW WOULD OCCUR */
  9620. /*     IKFLG=1 AND NUF.GT.0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO 
  9621. */
  9622. /*             THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE */
  9623. /*     IKFLG=2 AND NUF.EQ.N MEANS ALL Y VALUES WERE SET TO ZERO */
  9624. /*     IKFLG=2 AND 0.LT.NUF.LT.N NOT CONSIDERED. Y MUST BE SET BY */
  9625. /*             ANOTHER ROUTINE */
  9626.  
  9627. /* ***ROUTINES CALLED  ZUCHK,ZUNHJ,ZUNIK,D1MACH,Z1ABS,ZLOG */
  9628. /* ***END PROLOGUE  ZUOIK */
  9629. /*     COMPLEX ARG,ASUM,BSUM,CWRK,CZ,CZERO,PHI,SUM,Y,Z,ZB,ZETA1,ZETA2,ZN, 
  9630. */
  9631. /*    *ZR */
  9632.     /* Parameter adjustments */
  9633.     --yi;
  9634.     --yr;
  9635.  
  9636.     /* Function Body */
  9637.     *nuf = 0;
  9638.     nn = *n;
  9639.     zrr = *zr;
  9640.     zri = *zi;
  9641.     if (*zr >= 0.) {
  9642.         goto L10;
  9643.     }
  9644.     zrr = -(*zr);
  9645.     zri = -(*zi);
  9646. L10:
  9647.     zbr = zrr;
  9648.     zbi = zri;
  9649.     ax = abs(*zr) * 1.7321;
  9650.     ay = abs(*zi);
  9651.     iform = 1;
  9652.     if (ay > ax) {
  9653.         iform = 2;
  9654.     }
  9655.     gnu = max(*fnu,1.);
  9656.     if (*ikflg == 1) {
  9657.         goto L20;
  9658.     }
  9659.     fnn = (doublereal) ((real) nn);
  9660.     gnn = *fnu + fnn - 1.;
  9661.     gnu = max(gnn,fnn);
  9662. L20:
  9663. /* -----------------------------------------------------------------------
  9664.  */
  9665. /*     ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE */
  9666. /*     REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET */
  9667. /*     THE SIGN OF THE IMAGINARY PART CORRECT. */
  9668. /* -----------------------------------------------------------------------
  9669.  */
  9670.     if (iform == 2) {
  9671.         goto L30;
  9672.     }
  9673.     init = 0;
  9674.     zunik_(&zrr, &zri, &gnu, ikflg, &c__1, tol, &init, &phir, &phii, &zeta1r, 
  9675.             &zeta1i, &zeta2r, &zeta2i, &sumr, &sumi, cwrkr, cwrki);
  9676.     czr = -zeta1r + zeta2r;
  9677.     czi = -zeta1i + zeta2i;
  9678.     goto L50;
  9679. L30:
  9680.     znr = zri;
  9681.     zni = -zrr;
  9682.     if (*zi > 0.) {
  9683.         goto L40;
  9684.     }
  9685.     znr = -znr;
  9686. L40:
  9687.     zunhj_(&znr, &zni, &gnu, &c__1, tol, &phir, &phii, &argr, &argi, &zeta1r, 
  9688.             &zeta1i, &zeta2r, &zeta2i, &asumr, &asumi, &bsumr, &bsumi);
  9689.     czr = -zeta1r + zeta2r;
  9690.     czi = -zeta1i + zeta2i;
  9691.     aarg = z1abs_(&argr, &argi);
  9692. L50:
  9693.     if (*kode == 1) {
  9694.         goto L60;
  9695.     }
  9696.     czr -= zbr;
  9697.     czi -= zbi;
  9698. L60:
  9699.     if (*ikflg == 1) {
  9700.         goto L70;
  9701.     }
  9702.     czr = -czr;
  9703.     czi = -czi;
  9704. L70:
  9705.     aphi = z1abs_(&phir, &phii);
  9706.     rcz = czr;
  9707. /* -----------------------------------------------------------------------
  9708.  */
  9709. /*     OVERFLOW TEST */
  9710. /* -----------------------------------------------------------------------
  9711.  */
  9712.     if (rcz > *elim) {
  9713.         goto L210;
  9714.     }
  9715.     if (rcz < *alim) {
  9716.         goto L80;
  9717.     }
  9718.     rcz += log(aphi);
  9719.     if (iform == 2) {
  9720.         rcz = rcz - log(aarg) * .25 - aic;
  9721.     }
  9722.     if (rcz > *elim) {
  9723.         goto L210;
  9724.     }
  9725.     goto L130;
  9726. L80:
  9727. /* -----------------------------------------------------------------------
  9728.  */
  9729. /*     UNDERFLOW TEST */
  9730. /* -----------------------------------------------------------------------
  9731.  */
  9732.     if (rcz < -(*elim)) {
  9733.         goto L90;
  9734.     }
  9735.     if (rcz > -(*alim)) {
  9736.         goto L130;
  9737.     }
  9738.     rcz += log(aphi);
  9739.     if (iform == 2) {
  9740.         rcz = rcz - log(aarg) * .25 - aic;
  9741.     }
  9742.     if (rcz > -(*elim)) {
  9743.         goto L110;
  9744.     }
  9745. L90:
  9746.     i__1 = nn;
  9747.     for (i = 1; i <= i__1; ++i) {
  9748.         yr[i] = zeror;
  9749.         yi[i] = zeroi;
  9750. /* L100: */
  9751.     }
  9752.     *nuf = nn;
  9753.     return 0;
  9754. L110:
  9755.     ascle = d1mach_(&c__1) * 1e3 / *tol;
  9756.     zlog_(&phir, &phii, &str, &sti, &idum);
  9757.     czr += str;
  9758.     czi += sti;
  9759.     if (iform == 1) {
  9760.         goto L120;
  9761.     }
  9762.     zlog_(&argr, &argi, &str, &sti, &idum);
  9763.     czr = czr - str * .25 - aic;
  9764.     czi -= sti * .25;
  9765. L120:
  9766.     ax = exp(rcz) / *tol;
  9767.     ay = czi;
  9768.     czr = ax * cos(ay);
  9769.     czi = ax * sin(ay);
  9770.     zuchk_(&czr, &czi, &nw, &ascle, tol);
  9771.     if (nw != 0) {
  9772.         goto L90;
  9773.     }
  9774. L130:
  9775.     if (*ikflg == 2) {
  9776.         return 0;
  9777.     }
  9778.     if (*n == 1) {
  9779.         return 0;
  9780.     }
  9781. /* -----------------------------------------------------------------------
  9782.  */
  9783. /*     SET UNDERFLOWS ON I SEQUENCE */
  9784. /* -----------------------------------------------------------------------
  9785.  */
  9786. L140:
  9787.     gnu = *fnu + (doublereal) ((real) (nn - 1));
  9788.     if (iform == 2) {
  9789.         goto L150;
  9790.     }
  9791.     init = 0;
  9792.     zunik_(&zrr, &zri, &gnu, ikflg, &c__1, tol, &init, &phir, &phii, &zeta1r, 
  9793.             &zeta1i, &zeta2r, &zeta2i, &sumr, &sumi, cwrkr, cwrki);
  9794.     czr = -zeta1r + zeta2r;
  9795.     czi = -zeta1i + zeta2i;
  9796.     goto L160;
  9797. L150:
  9798.     zunhj_(&znr, &zni, &gnu, &c__1, tol, &phir, &phii, &argr, &argi, &zeta1r, 
  9799.             &zeta1i, &zeta2r, &zeta2i, &asumr, &asumi, &bsumr, &bsumi);
  9800.     czr = -zeta1r + zeta2r;
  9801.     czi = -zeta1i + zeta2i;
  9802.     aarg = z1abs_(&argr, &argi);
  9803. L160:
  9804.     if (*kode == 1) {
  9805.         goto L170;
  9806.     }
  9807.     czr -= zbr;
  9808.     czi -= zbi;
  9809. L170:
  9810.     aphi = z1abs_(&phir, &phii);
  9811.     rcz = czr;
  9812.     if (rcz < -(*elim)) {
  9813.         goto L180;
  9814.     }
  9815.     if (rcz > -(*alim)) {
  9816.         return 0;
  9817.     }
  9818.     rcz += log(aphi);
  9819.     if (iform == 2) {
  9820.         rcz = rcz - log(aarg) * .25 - aic;
  9821.     }
  9822.     if (rcz > -(*elim)) {
  9823.         goto L190;
  9824.     }
  9825. L180:
  9826.     yr[nn] = zeror;
  9827.     yi[nn] = zeroi;
  9828.     --nn;
  9829.     ++(*nuf);
  9830.     if (nn == 0) {
  9831.         return 0;
  9832.     }
  9833.     goto L140;
  9834. L190:
  9835.     ascle = d1mach_(&c__1) * 1e3 / *tol;
  9836.     zlog_(&phir, &phii, &str, &sti, &idum);
  9837.     czr += str;
  9838.     czi += sti;
  9839.     if (iform == 1) {
  9840.         goto L200;
  9841.     }
  9842.     zlog_(&argr, &argi, &str, &sti, &idum);
  9843.     czr = czr - str * .25 - aic;
  9844.     czi -= sti * .25;
  9845. L200:
  9846.     ax = exp(rcz) / *tol;
  9847.     ay = czi;
  9848.     czr = ax * cos(ay);
  9849.     czi = ax * sin(ay);
  9850.     zuchk_(&czr, &czi, &nw, &ascle, tol);
  9851.     if (nw != 0) {
  9852.         goto L180;
  9853.     }
  9854.     return 0;
  9855. L210:
  9856.     *nuf = -1;
  9857.     return 0;
  9858. } /* zuoik_ */
  9859.  
  9860. /* Subroutine */ int zwrsk_(doublereal *zrr, doublereal *zri, doublereal *fnu,
  9861.          integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *
  9862.         nz, doublereal *cwr, doublereal *cwi, doublereal *tol, doublereal *
  9863.         elim, doublereal *alim)
  9864. {
  9865.     /* System generated locals */
  9866.     integer i__1;
  9867.  
  9868.     /* Builtin functions */
  9869.     double cos(doublereal), sin(doublereal);
  9870.  
  9871.     /* Local variables */
  9872.     static doublereal ract;
  9873.     extern doublereal z1abs_(doublereal *, doublereal *);
  9874.     static integer i;
  9875.     static doublereal ascle, csclr, cinui, cinur;
  9876.     extern /* Subroutine */ int zbknu_(doublereal *, doublereal *, doublereal 
  9877.             *, integer *, integer *, doublereal *, doublereal *, integer *, 
  9878.             doublereal *, doublereal *, doublereal *), zrati_(doublereal *, 
  9879.             doublereal *, doublereal *, integer *, doublereal *, doublereal *,
  9880.              doublereal *);
  9881.     extern doublereal d1mach_(integer *);
  9882.     static integer nw;
  9883.     static doublereal c1i, c2i, c1r, c2r, act, acw, cti, ctr, pti, sti, ptr, 
  9884.             str;
  9885.  
  9886. /* ***BEGIN PROLOGUE  ZWRSK */
  9887. /* ***REFER TO  ZBESI,ZBESK */
  9888.  
  9889. /*     ZWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY */
  9890. /*     NORMALIZING THE I FUNCTION RATIOS FROM ZRATI BY THE WRONSKIAN */
  9891.  
  9892. /* ***ROUTINES CALLED  D1MACH,ZBKNU,ZRATI,Z1ABS */
  9893. /* ***END PROLOGUE  ZWRSK */
  9894. /*     COMPLEX CINU,CSCL,CT,CW,C1,C2,RCT,ST,Y,ZR */
  9895. /* -----------------------------------------------------------------------
  9896.  */
  9897. /*     I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS */
  9898. /*     Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM CRATI NORMALIZED BY THE */
  9899. /*     WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM CBKNU. */
  9900. /* -----------------------------------------------------------------------
  9901.  */
  9902.     /* Parameter adjustments */
  9903.     --cwi;
  9904.     --cwr;
  9905.     --yi;
  9906.     --yr;
  9907.  
  9908.     /* Function Body */
  9909.     *nz = 0;
  9910.     zbknu_(zrr, zri, fnu, kode, &c__2, &cwr[1], &cwi[1], &nw, tol, elim, alim)
  9911.             ;
  9912.     if (nw != 0) {
  9913.         goto L50;
  9914.     }
  9915.     zrati_(zrr, zri, fnu, n, &yr[1], &yi[1], tol);
  9916. /* -----------------------------------------------------------------------
  9917.  */
  9918. /*     RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z), */
  9919. /*     R(FNU+J-1,Z)=Y(J),  J=1,...,N */
  9920. /* -----------------------------------------------------------------------
  9921.  */
  9922.     cinur = 1.;
  9923.     cinui = 0.;
  9924.     if (*kode == 1) {
  9925.         goto L10;
  9926.     }
  9927.     cinur = cos(*zri);
  9928.     cinui = sin(*zri);
  9929. L10:
  9930. /* -----------------------------------------------------------------------
  9931.  */
  9932. /*     ON LOW EXPONENT MACHINES THE K FUNCTIONS CAN BE CLOSE TO BOTH */
  9933. /*     THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE */
  9934. /*     SCALED TO PREVENT OVER OR UNDERFLOW. CUOIK HAS DETERMINED THAT */
  9935. /*     THE RESULT IS ON SCALE. */
  9936. /* -----------------------------------------------------------------------
  9937.  */
  9938.     acw = z1abs_(&cwr[2], &cwi[2]);
  9939.     ascle = d1mach_(&c__1) * 1e3 / *tol;
  9940.     csclr = 1.;
  9941.     if (acw > ascle) {
  9942.         goto L20;
  9943.     }
  9944.     csclr = 1. / *tol;
  9945.     goto L30;
  9946. L20:
  9947.     ascle = 1. / ascle;
  9948.     if (acw < ascle) {
  9949.         goto L30;
  9950.     }
  9951.     csclr = *tol;
  9952. L30:
  9953.     c1r = cwr[1] * csclr;
  9954.     c1i = cwi[1] * csclr;
  9955.     c2r = cwr[2] * csclr;
  9956.     c2i = cwi[2] * csclr;
  9957.     str = yr[1];
  9958.     sti = yi[1];
  9959. /* -----------------------------------------------------------------------
  9960.  */
  9961. /*     CINU=CINU*(CONJG(CT)/CABS(CT))*(1.0D0/CABS(CT) PREVENTS */
  9962. /*     UNDER- OR OVERFLOW PREMATURELY BY SQUARING CABS(CT) */
  9963. /* -----------------------------------------------------------------------
  9964.  */
  9965.     ptr = str * c1r - sti * c1i;
  9966.     pti = str * c1i + sti * c1r;
  9967.     ptr += c2r;
  9968.     pti += c2i;
  9969.     ctr = *zrr * ptr - *zri * pti;
  9970.     cti = *zrr * pti + *zri * ptr;
  9971.     act = z1abs_(&ctr, &cti);
  9972.     ract = 1. / act;
  9973.     ctr *= ract;
  9974.     cti = -cti * ract;
  9975.     ptr = cinur * ract;
  9976.     pti = cinui * ract;
  9977.     cinur = ptr * ctr - pti * cti;
  9978.     cinui = ptr * cti + pti * ctr;
  9979.     yr[1] = cinur * csclr;
  9980.     yi[1] = cinui * csclr;
  9981.     if (*n == 1) {
  9982.         return 0;
  9983.     }
  9984.     i__1 = *n;
  9985.     for (i = 2; i <= i__1; ++i) {
  9986.         ptr = str * cinur - sti * cinui;
  9987.         cinui = str * cinui + sti * cinur;
  9988.         cinur = ptr;
  9989.         str = yr[i];
  9990.         sti = yi[i];
  9991.         yr[i] = cinur * csclr;
  9992.         yi[i] = cinui * csclr;
  9993. /* L40: */
  9994.     }
  9995.     return 0;
  9996. L50:
  9997.     *nz = -1;
  9998.     if (nw == -2) {
  9999.         *nz = -2;
  10000.     }
  10001.     return 0;
  10002. } /* zwrsk_ */
  10003.  
  10004. /* carlson.f -- translated by f2c (version of 16 May 1991  13:06:06).
  10005.    You must link the resulting object file with the libraries:
  10006.     -link <S|C|M|L>f2c.lib   (in that order)
  10007. */
  10008.  
  10009. /* ACM ALGORITHM 577 */
  10010.  
  10011. /* ALGORITHMS FOR INCOMPLETE ELLIPTIC INTEGRALS */
  10012.  
  10013. /* BY B.C. CARLSON AND E.M. NOTIS */
  10014.  
  10015. /* ACM TRANSACTIONS ON MATHEMATICAL SOFTWARE, SEPTEMBER, 1981. */
  10016.  
  10017.  
  10018. /*     THIS FILE CONTAINS FOUR SUBROUTINES FOR COMPUTING INCOMPLETE */
  10019. /*     ELLIPTIC INTEGRALS, FOLLOWED BY SIX DRIVERS FOR TESTING THE */
  10020. /*     SUBROUTINES.  EACH SUBROUTINE AND EACH DRIVER IS PRECEDED BY */
  10021. /*     A COMMENT CARD WITH A LINE OF DOLLAR SIGNS, AND EACH DRIVER IS */
  10022. /*     FOLLOWED BY ITS INPUT DATA IF ANY.  THE FOUR SUBROUTINES HAVE */
  10023. /*     THE NAMES RC, RF, RD, RJ IN THAT ORDER.  THE DRIVERS HAVE NO */
  10024. /*     NAMES BUT BEGIN WITH DESCRIPTIVE COMMENTS.  THE FIRST FOUR */
  10025. /*     DRIVERS TEST RC, RF, RD, RJ IN THAT ORDER.  THE FIFTH DRIVER */
  10026. /*     TESTS RC AGAINST LIBRARY ROUTINES.  THE SIXTH DRIVER TESTS RF */
  10027. /*     AGAINST THE FUNPACK SUBROUTINE DELIKM. */
  10028.  
  10029.  
  10030. /*     $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ */
  10031.  
  10032.  
  10033. /*          ******************************************************** */
  10034.  
  10035. doublereal rc_(doublereal *x, doublereal *y, doublereal *errtol, integer *
  10036.     ierr)
  10037. {
  10038.     /* Initialized data */
  10039.  
  10040.     static doublereal lolim = 1.113e-307;
  10041.     static doublereal uplim = 3.59e307;
  10042.  
  10043.     /* System generated locals */
  10044.     doublereal ret_val;
  10045.  
  10046.     /* Builtin functions */
  10047.     double sqrt(doublereal);
  10048.  
  10049.     /* Local variables */
  10050.     static doublereal lamda, s, c1, c2, sn, mu, xn, yn;
  10051.  
  10052.  
  10053. /*          THIS FUNCTION SUBROUTINE COMPUTES THE ELEMENTARY INTEGRAL */
  10054. /*          RC(X,Y) = INTEGRAL FROM ZERO TO INFINITY OF */
  10055.  
  10056. /*                              -1/2     -1 */
  10057. /*                    (1/2)(T+X)    (T+Y)  DT, */
  10058.  
  10059. /*          WHERE X IS NONNEGATIVE AND Y IS POSITIVE.  THE DUPLICATION */
  10060. /*          THEOREM IS ITERATED UNTIL THE VARIABLES ARE NEARLY EQUAL, */
  10061. /*          AND THE FUNCTION IS THEN EXPANDED IN TAYLOR SERIES TO FIFTH */
  10062.  
  10063. /*          ORDER.  LOGARITHMIC, INVERSE CIRCULAR, AND INVERSE HYPER- */
  10064. /*          BOLIC FUNCTIONS CAN BE EXPRESSED IN TERMS OF RC.  REFERENCE: 
  10065. */
  10066. /*          B. C. CARLSON, COMPUTING ELLIPTIC INTEGRALS BY DUPLICATION, */
  10067.  
  10068. /*          NUMER. MATH. 33 (1979), 1-16.  CODED BY B. C. CARLSON AND */
  10069. /*          ELAINE M. NOTIS, AMES LABORATORY-DOE, IOWA STATE UNIVERSITY, 
  10070. */
  10071. /*          AMES, IOWA 50011.  MARCH 1, 1980. */
  10072.  
  10073. /*          CHECK BY ADDITION THEOREM: RC(X,X+Z) + RC(Y,Y+Z) = RC(0,Z), */
  10074.  
  10075. /*          WHERE X, Y, AND Z ARE POSITIVE AND  X * Y = Z * Z. */
  10076.  
  10077. /*          INTRINSIC FUNCTIONS USED: DABS,DMAX1,DSQRT */
  10078.  
  10079. /*          PRINTR IS THE UNIT NUMBER OF THE PRINTER. */
  10080.  
  10081. /*          LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS. */
  10082. /*          LOLIM IS NOT LESS THAN THE MACHINE MINIMUM MULTIPLIED BY 5. */
  10083.  
  10084. /*          UPLIM IS NOT GREATER THAN THE MACHINE MAXIMUM DIVIDED BY 5. */
  10085.  
  10086.  
  10087. /*          ACCEPTABLE VALUES FOR:   LOLIM      UPLIM */
  10088. /*          IBM 360/370 SERIES   :   3.D-78     1.D+75 */
  10089. /*          CDC 6000/7000 SERIES :   1.D-292    1.D+321 */
  10090. /*          UNIVAC 1100 SERIES   :   1.D-307    1.D+307 */
  10091.  
  10092. /*          WARNING: IF THIS PROGRAM IS CONVERTED TO SINGLE PRECISION, */
  10093. /*          THE VALUES FOR THE UNIVAC 1100 SERIES SHOULD BE CHANGED TO */
  10094. /*          LOLIM = 1.E-37 AND UPLIM = 1.E+37 BECAUSE THE MACHINE */
  10095. /*          EXTREMA CHANGE WITH THE PRECISION. */
  10096.  
  10097.  
  10098. /*          ON INPUT: */
  10099.  
  10100. /*          X AND Y ARE THE VARIABLES IN THE INTEGRAL RC(X,Y). */
  10101.  
  10102. /*          ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE. */
  10103. /*          RELATIVE ERROR DUE TO TRUNCATION IS LESS THAN */
  10104. /*          16 * ERRTOL ** 6 / (1 - 2 * ERRTOL). */
  10105.  
  10106. /*          SAMPLE CHOICES:  ERRTOL   RELATIVE TRUNCATION */
  10107. /*                                    ERROR LESS THAN */
  10108. /*                           1.D-3    2.D-17 */
  10109. /*                           3.D-3    2.D-14 */
  10110. /*                           1.D-2    2.D-11 */
  10111. /*                           3.D-2    2.D-8 */
  10112. /*                           1.D-1    2.D-5 */
  10113.  
  10114. /*          ON OUTPUT: */
  10115.  
  10116. /*          X, Y, AND ERRTOL ARE UNALTERED. */
  10117.  
  10118. /*          IERR IS THE RETURN ERROR CODE: */
  10119. /*               IERR = 0 FOR NORMAL COMPLETION OF THE SUBROUTINE, */
  10120. /*               IERR = 1 FOR ABNORMAL TERMINATION. */
  10121.  
  10122. /*          ******************************************************** */
  10123. /*          WARNING: CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE */
  10124. /*          EXPENSE OF ROBUSTNESS. */
  10125.  
  10126.     if (*x < 0. || *y <= 0.) {
  10127.     goto L100;
  10128.     }
  10129.     if (*x + *y < lolim) {
  10130.     goto L100;
  10131.     }
  10132.     if (max(*x,*y) <= uplim) {
  10133.     goto L112;
  10134.     }
  10135. L100:
  10136.     *ierr = 1;
  10137.     goto L124;
  10138.  
  10139. L112:
  10140.     *ierr = 0;
  10141.     xn = *x;
  10142.     yn = *y;
  10143.  
  10144. L116:
  10145.     mu = (xn + yn + yn) / 3.;
  10146.     sn = (yn + mu) / mu - 2.;
  10147.     if (abs(sn) < *errtol) {
  10148.     goto L120;
  10149.     }
  10150.     lamda = sqrt(xn) * 2. * sqrt(yn) + yn;
  10151.     xn = (xn + lamda) * .25;
  10152.     yn = (yn + lamda) * .25;
  10153.     goto L116;
  10154.  
  10155. L120:
  10156.     c1 = .1428571428571428;
  10157.     c2 = .4090909090909091;
  10158.     s = sn * sn * (sn * (c1 + sn * (sn * c2 + .375)) + .3);
  10159.     ret_val = (s + 1.) / sqrt(mu);
  10160.  
  10161. L124:
  10162.     return ret_val;
  10163. } /* rc_ */
  10164.  
  10165.  
  10166.  
  10167. /*     $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ */
  10168.  
  10169.  
  10170. /*          ******************************************************** */
  10171.  
  10172. doublereal rf_(doublereal *x, doublereal *y, doublereal *z, doublereal *
  10173.     errtol, integer *ierr)
  10174. {
  10175.     /* Initialized data */
  10176.  
  10177.     static doublereal lolim = 1.113e-307;
  10178.     static doublereal uplim = 3.59e307;
  10179.  
  10180.     /* System generated locals */
  10181.     doublereal ret_val, d__1, d__2;
  10182.  
  10183.     /* Builtin functions */
  10184.     double sqrt(doublereal);
  10185.  
  10186.     /* Local variables */
  10187.     static doublereal lamda, s, c1, c2, c3, e2, e3, xndev, yndev, zndev, mu, 
  10188.         xn, yn, zn, epslon, xnroot, ynroot, znroot;
  10189.  
  10190.  
  10191. /*          THIS FUNCTION SUBROUTINE COMPUTES THE INCOMPLETE ELLIPTIC */
  10192. /*          INTEGRAL OF THE FIRST KIND, */
  10193. /*          RF(X,Y,Z) = INTEGRAL FROM ZERO TO INFINITY OF */
  10194.  
  10195. /*                                -1/2     -1/2     -1/2 */
  10196. /*                      (1/2)(T+X)    (T+Y)    (T+Z)    DT, */
  10197.  
  10198. /*          WHERE X, Y, AND Z ARE NONNEGATIVE AND AT MOST ONE OF THEM */
  10199. /*          IS ZERO.  IF ONE OF THEM IS ZERO, THE INTEGRAL IS COMPLETE. */
  10200.  
  10201. /*          THE DUPLICATION THEOREM IS ITERATED UNTIL THE VARIABLES ARE */
  10202.  
  10203. /*          NEARLY EQUAL, AND THE FUNCTION IS THEN EXPANDED IN TAYLOR */
  10204. /*          SERIES TO FIFTH ORDER.  REFERENCE: B. C. CARLSON, COMPUTING */
  10205.  
  10206. /*          ELLIPTIC INTEGRALS BY DUPLICATION, NUMER. MATH. 33 (1979), */
  10207. /*          1-16.  CODED BY B. C. CARLSON AND ELAINE M. NOTIS, AMES */
  10208. /*          LABORATORY-DOE, IOWA STATE UNIVERSITY, AMES, IOWA 50011. */
  10209. /*          MARCH 1, 1980. */
  10210.  
  10211. /*          CHECK BY ADDITION THEOREM: RF(X,X+Z,X+W) + RF(Y,Y+Z,Y+W) */
  10212. /*          = RF(0,Z,W), WHERE X,Y,Z,W ARE POSITIVE AND X * Y = Z * W. */
  10213.  
  10214. /*          INTRINSIC FUNCTIONS USED: DABS,DMAX1,DMIN1,DSQRT */
  10215.  
  10216.  
  10217. /*          LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS. */
  10218. /*          LOLIM IS NOT LESS THAN THE MACHINE MINIMUM MULTIPLIED BY 5. */
  10219.  
  10220. /*          UPLIM IS NOT GREATER THAN THE MACHINE MAXIMUM DIVIDED BY 5. */
  10221.  
  10222.  
  10223. /*          ACCEPTABLE VALUES FOR:   LOLIM      UPLIM */
  10224. /*          IBM 360/370 SERIES   :   3.D-78     1.D+75 */
  10225. /*          CDC 6000/7000 SERIES :   1.D-292    1.D+321 */
  10226. /*          UNIVAC 1100 SERIES   :   1.D-307    1.D+307 */
  10227.  
  10228. /*          WARNING: IF THIS PROGRAM IS CONVERTED TO SINGLE PRECISION, */
  10229. /*          THE VALUES FOR THE UNIVAC 1100 SERIES SHOULD BE CHANGED TO */
  10230. /*          LOLIM = 1.E-37 AND UPLIM = 1.E+37 BECAUSE THE MACHINE */
  10231. /*          EXTREMA CHANGE WITH THE PRECISION. */
  10232.  
  10233.  
  10234. /*          ON INPUT: */
  10235.  
  10236. /*          X, Y, AND Z ARE THE VARIABLES IN THE INTEGRAL RF(X,Y,Z). */
  10237.  
  10238. /*          ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE. */
  10239. /*          RELATIVE ERROR DUE TO TRUNCATION IS LESS THAN */
  10240. /*          ERRTOL ** 6 / (4 * (1 - ERRTOL)). */
  10241.  
  10242. /*          SAMPLE CHOICES:  ERRTOL   RELATIVE TRUNCATION */
  10243. /*                                    ERROR LESS THAN */
  10244. /*                           1.D-3    3.D-19 */
  10245. /*                           3.D-3    2.D-16 */
  10246. /*                           1.D-2    3.D-13 */
  10247. /*                           3.D-2    2.D-10 */
  10248. /*                           1.D-1    3.D-7 */
  10249.  
  10250. /*          ON OUTPUT: */
  10251.  
  10252. /*          X, Y, Z, AND ERRTOL ARE UNALTERED. */
  10253.  
  10254. /*          IERR IS THE RETURN ERROR CODE: */
  10255. /*               IERR = 0 FOR NORMAL COMPLETION OF THE SUBROUTINE, */
  10256. /*               IERR = 1 FOR ABNORMAL TERMINATION. */
  10257.  
  10258. /*          ******************************************************** */
  10259. /*          WARNING: CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE */
  10260. /*          EXPENSE OF ROBUSTNESS. */
  10261.  
  10262. /* Computing MIN */
  10263.     d__1 = min(*x,*y);
  10264.     if (min(d__1,*z) < 0.) {
  10265.     goto L100;
  10266.     }
  10267. /* Computing MIN */
  10268.     d__1 = *x + *y, d__2 = *x + *z, d__1 = min(d__1,d__2), d__2 = *y + *z;
  10269.     if (min(d__1,d__2) < lolim) {
  10270.     goto L100;
  10271.     }
  10272. /* Computing MAX */
  10273.     d__1 = max(*x,*y);
  10274.     if (max(d__1,*z) <= uplim) {
  10275.     goto L112;
  10276.     }
  10277. L100:
  10278.     *ierr = 1;
  10279.     goto L124;
  10280.  
  10281. L112:
  10282.     *ierr = 0;
  10283.     xn = *x;
  10284.     yn = *y;
  10285.     zn = *z;
  10286.  
  10287. L116:
  10288.     mu = (xn + yn + zn) / 3.;
  10289.     xndev = 2. - (mu + xn) / mu;
  10290.     yndev = 2. - (mu + yn) / mu;
  10291.     zndev = 2. - (mu + zn) / mu;
  10292. /* Computing MAX */
  10293.     d__1 = abs(xndev), d__2 = abs(yndev), d__1 = max(d__1,d__2), d__2 = abs(
  10294.         zndev);
  10295.     epslon = max(d__1,d__2);
  10296.     if (epslon < *errtol) {
  10297.     goto L120;
  10298.     }
  10299.     xnroot = sqrt(xn);
  10300.     ynroot = sqrt(yn);
  10301.     znroot = sqrt(zn);
  10302.     lamda = xnroot * (ynroot + znroot) + ynroot * znroot;
  10303.     xn = (xn + lamda) * .25;
  10304.     yn = (yn + lamda) * .25;
  10305.     zn = (zn + lamda) * .25;
  10306.     goto L116;
  10307.  
  10308. L120:
  10309.     c1 = .04166666666666666;
  10310.     c2 = .06818181818181818;
  10311.     c3 = .07142857142857142;
  10312.     e2 = xndev * yndev - zndev * zndev;
  10313.     e3 = xndev * yndev * zndev;
  10314.     s = (c1 * e2 - .1 - c2 * e3) * e2 + 1. + c3 * e3;
  10315.     ret_val = s / sqrt(mu);
  10316.  
  10317. L124:
  10318.     return ret_val;
  10319. } /* rf_ */
  10320.  
  10321.  
  10322.  
  10323. /*     $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ */
  10324.  
  10325.  
  10326. /*          ******************************************************** */
  10327.  
  10328. doublereal rd_(doublereal *x, doublereal *y, doublereal *z, doublereal *
  10329.     errtol, integer *ierr)
  10330. {
  10331.     /* Initialized data */
  10332.  
  10333.     static doublereal lolim = 6.28e-206;
  10334.     static doublereal uplim = 2.72e202;
  10335.  
  10336.     /* System generated locals */
  10337.     doublereal ret_val, d__1, d__2;
  10338.  
  10339.     /* Builtin functions */
  10340.     double sqrt(doublereal);
  10341.  
  10342.     /* Local variables */
  10343.     static doublereal lamda, sigma, c1, c2, c3, c4, xndev, yndev, zndev, s1, 
  10344.         s2, ea, eb, ec, ed, ef, power4, mu, xn, yn, zn, epslon, xnroot, 
  10345.         ynroot, znroot;
  10346.  
  10347.  
  10348. /*          THIS FUNCTION SUBROUTINE COMPUTES AN INCOMPLETE ELLIPTIC */
  10349. /*          INTEGRAL OF THE SECOND KIND, */
  10350. /*          RD(X,Y,Z) = INTEGRAL FROM ZERO TO INFINITY OF */
  10351.  
  10352. /*                                -1/2     -1/2     -3/2 */
  10353. /*                      (3/2)(T+X)    (T+Y)    (T+Z)    DT, */
  10354.  
  10355. /*          WHERE X AND Y ARE NONNEGATIVE, X + Y IS POSITIVE, AND Z IS */
  10356. /*          POSITIVE.  IF X OR Y IS ZERO, THE INTEGRAL IS COMPLETE. */
  10357. /*          THE DUPLICATION THEOREM IS ITERATED UNTIL THE VARIABLES ARE */
  10358.  
  10359. /*          NEARLY EQUAL, AND THE FUNCTION IS THEN EXPANDED IN TAYLOR */
  10360. /*          SERIES TO FIFTH ORDER.  REFERENCE: B. C. CARLSON, COMPUTING */
  10361.  
  10362. /*          ELLIPTIC INTEGRALS BY DUPLICATION, NUMER. MATH. 33 (1979), */
  10363. /*          1-16.  CODED BY B. C. CARLSON AND ELAINE M. NOTIS, AMES */
  10364. /*          LABORATORY-DOE, IOWA STATE UNIVERSITY, AMES, IOWA 50011. */
  10365. /*          MARCH 1, 1980.. */
  10366.  
  10367. /*          CHECK: RD(X,Y,Z) + RD(Y,Z,X) + RD(Z,X,Y) */
  10368. /*          = 3 / DSQRT(X * Y * Z), WHERE X, Y, AND Z ARE POSITIVE. */
  10369.  
  10370. /*          INTRINSIC FUNCTIONS USED: DABS,DMAX1,DMIN1,DSQRT */
  10371.  
  10372. /*          LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS. */
  10373. /*          LOLIM IS NOT LESS THAN 2 / (MACHINE MAXIMUM) ** (2/3). */
  10374. /*          UPLIM IS NOT GREATER THAN (0.1 * ERRTOL / MACHINE */
  10375. /*          MINIMUM) ** (2/3), WHERE ERRTOL IS DESCRIBED BELOW. */
  10376. /*          IN THE FOLLOWING TABLE IT IS ASSUMED THAT ERRTOL WILL */
  10377. /*          NEVER BE CHOSEN SMALLER THAN 1.D-5. */
  10378.  
  10379. /*          ACCEPTABLE VALUES FOR:   LOLIM      UPLIM */
  10380. /*          IBM 360/370 SERIES   :   6.D-51     1.D+48 */
  10381. /*          CDC 6000/7000 SERIES :   5.D-215    2.D+191 */
  10382. /*          UNIVAC 1100 SERIES   :   1.D-205    2.D+201 */
  10383.  
  10384. /*          WARNING: IF THIS PROGRAM IS CONVERTED TO SINGLE PRECISION, */
  10385. /*          THE VALUES FOR THE UNIVAC 1100 SERIES SHOULD BE CHANGED TO */
  10386. /*          LOLIM = 1.E-25 AND UPLIM = 2.E+21 BECAUSE THE MACHINE */
  10387. /*          EXTREMA CHANGE WITH THE PRECISION. */
  10388.  
  10389.  
  10390. /*          ON INPUT: */
  10391.  
  10392. /*          X, Y, AND Z ARE THE VARIABLES IN THE INTEGRAL RD(X,Y,Z). */
  10393.  
  10394. /*          ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE. */
  10395. /*          RELATIVE ERROR DUE TO TRUNCATION IS LESS THAN */
  10396. /*          3 * ERRTOL ** 6 / (1-ERRTOL) ** 3/2. */
  10397.  
  10398. /*          SAMPLE CHOICES:  ERRTOL   RELATIVE TRUNCATION */
  10399. /*                                    ERROR LESS THAN */
  10400. /*                           1.D-3    4.D-18 */
  10401. /*                           3.D-3    3.D-15 */
  10402. /*                           1.D-2    4.D-12 */
  10403. /*                           3.D-2    3.D-9 */
  10404. /*                           1.D-1    4.D-6 */
  10405.  
  10406. /*          ON OUTPUT: */
  10407.  
  10408. /*          X, Y, Z, AND ERRTOL ARE UNALTERED. */
  10409.  
  10410. /*          IERR IS THE RETURN ERROR CODE: */
  10411. /*               IERR = 0 FOR NORMAL COMPLETION OF THE SUBROUTINE, */
  10412. /*               IERR = 1 FOR ABNORMAL TERMINATION. */
  10413.  
  10414. /*          ******************************************************** */
  10415. /*          WARNING: CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE */
  10416. /*          EXPENSE OF ROBUSTNESS. */
  10417.  
  10418.     if (min(*x,*y) < 0.) {
  10419.     goto L100;
  10420.     }
  10421. /* Computing MIN */
  10422.     d__1 = *x + *y;
  10423.     if (min(d__1,*z) < lolim) {
  10424.     goto L100;
  10425.     }
  10426. /* Computing MAX */
  10427.     d__1 = max(*x,*y);
  10428.     if (max(d__1,*z) <= uplim) {
  10429.     goto L112;
  10430.     }
  10431. L100:
  10432.     *ierr = 1;
  10433.     goto L124;
  10434.  
  10435. L112:
  10436.     *ierr = 0;
  10437.     xn = *x;
  10438.     yn = *y;
  10439.     zn = *z;
  10440.     sigma = 0.;
  10441.     power4 = 1.;
  10442.  
  10443. L116:
  10444.     mu = (xn + yn + zn * 3.) * .2;
  10445.     xndev = (mu - xn) / mu;
  10446.     yndev = (mu - yn) / mu;
  10447.     zndev = (mu - zn) / mu;
  10448. /* Computing MAX */
  10449.     d__1 = abs(xndev), d__2 = abs(yndev), d__1 = max(d__1,d__2), d__2 = abs(
  10450.         zndev);
  10451.     epslon = max(d__1,d__2);
  10452.     if (epslon < *errtol) {
  10453.     goto L120;
  10454.     }
  10455.     xnroot = sqrt(xn);
  10456.     ynroot = sqrt(yn);
  10457.     znroot = sqrt(zn);
  10458.     lamda = xnroot * (ynroot + znroot) + ynroot * znroot;
  10459.     sigma += power4 / (znroot * (zn + lamda));
  10460.     power4 *= .25;
  10461.     xn = (xn + lamda) * .25;
  10462.     yn = (yn + lamda) * .25;
  10463.     zn = (zn + lamda) * .25;
  10464.     goto L116;
  10465.  
  10466. L120:
  10467.     c1 = .2142857142857143;
  10468.     c2 = .1666666666666667;
  10469.     c3 = .4090909090909091;
  10470.     c4 = .1153846153846154;
  10471.     ea = xndev * yndev;
  10472.     eb = zndev * zndev;
  10473.     ec = ea - eb;
  10474.     ed = ea - eb * 6.;
  10475.     ef = ed + ec + ec;
  10476.     s1 = ed * (-c1 + c3 * .25 * ed - c4 * 1.5 * zndev * ef);
  10477.     s2 = zndev * (c2 * ef + zndev * (-c3 * ec + zndev * c4 * ea));
  10478.     ret_val = sigma * 3. + power4 * (s1 + 1. + s2) / (mu * sqrt(mu));
  10479.  
  10480. L124:
  10481.     return ret_val;
  10482. } /* rd_ */
  10483.  
  10484.  
  10485.  
  10486. /*     $$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$$ */
  10487.  
  10488.  
  10489. /*          ******************************************************** */
  10490.  
  10491. doublereal rj_(doublereal *x, doublereal *y, doublereal *z, doublereal *p, 
  10492.     doublereal *errtol, integer *ierr)
  10493. {
  10494.     /* Initialized data */
  10495.  
  10496.     static doublereal lolim = 4.81e-103;
  10497.     static doublereal uplim = 9.89e101;
  10498.  
  10499.     /* System generated locals */
  10500.     doublereal ret_val, d__1, d__2;
  10501.  
  10502.     /* Builtin functions */
  10503.     double sqrt(doublereal);
  10504.  
  10505.     /* Local variables */
  10506.     static doublereal alfa, beta, lamda, sigma, pndev, c1, c2, c3, c4, e2, e3,
  10507.          xndev, yndev, zndev, s1, s2, s3, ea, eb, ec, power4;
  10508.     extern doublereal rc_(doublereal *, doublereal *, doublereal *, integer *)
  10509.         ;
  10510.     static doublereal pn, mu, xn, yn, zn, etolrc, epslon, xnroot, ynroot, 
  10511.         znroot;
  10512.  
  10513.  
  10514. /*          THIS FUNCTION SUBROUTINE COMPUTES AN INCOMPLETE ELLIPTIC */
  10515. /*          INTEGRAL OF THE THIRD KIND, */
  10516. /*          RJ(X,Y,Z,P) = INTEGRAL FROM ZERO TO INFINITY OF */
  10517.  
  10518. /*                                  -1/2     -1/2     -1/2     -1 */
  10519. /*                        (3/2)(T+X)    (T+Y)    (T+Z)    (T+P)  DT, */
  10520.  
  10521. /*          WHERE X, Y, AND Z ARE NONNEGATIVE, AT MOST ONE OF THEM IS */
  10522. /*          ZERO, AND P IS POSITIVE.  IF X OR Y OR Z IS ZERO, THE */
  10523. /*          INTEGRAL IS COMPLETE.  THE DUPLICATION THEOREM IS ITERATED */
  10524. /*          UNTIL THE VARIABLES ARE NEARLY EQUAL, AND THE FUNCTION IS */
  10525. /*          THEN EXPANDED IN TAYLOR SERIES TO FIFTH ORDER.  REFERENCE: */
  10526. /*          B. C. CARLSON, COMPUTING ELLIPTIC INTEGRALS BY DUPLICATION, */
  10527.  
  10528. /*          NUMER. MATH. 33 (1979), 1-16.  CODED BY B. C. CARLSON AND */
  10529. /*          ELAINE M. NOTIS, AMES LABORATORY-DOE, IOWA STATE UNIVERSITY, 
  10530. */
  10531. /*          AMES, IOWA 50011.  MARCH 1, 1980. */
  10532.  
  10533. /*          CHECK BY ADDITION THEOREM: RJ(X,X+Z,X+W,X+P) */
  10534. /*          + RJ(Y,Y+Z,Y+W,Y+P) + (A-B) * RJ(A,B,B,A) + 3 / DSQRT(A) */
  10535. /*          = RJ(0,Z,W,P), WHERE X,Y,Z,W,P ARE POSITIVE AND X * Y */
  10536. /*          = Z * W,  A = P * P * (X+Y+Z+W),  B = P * (P+X) * (P+Y), */
  10537. /*          AND B - A = P * (P-Z) * (P-W).  THE SUM OF THE THIRD AND */
  10538. /*          FOURTH TERMS ON THE LEFT SIDE IS 3 * RC(A,B). */
  10539.  
  10540. /*          INTRINSIC FUNCTIONS USED: DABS,DMAX1,DMIN1,DSQRT */
  10541.  
  10542. /*          RC IS A FUNCTION COMPUTED BY AN EXTERNAL SUBROUTINE. */
  10543.  
  10544. /*          LOLIM AND UPLIM DETERMINE THE RANGE OF VALID ARGUMENTS. */
  10545. /*          LOLIM IS NOT LESS THAN THE CUBE ROOT OF THE VALUE */
  10546. /*          OF LOLIM USED IN THE SUBROUTINE FOR RC. */
  10547. /*          UPLIM IS NOT GREATER THAN 0.3 TIMES THE CUBE ROOT OF */
  10548. /*          THE VALUE OF UPLIM USED IN THE SUBROUTINE FOR RC. */
  10549.  
  10550. /*          ACCEPTABLE VALUES FOR:   LOLIM      UPLIM */
  10551. /*          IBM 360/370 SERIES   :   2.D-26     3.D+24 */
  10552. /*          CDC 6000/7000 SERIES :   5.D-98     3.D+106 */
  10553. /*          UNIVAC 1100 SERIES   :   5.D-103    6.D+101 */
  10554.  
  10555. /*          WARNING: IF THIS PROGRAM IS CONVERTED TO SINGLE PRECISION, */
  10556. /*          THE VALUES FOR THE UNIVAC 1100 SERIES SHOULD BE CHANGED TO */
  10557. /*          LOLIM = 5.E-13 AND UPLIM = 6.E+11 BECAUSE THE MACHINE */
  10558. /*          EXTREMA CHANGE WITH THE PRECISION. */
  10559.  
  10560.  
  10561. /*          ON INPUT: */
  10562.  
  10563. /*          X, Y, Z, AND P ARE THE VARIABLES IN THE INTEGRAL RJ(X,Y,Z,P). 
  10564. */
  10565.  
  10566. /*          ERRTOL IS SET TO THE DESIRED ERROR TOLERANCE. */
  10567. /*          RELATIVE ERROR DUE TO TRUNCATION OF THE SERIES FOR RJ */
  10568. /*          IS LESS THAN 3 * ERRTOL ** 6 / (1 - ERRTOL) ** 3/2. */
  10569. /*          AN ERROR TOLERANCE (ETOLRC) WILL BE PASSED TO THE SUBROUTINE 
  10570. */
  10571. /*          FOR RC TO MAKE THE TRUNCATION ERROR FOR RC LESS THAN FOR RJ. 
  10572. */
  10573.  
  10574. /*          SAMPLE CHOICES:  ERRTOL   RELATIVE TRUNCATION */
  10575. /*                                    ERROR LESS THAN */
  10576. /*                           1.D-3    4.D-18 */
  10577. /*                           3.D-3    3.D-15 */
  10578. /*                           1.D-2    4.D-12 */
  10579. /*                           3.D-2    3.D-9 */
  10580. /*                           1.D-1    4.D-6 */
  10581.  
  10582. /*          ON OUTPUT: */
  10583.  
  10584. /*          X, Y, Z, P, AND ERRTOL ARE UNALTERED. */
  10585.  
  10586. /*          IERR IS THE RETURN ERROR CODE: */
  10587. /*               IERR = 0 FOR NORMAL COMPLETION OF THE SUBROUTINE, */
  10588. /*               IERR = 1 FOR ABNORMAL TERMINATION. */
  10589.  
  10590. /*          ******************************************************** */
  10591. /*          WARNING: CHANGES IN THE PROGRAM MAY IMPROVE SPEED AT THE */
  10592. /*          EXPENSE OF ROBUSTNESS. */
  10593.  
  10594. /* Computing MIN */
  10595.     d__1 = min(*x,*y);
  10596.     if (min(d__1,*z) < 0.) {
  10597.     goto L100;
  10598.     }
  10599. /* Computing MIN */
  10600.     d__1 = *x + *y, d__2 = *x + *z, d__1 = min(d__1,d__2), d__2 = *y + *z, 
  10601.         d__1 = min(d__1,d__2);
  10602.     if (min(d__1,*p) < lolim) {
  10603.     goto L100;
  10604.     }
  10605. /* Computing MAX */
  10606.     d__1 = max(*x,*y), d__1 = max(d__1,*z);
  10607.     if (max(d__1,*p) <= uplim) {
  10608.     goto L112;
  10609.     }
  10610. L100:
  10611.     *ierr = 1;
  10612.     goto L124;
  10613.  
  10614. L112:
  10615.     *ierr = 0;
  10616.     xn = *x;
  10617.     yn = *y;
  10618.     zn = *z;
  10619.     pn = *p;
  10620.     sigma = 0.;
  10621.     power4 = 1.;
  10622.     etolrc = *errtol * .5;
  10623.  
  10624. L116:
  10625.     mu = (xn + yn + zn + pn + pn) * .2;
  10626.     xndev = (mu - xn) / mu;
  10627.     yndev = (mu - yn) / mu;
  10628.     zndev = (mu - zn) / mu;
  10629.     pndev = (mu - pn) / mu;
  10630. /* Computing MAX */
  10631.     d__1 = abs(xndev), d__2 = abs(yndev), d__1 = max(d__1,d__2), d__2 = abs(
  10632.         zndev), d__1 = max(d__1,d__2), d__2 = abs(pndev);
  10633.     epslon = max(d__1,d__2);
  10634.     if (epslon < *errtol) {
  10635.     goto L120;
  10636.     }
  10637.     xnroot = sqrt(xn);
  10638.     ynroot = sqrt(yn);
  10639.     znroot = sqrt(zn);
  10640.     lamda = xnroot * (ynroot + znroot) + ynroot * znroot;
  10641.     alfa = pn * (xnroot + ynroot + znroot) + xnroot * ynroot * znroot;
  10642.     alfa *= alfa;
  10643.     beta = pn * (pn + lamda) * (pn + lamda);
  10644.     sigma += power4 * rc_(&alfa, &beta, &etolrc, ierr);
  10645.     if (*ierr != 0) {
  10646.     goto L124;
  10647.     }
  10648.     power4 *= .25;
  10649.     xn = (xn + lamda) * .25;
  10650.     yn = (yn + lamda) * .25;
  10651.     zn = (zn + lamda) * .25;
  10652.     pn = (pn + lamda) * .25;
  10653.     goto L116;
  10654.  
  10655. L120:
  10656.     c1 = .2142857142857143;
  10657.     c2 = .3333333333333333;
  10658.     c3 = .1363636363636364;
  10659.     c4 = .1153846153846154;
  10660.     ea = xndev * (yndev + zndev) + yndev * zndev;
  10661.     eb = xndev * yndev * zndev;
  10662.     ec = pndev * pndev;
  10663.     e2 = ea - ec * 3.;
  10664.     e3 = eb + pndev * 2. * (ea - ec);
  10665.     s1 = e2 * (-c1 + c3 * .75 * e2 - c4 * 1.5 * e3) + 1.;
  10666.     s2 = eb * (c2 * .5 + pndev * (-c3 - c3 + pndev * c4));
  10667.     s3 = pndev * ea * (c2 - pndev * c3) - c2 * pndev * ec;
  10668.     ret_val = sigma * 3. + power4 * (s1 + s2 + s3) / (mu * sqrt(mu));
  10669.  
  10670. L124:
  10671.     return ret_val;
  10672. } /* rj_ */
  10673.  
  10674.