TBCI Numerical high perf. C++ Library  2.8.0
zbesh.c
Go to the documentation of this file.
1 
4 /* zbesh.f -- translated by f2c (version 19980516).
5  You must link the resulting object file with the libraries:
6  -lf2c -lm (in that order)
7 */
8 
9 /* $Id: zbesh.c,v 1.3.2.5 2019/05/28 11:13:02 garloff Exp $ */
10 
11 #include "tbci/specfun/prototypes.h"
12 #include "tbci/specfun/prototypes2.h"
13 
14 /* Table of constant values */
15 
16 static integer c__4 = 4;
17 static integer c__15 = 15;
18 static integer c__16 = 16;
19 static integer c__5 = 5;
20 static integer c__14 = 14;
21 static integer c__9 = 9;
22 static integer c__1 = 1;
23 static integer c__2 = 2;
24 static integer c__25 = 25;
25 static doublereal c_b147 = .5;
26 static doublereal c_b148 = 0.;
27 static integer c__0 = 0;
28 
29 int zuchk_(doublereal *yr, doublereal *yi, integer *nz, doublereal *ascle, doublereal *tol);
30 int zunhj_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *ipmtr, doublereal *tol, doublereal *phir, doublereal *phii, doublereal *argr, doublereal *argi, doublereal *zeta1r, doublereal *zeta1i, doublereal *zeta2r, doublereal *zeta2i, doublereal *asumr, doublereal *asumi, doublereal *bsumr, doublereal *bsumi);
31 int zuoik_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *ikflg, integer *n, doublereal *yr, doublereal *yi, integer *nuf, doublereal *tol, doublereal *elim, doublereal *alim);
32 
33 int zacon_(double*, double*, double*, integer*,
34  integer*, integer*, double*, double*,
35  integer*, double*, double*, double*,
36  double*, double*);
37 int zbknu_(double*, double*, double*, integer*,
38  integer*, double*, double*,
39  integer*, double*, double*, double*);
40 int zbunk_(double*, double*, double*, integer*,
41  integer*, integer*, double*, double*,
42  integer*, double*, double*, double*);
43 int zuoik_(double*, double*, double*, integer*,
44  integer*, integer*, double*, double*,
45  integer*, double*, double*, double*);
46 
47 doublereal d1mach_(const integer*);
48 integer i1mach_(const integer*);
49 doublereal myzabs_(const doublereal*, const doublereal*);
50 
51  static doublereal ascle, csgni, csgnr, cspni, cspnr;
52  extern /* Subroutine */ int zs1s2_(doublereal *zrr, doublereal *zri, doublereal *s1r, doublereal *s1i, doublereal *s2r, doublereal *s2i, integer *nz, doublereal *ascle, doublereal *alim, integer *iuf);
53  extern /* Subroutine */ int zbknu_(double*, double*, double*, integer*,
54  integer*, double*, double*,
55  integer*, double*, double*, double*),
56  zseri_(doublereal *zr, doublereal *zi, doublereal *fnu,
57  integer *kode, integer *n, doublereal *yr, doublereal *yi,
58  integer *nz,
59  doublereal *tol, doublereal *elim, doublereal *alim);
60  extern /* Subroutine */ int
61  zmlri_(doublereal *zr, doublereal *zi, doublereal *fnu,
62  integer *kode, integer *n,
63  doublereal *yr, doublereal *yi, integer *nz, doublereal *tol),
64  zasyi_(doublereal *zr, doublereal *zi, doublereal *fnu,
65  integer *kode, integer *n,
66  doublereal *yr, doublereal *yi, integer *nz,
67  doublereal *rl, doublereal *tol,
68  doublereal *elim, doublereal *alim);
69 
70  extern /* Subroutine */ int zbinu_(doublereal *zr, doublereal *zi,
71  doublereal *fnu, integer *kode,
72  integer *n, doublereal *cyr,
73  doublereal *cyi, integer *nz,
74  doublereal *rl, doublereal *fnul,
75  doublereal *tol, doublereal *elim,
76  doublereal *alim),
77  zbknu_(double*, double*, double*, integer*,
78  integer*, double*, double*,
79  integer*, double*, double*, double*);
80 
81 ;
82  extern /* Subroutine */ int zshch_(doublereal *zr, doublereal *zi, doublereal *cshr, doublereal *cshi, doublereal *cchr, doublereal *cchi);
83  extern int zkscl_(doublereal *zrr, doublereal *zri, doublereal *fnu, integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *rzr, doublereal *rzi, doublereal *ascle, doublereal *tol, doublereal *elim);
84  extern /* Subroutine */ int zsqrt_(const doublereal *ar, const doublereal *ai, doublereal *br, doublereal *bi);
85 
86  extern /* Subroutine */ int zlog_(doublereal *ar, doublereal *ai, doublereal *br, doublereal *bi, integer *ierr);
87  extern /* Subroutine */ int zdiv_(doublereal *ar, doublereal *ai, doublereal *br, doublereal *bi, doublereal *cr, doublereal *ci);
88  extern /* Subroutine */ int zexp_(const doublereal *ar, const doublereal *ai, doublereal *br, doublereal *bi),
89  zmlt_(doublereal *ar, doublereal *ai, doublereal *br, doublereal *bi, doublereal *cr, doublereal *ci);
90  extern doublereal dgamln_(doublereal *z__, integer *ierr);
91 
92  extern /* Subroutine */ int zunhj_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *ipmtr, doublereal *tol, doublereal *phir, doublereal *phii, doublereal *argr, doublereal *argi, doublereal *zeta1r, doublereal *zeta1i, doublereal *zeta2r, doublereal *zeta2i, doublereal *asumr, doublereal *asumi, doublereal *bsumr, doublereal *bsumi);
93 
94  extern /* Subroutine */ int zbuni_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *nz, integer *nui, integer *nlast, doublereal *fnul, doublereal *tol, doublereal *elim, doublereal *alim),
95  zseri_(doublereal *zr, doublereal *zi, doublereal *fnu,
96  integer *kode, integer *n, doublereal *yr, doublereal *yi,
97  integer *nz,
98  doublereal *tol, doublereal *elim, doublereal *alim),
99  zmlri_(doublereal *zr, doublereal *zi, doublereal *fnu,
100  integer *kode, integer *n,
101  doublereal *yr, doublereal *yi, integer *nz, doublereal *tol),
102  zasyi_(doublereal *zr, doublereal *zi, doublereal *fnu,
103  integer *kode, integer *n,
104  doublereal *yr, doublereal *yi, integer *nz,
105  doublereal *rl, doublereal *tol,
106  doublereal *elim, doublereal *alim),
107  zuoik_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *ikflg, integer *n, doublereal *yr, doublereal *yi, integer *nuf, doublereal *tol, doublereal *elim, doublereal *alim),
108  zwrsk_(doublereal *zrr, doublereal *zri, doublereal *fnu, integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *cwr, doublereal *cwi, doublereal *tol, doublereal *elim, doublereal *alim);
109 
110  extern /* Subroutine */ int zuni1_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *nz, integer *nlast, doublereal *fnul, doublereal *tol, doublereal *elim, doublereal *alim), zuni2_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *nz, integer *nlast, doublereal *fnul, doublereal *tol, doublereal *elim, doublereal *alim);
111 
112  extern /* Subroutine */ int xerror_(char* mess, integer* nmess,
113  integer* l1, integer* l2, ftnlen mess_len);
114  extern /* Subroutine */ int zunk1_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *tol, doublereal *elim, doublereal *alim), zunk2_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *tol, doublereal *elim, doublereal *alim);
115 
116 
117  extern /* Subroutine */ int zlog_(doublereal *ar, doublereal *ai, doublereal *br, doublereal *bi, integer *ierr),
118  zdiv_(doublereal *ar, doublereal *ai, doublereal *br, doublereal *bi, doublereal *cr, doublereal *ci),
119  zmlt_(doublereal *ar, doublereal *ai, doublereal *br, doublereal *bi, doublereal *cr, doublereal *ci);
120 
121  extern /* Subroutine */ int zunik_(doublereal *zrr, doublereal *zri, doublereal *fnu, integer *ikflg, integer *ipmtr, doublereal *tol, integer *init, doublereal *phir, doublereal *phii, doublereal *zeta1r, doublereal *zeta1i, doublereal *zeta2r, doublereal *zeta2i, doublereal *sumr, doublereal *sumi, doublereal *cwrkr, doublereal *cwrki), zuoik_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *ikflg, integer *n, doublereal *yr, doublereal *yi, integer *nuf, doublereal *tol, doublereal *elim, doublereal *alim);
122 
123 
124 
125 /* Subroutine */
126 /*
127 int zbesh_(zr, zi, fnu, kode, m, n, cyr, cyi, nz, ierr)
128 doublereal *zr, *zi, *fnu;
129 integer *kode, *m, *n;
130 doublereal *cyr, *cyi;
131 integer *nz, *ierr; */
132 int zbesh_ (doublereal* zr, doublereal* zi, doublereal* fnu,
133  integer* kode, integer* m, integer* n,
134  doublereal* cyr, doublereal* cyi,
135  integer* nz, integer* ierr)
136 {
137  /* Initialized data */
138 
139  static doublereal hpi = 1.57079632679489662;
140 
141  /* System generated locals */
142  integer i__1, i__2;
143  doublereal d__1, d__2;
144 
145  /* Builtin functions */
146 
147  /* Local variables */
148  static doublereal alim, elim, atol, rhpi;
149  static integer inuh;
150  static doublereal fnul, rtol;
151  static integer i__, k;
152  static doublereal ascle, csgni;
153  static doublereal csgnr;
154  static integer k1;
155  static integer k2;
156  static doublereal aa, bb, fn;
157  static integer mm;
158  static doublereal az;
159  static integer ir, nn;
160  static doublereal rl;
161  static integer mr, nw;
162  static doublereal dig, arg, aln, fmm, r1m5, ufl, sgn;
163  static integer nuf, inu;
164  static doublereal tol, sti, zni, zti, str, znr;
165 
166 /* ***BEGIN PROLOGUE ZBESH */
167 /* ***DATE WRITTEN 830501 (YYMMDD) */
168 /* ***REVISION DATE 890801 (YYMMDD) */
169 /* ***CATEGORY NO. B5K */
170 /* ***KEYWORDS H-BESSEL FUNCTIONS,BESSEL FUNCTIONS OF COMPLEX ARGUMENT, */
171 /* BESSEL FUNCTIONS OF THIRD KIND,HANKEL FUNCTIONS */
172 /* ***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES */
173 /* ***PURPOSE TO COMPUTE THE H-BESSEL FUNCTIONS OF A COMPLEX ARGUMENT */
174 /* ***DESCRIPTION */
175 
176 /* ***A DOUBLE PRECISION ROUTINE*** */
177 /* ON KODE=1, ZBESH COMPUTES AN N MEMBER SEQUENCE OF COMPLEX */
178 /* HANKEL (BESSEL) FUNCTIONS CY(J)=H(M,FNU+J-1,Z) FOR KINDS M=1 */
179 /* OR 2, REAL, NONNEGATIVE ORDERS FNU+J-1, J=1,...,N, AND COMPLEX */
180 /* Z.NE.CMPLX(0.0,0.0) IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI. */
181 /* ON KODE=2, ZBESH RETURNS THE SCALED HANKEL FUNCTIONS */
182 
183 /* CY(I)=EXP(-MM*Z*I)*H(M,FNU+J-1,Z) MM=3-2*M, I**2=-1. */
184 
185 /* WHICH REMOVES THE EXPONENTIAL BEHAVIOR IN BOTH THE UPPER AND */
186 /* LOWER HALF PLANES. DEFINITIONS AND NOTATION ARE FOUND IN THE */
187 /* NBS HANDBOOK OF MATHEMATICAL FUNCTIONS (REF. 1). */
188 
189 /* INPUT ZR,ZI,FNU ARE DOUBLE PRECISION */
190 /* ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0), */
191 /* -PT.LT.ARG(Z).LE.PI */
192 /* FNU - ORDER OF INITIAL H FUNCTION, FNU.GE.0.0D0 */
193 /* KODE - A PARAMETER TO INDICATE THE SCALING OPTION */
194 /* KODE= 1 RETURNS */
195 /* CY(J)=H(M,FNU+J-1,Z), J=1,...,N */
196 /* = 2 RETURNS */
197 /* CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) */
198 /* J=1,...,N , I**2=-1 */
199 /* M - KIND OF HANKEL FUNCTION, M=1 OR 2 */
200 /* N - NUMBER OF MEMBERS IN THE SEQUENCE, N.GE.1 */
201 
202 /* OUTPUT CYR,CYI ARE DOUBLE PRECISION */
203 /* CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS */
204 /* CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE */
205 /* CY(J)=H(M,FNU+J-1,Z) OR */
206 /* CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) J=1,...,N */
207 /* DEPENDING ON KODE, I**2=-1. */
208 /* NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW, */
209 /* NZ= 0 , NORMAL RETURN */
210 /* NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO DUE */
211 /* TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0) */
212 /* J=1,...,NZ WHEN Y.GT.0.0 AND M=1 OR */
213 /* Y.LT.0.0 AND M=2. FOR THE COMPLMENTARY */
214 /* HALF PLANES, NZ STATES ONLY THE NUMBER */
215 /* OF UNDERFLOWS. */
216 /* IERR - ERROR FLAG */
217 /* IERR=0, NORMAL RETURN - COMPUTATION COMPLETED */
218 /* IERR=1, INPUT ERROR - NO COMPUTATION */
219 /* IERR=2, OVERFLOW - NO COMPUTATION, FNU TOO */
220 /* LARGE OR CABS(Z) TOO SMALL OR BOTH */
221 /* IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE */
222 /* BUT LOSSES OF SIGNIFCANCE BY ARGUMENT */
223 /* REDUCTION PRODUCE LESS THAN HALF OF MACHINE */
224 /* ACCURACY */
225 /* IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- */
226 /* TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- */
227 /* CANCE BY ARGUMENT REDUCTION */
228 /* IERR=5, ERROR - NO COMPUTATION, */
229 /* ALGORITHM TERMINATION CONDITION NOT MET */
230 
231 /* ***LONG DESCRIPTION */
232 
233 /* THE COMPUTATION IS CARRIED OUT BY THE RELATION */
234 
235 /* H(M,FNU,Z)=(1/MP)*EXP(-MP*FNU)*K(FNU,Z*EXP(-MP)) */
236 /* MP=MM*HPI*I, MM=3-2*M, HPI=PI/2, I**2=-1 */
237 
238 /* FOR M=1 OR 2 WHERE THE K BESSEL FUNCTION IS COMPUTED FOR THE */
239 /* RIGHT HALF PLANE RE(Z).GE.0.0. THE K FUNCTION IS CONTINUED */
240 /* TO THE LEFT HALF PLANE BY THE RELATION */
241 
242 /* K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z) */
243 /* MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1 */
244 
245 /* WHERE I(FNU,Z) IS THE I BESSEL FUNCTION. */
246 
247 /* EXPONENTIAL DECAY OF H(M,FNU,Z) OCCURS IN THE UPPER HALF Z */
248 /* PLANE FOR M=1 AND THE LOWER HALF Z PLANE FOR M=2. EXPONENTIAL */
249 /* GROWTH OCCURS IN THE COMPLEMENTARY HALF PLANES. SCALING */
250 /* BY EXP(-MM*Z*I) REMOVES THE EXPONENTIAL BEHAVIOR IN THE */
251 /* WHOLE Z PLANE FOR Z TO INFINITY. */
252 
253 /* FOR NEGATIVE ORDERS,THE FORMULAE */
254 
255 /* H(1,-FNU,Z) = H(1,FNU,Z)*CEXP( PI*FNU*I) */
256 /* H(2,-FNU,Z) = H(2,FNU,Z)*CEXP(-PI*FNU*I) */
257 /* I**2=-1 */
258 
259 /* CAN BE USED. */
260 
261 /* IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- */
262 /* MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS */
263 /* LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. */
264 /* CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN */
265 /* LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG */
266 /* IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS */
267 /* DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. */
268 /* IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS */
269 /* LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS */
270 /* MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE */
271 /* INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS */
272 /* RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 */
273 /* ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION */
274 /* ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION */
275 /* ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN */
276 /* THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT */
277 /* TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS */
278 /* IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. */
279 /* SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. */
280 
281 /* THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX */
282 /* BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT */
283 /* ROUNDOFF,1.0D-18) IS THE NOMINAL PRECISION AND 10**S REPRE- */
284 /* SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE */
285 /* ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), */
286 /* ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF */
287 /* CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY */
288 /* HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN */
289 /* ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY */
290 /* SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER */
291 /* THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, */
292 /* 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS */
293 /* THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER */
294 /* COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY */
295 /* BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER */
296 /* COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE */
297 /* MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, */
298 /* THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, */
299 /* OR -PI/2+P. */
300 
301 /* ***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ */
302 /* AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF */
303 /* COMMERCE, 1955. */
304 
305 /* COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
306 /* BY D. E. AMOS, SAND83-0083, MAY, 1983. */
307 
308 /* COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
309 /* AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 */
310 
311 /* A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
312 /* ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- */
313 /* 1018, MAY, 1985 */
314 
315 /* A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX */
316 /* ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. */
317 /* MATH. SOFTWARE, 1986 */
318 
319 /* ***ROUTINES CALLED ZACON,ZBKNU,ZBUNK,ZUOIK,myzabs,I1MACH,D1MACH */
320 /* ***END PROLOGUE ZBESH */
321 
322 /* COMPLEX CY,Z,ZN,ZT,CSGN */
323 
324  /* Parameter adjustments */
325  --cyi;
326  --cyr;
327 
328  /* Function Body */
329 
330 /* ***FIRST EXECUTABLE STATEMENT ZBESH */
331  *ierr = 0;
332  *nz = 0;
333  if (*zr == 0. && *zi == 0.) {
334  *ierr = 1;
335  }
336  if (*fnu < 0.) {
337  *ierr = 1;
338  }
339  if (*m < 1 || *m > 2) {
340  *ierr = 1;
341  }
342  if (*kode < 1 || *kode > 2) {
343  *ierr = 1;
344  }
345  if (*n < 1) {
346  *ierr = 1;
347  }
348  if (*ierr != 0) {
349  return 0;
350  }
351  nn = *n;
352 /* ----------------------------------------------------------------------- */
353 /* SET PARAMETERS RELATED TO MACHINE CONSTANTS. */
354 /* TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. */
355 /* ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. */
356 /* EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND */
357 /* EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR */
358 /* UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. */
359 /* RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. */
360 /* DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). */
361 /* FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU */
362 /* ----------------------------------------------------------------------- */
363 /* Computing MAX */
364  d__1 = d1mach_(&c__4);
365  tol = max(d__1,1e-18);
366  k1 = i1mach_(&c__15);
367  k2 = i1mach_(&c__16);
368  r1m5 = d1mach_(&c__5);
369 /* Computing MIN */
370  i__1 = abs(k1), i__2 = abs(k2);
371  k = min(i__1,i__2);
372  elim = ((doublereal) ((real) k) * r1m5 - 3.) * 2.303;
373  k1 = i1mach_(&c__14) - 1;
374  aa = r1m5 * (doublereal) ((real) k1);
375  dig = min(aa,18.);
376  aa *= 2.303;
377 /* Computing MAX */
378  d__1 = -aa;
379  alim = elim + max(d__1,-41.45);
380  fnul = (dig - 3.) * 6. + 10.;
381  rl = dig * 1.2 + 3.;
382  fn = *fnu + (doublereal) ((real) (nn - 1));
383  mm = 3 - *m - *m;
384  fmm = (doublereal) ((real) mm);
385  znr = fmm * *zi;
386  zni = -fmm * *zr;
387 /* ----------------------------------------------------------------------- */
388 /* TEST FOR PROPER RANGE */
389 /* ----------------------------------------------------------------------- */
390  az = myzabs_(zr, zi);
391  aa = .5 / tol;
392  bb = (doublereal) ((real) i1mach_(&c__9)) * .5;
393  aa = min(aa,bb);
394  if (az > aa) {
395  goto L260;
396  }
397  if (fn > aa) {
398  goto L260;
399  }
400  aa = sqrt(aa);
401  if (az > aa) {
402  *ierr = 3;
403  }
404  if (fn > aa) {
405  *ierr = 3;
406  }
407 /* ----------------------------------------------------------------------- */
408 /* OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE */
409 /* ----------------------------------------------------------------------- */
410  ufl = d1mach_(&c__1) * 1e3;
411  if (az < ufl) {
412  goto L230;
413  }
414  if (*fnu > fnul) {
415  goto L90;
416  }
417  if (fn <= 1.) {
418  goto L70;
419  }
420  if (fn > 2.) {
421  goto L60;
422  }
423  if (az > tol) {
424  goto L70;
425  }
426  arg = az * .5;
427  aln = -fn * log(arg);
428  if (aln > elim) {
429  goto L230;
430  }
431  goto L70;
432 L60:
433  zuoik_(&znr, &zni, fnu, kode, &c__2, &nn, &cyr[1], &cyi[1], &nuf, &tol, &
434  elim, &alim);
435  if (nuf < 0) {
436  goto L230;
437  }
438  *nz += nuf;
439  nn -= nuf;
440 /* ----------------------------------------------------------------------- */
441 /* HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK */
442 /* IF NUF=NN, THEN CY(I)=CZERO FOR ALL I */
443 /* ----------------------------------------------------------------------- */
444  if (nn == 0) {
445  goto L140;
446  }
447 L70:
448  if (znr < 0. || (znr == 0. && zni < 0. && *m == 2)) {
449  goto L80;
450  }
451 /* ----------------------------------------------------------------------- */
452 /* RIGHT HALF PLANE COMPUTATION, XN.GE.0. .AND. (XN.NE.0. .OR. */
453 /* YN.GE.0. .OR. M=1) */
454 /* ----------------------------------------------------------------------- */
455  zbknu_(&znr, &zni, fnu, kode, &nn, &cyr[1], &cyi[1], nz, &tol, &elim, &
456  alim);
457  goto L110;
458 /* ----------------------------------------------------------------------- */
459 /* LEFT HALF PLANE COMPUTATION */
460 /* ----------------------------------------------------------------------- */
461 L80:
462  mr = -mm;
463  zacon_(&znr, &zni, fnu, kode, &mr, &nn, &cyr[1], &cyi[1], &nw, &rl, &fnul,
464  &tol, &elim, &alim);
465  if (nw < 0) {
466  goto L240;
467  }
468  *nz = nw;
469  goto L110;
470 L90:
471 /* ----------------------------------------------------------------------- */
472 /* UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL */
473 /* ----------------------------------------------------------------------- */
474  mr = 0;
475  if (znr >= 0. && (znr != 0. || zni >= 0. || *m != 2)) {
476  goto L100;
477  }
478  mr = -mm;
479  if (znr != 0. || zni >= 0.) {
480  goto L100;
481  }
482  znr = -znr;
483  zni = -zni;
484 L100:
485  zbunk_(&znr, &zni, fnu, kode, &mr, &nn, &cyr[1], &cyi[1], &nw, &tol, &
486  elim, &alim);
487  if (nw < 0) {
488  goto L240;
489  }
490  *nz += nw;
491 L110:
492 /* ----------------------------------------------------------------------- */
493 /* H(M,FNU,Z) = -FMM*(I/HPI)*(ZT**FNU)*K(FNU,-Z*ZT) */
494 
495 /* ZT=EXP(-FMM*HPI*I) = CMPLX(0.0,-FMM), FMM=3-2*M, M=1,2 */
496 /* ----------------------------------------------------------------------- */
497  d__1 = -fmm;
498  sgn = d_sign(&hpi, &d__1);
499 /* ----------------------------------------------------------------------- */
500 /* CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE */
501 /* WHEN FNU IS LARGE */
502 /* ----------------------------------------------------------------------- */
503  inu = (integer) ((real) (*fnu));
504  inuh = inu / 2;
505  ir = inu - (inuh << 1);
506  arg = (*fnu - (doublereal) ((real) (inu - ir))) * sgn;
507  rhpi = 1. / sgn;
508 /* ZNI = RHPI*DCOS(ARG) */
509 /* ZNR = -RHPI*DSIN(ARG) */
510  csgni = rhpi * cos(arg);
511  csgnr = -rhpi * sin(arg);
512  if (inuh % 2 == 0) {
513  goto L120;
514  }
515 /* ZNR = -ZNR */
516 /* ZNI = -ZNI */
517  csgnr = -csgnr;
518  csgni = -csgni;
519 L120:
520  zti = -fmm;
521  rtol = 1. / tol;
522  ascle = ufl * rtol;
523  i__1 = nn;
524  for (i__ = 1; i__ <= i__1; ++i__) {
525 /* STR = CYR(I)*ZNR - CYI(I)*ZNI */
526 /* CYI(I) = CYR(I)*ZNI + CYI(I)*ZNR */
527 /* CYR(I) = STR */
528 /* STR = -ZNI*ZTI */
529 /* ZNI = ZNR*ZTI */
530 /* ZNR = STR */
531  aa = cyr[i__];
532  bb = cyi[i__];
533  atol = 1.;
534 /* Computing MAX */
535  d__1 = abs(aa), d__2 = abs(bb);
536  if (max(d__1,d__2) > ascle) {
537  goto L135;
538  }
539  aa *= rtol;
540  bb *= rtol;
541  atol = tol;
542 L135:
543  str = aa * csgnr - bb * csgni;
544  sti = aa * csgni + bb * csgnr;
545  cyr[i__] = str * atol;
546  cyi[i__] = sti * atol;
547  str = -csgni * zti;
548  csgni = csgnr * zti;
549  csgnr = str;
550 /* L130: */
551  }
552  return 0;
553 L140:
554  if (znr < 0.) {
555  goto L230;
556  }
557  return 0;
558 L230:
559  *nz = 0;
560  *ierr = 2;
561  return 0;
562 L240:
563  if (nw == -1) {
564  goto L230;
565  }
566  *nz = 0;
567  *ierr = 5;
568  return 0;
569 L260:
570  *nz = 0;
571  *ierr = 4;
572  return 0;
573 } /* zbesh_ */
574 
575 /* DECK D1MACH */
576 doublereal d1mach_(const integer* i__)
577 {
578  /* Initialized data */
579 
580  static struct {
581  integer e_1[10];
582  doublereal fill_2[1];
583  doublereal e_3;
584  } equiv_4 = { {2002288515, 1050897, 1487780761, 2146426097,
585  -1209488034, 1017118298, -1209488034, 1018166874, 1352628735,
586  1070810131}, {0}, 0. };
587 
588 
589  /* System generated locals */
590  doublereal ret_val;
591 
592  /* Local variables */
593 #define log10 ((integer *)&equiv_4 + 8)
594 #define dmach ((doublereal *)&equiv_4)
595 #define large ((integer *)&equiv_4 + 2)
596 #define small ((integer *)&equiv_4)
597 #define diver ((integer *)&equiv_4 + 6)
598 #define right ((integer *)&equiv_4 + 4)
599 
600 /* ***BEGIN PROLOGUE D1MACH */
601 /* ***DATE WRITTEN 750101 (YYMMDD) */
602 /* ***REVISION DATE 890213 (YYMMDD) */
603 /* ***CATEGORY NO. R1 */
604 /* ***KEYWORDS LIBRARY=SLATEC,TYPE=DOUBLE PRECISION(R1MACH-S D1MACH-D), */
605 /* MACHINE CONSTANTS */
606 /* ***AUTHOR FOX, P. A., (BELL LABS) */
607 /* HALL, A. D., (BELL LABS) */
608 /* SCHRYER, N. L., (BELL LABS) */
609 /* ***PURPOSE Returns double precision machine dependent constants */
610 /* ***DESCRIPTION */
611 
612 /* D1MACH can be used to obtain machine-dependent parameters */
613 /* for the local machine environment. It is a function */
614 /* subprogram with one (input) argument, and can be called */
615 /* as follows, for example */
616 
617 /* D = D1MACH(I) */
618 
619 /* where I=1,...,5. The (output) value of D above is */
620 /* determined by the (input) value of I. The results for */
621 /* various values of I are discussed below. */
622 
623 /* D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude. */
624 /* D1MACH( 2) = B**EMAX*(1 - B**(-T)), the largest magnitude. */
625 /* D1MACH( 3) = B**(-T), the smallest relative spacing. */
626 /* D1MACH( 4) = B**(1-T), the largest relative spacing. */
627 /* D1MACH( 5) = LOG10(B) */
628 
629 /* Assume double precision numbers are represented in the T-digit, */
630 /* base-B form */
631 
632 /* sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) */
633 
634 /* where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and */
635 /* EMIN .LE. E .LE. EMAX. */
636 
637 /* The values of B, T, EMIN and EMAX are provided in I1MACH as */
638 /* follows: */
639 /* I1MACH(10) = B, the base. */
640 /* I1MACH(14) = T, the number of base-B digits. */
641 /* I1MACH(15) = EMIN, the smallest exponent E. */
642 /* I1MACH(16) = EMAX, the largest exponent E. */
643 
644 /* To alter this function for a particular environment, */
645 /* the desired set of DATA statements should be activated by */
646 /* removing the C from column 1. Also, the values of */
647 /* D1MACH(1) - D1MACH(4) should be checked for consistency */
648 /* with the local operating system. */
649 
650 /* ***REFERENCES FOX P.A., HALL A.D., SCHRYER N.L.,*FRAMEWORK FOR A */
651 /* PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHEMATICAL */
652 /* SOFTWARE, VOL. 4, NO. 2, JUNE 1978, PP. 177-188. */
653 /* ***ROUTINES CALLED XERROR */
654 /* ***END PROLOGUE D1MACH */
655 
656 
657 
658 
659 /* MACHINE CONSTANTS FOR THE AMIGA */
660 /* ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION */
661 
662 /* DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / */
663 /* DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / */
664 /* DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / */
665 /* DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / */
666 /* DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / */
667 
668 /* MACHINE CONSTANTS FOR THE AMIGA */
669 /* ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT */
670 
671 /* DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / */
672 /* DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' / */
673 /* DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / */
674 /* DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / */
675 /* DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / */
676 
677 /* MACHINE CONSTANTS FOR THE APOLLO */
678 
679 /* DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 / */
680 /* DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF / */
681 /* DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 / */
682 /* DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 / */
683 /* DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF / */
684 
685 /* MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM */
686 
687 /* DATA SMALL(1) / ZC00800000 / */
688 /* DATA SMALL(2) / Z000000000 / */
689 /* DATA LARGE(1) / ZDFFFFFFFF / */
690 /* DATA LARGE(2) / ZFFFFFFFFF / */
691 /* DATA RIGHT(1) / ZCC5800000 / */
692 /* DATA RIGHT(2) / Z000000000 / */
693 /* DATA DIVER(1) / ZCC6800000 / */
694 /* DATA DIVER(2) / Z000000000 / */
695 /* DATA LOG10(1) / ZD00E730E7 / */
696 /* DATA LOG10(2) / ZC77800DC0 / */
697 
698 /* MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM */
699 
700 /* DATA SMALL(1) / O1771000000000000 / */
701 /* DATA SMALL(2) / O0000000000000000 / */
702 /* DATA LARGE(1) / O0777777777777777 / */
703 /* DATA LARGE(2) / O0007777777777777 / */
704 /* DATA RIGHT(1) / O1461000000000000 / */
705 /* DATA RIGHT(2) / O0000000000000000 / */
706 /* DATA DIVER(1) / O1451000000000000 / */
707 /* DATA DIVER(2) / O0000000000000000 / */
708 /* DATA LOG10(1) / O1157163034761674 / */
709 /* DATA LOG10(2) / O0006677466732724 / */
710 
711 /* MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS */
712 
713 /* DATA SMALL(1) / O1771000000000000 / */
714 /* DATA SMALL(2) / O7770000000000000 / */
715 /* DATA LARGE(1) / O0777777777777777 / */
716 /* DATA LARGE(2) / O7777777777777777 / */
717 /* DATA RIGHT(1) / O1461000000000000 / */
718 /* DATA RIGHT(2) / O0000000000000000 / */
719 /* DATA DIVER(1) / O1451000000000000 / */
720 /* DATA DIVER(2) / O0000000000000000 / */
721 /* DATA LOG10(1) / O1157163034761674 / */
722 /* DATA LOG10(2) / O0006677466732724 / */
723 
724 /* MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE */
725 
726 /* DATA SMALL(1) / Z"3001800000000000" / */
727 /* DATA SMALL(2) / Z"3001000000000000" / */
728 /* DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" / */
729 /* DATA LARGE(2) / Z"4FFE000000000000" / */
730 /* DATA RIGHT(1) / Z"3FD2800000000000" / */
731 /* DATA RIGHT(2) / Z"3FD2000000000000" / */
732 /* DATA DIVER(1) / Z"3FD3800000000000" / */
733 /* DATA DIVER(2) / Z"3FD3000000000000" / */
734 /* DATA LOG10(1) / Z"3FFF9A209A84FBCF" / */
735 /* DATA LOG10(2) / Z"3FFFF7988F8959AC" / */
736 
737 /* MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES */
738 
739 /* DATA SMALL(1) / 00564000000000000000B / */
740 /* DATA SMALL(2) / 00000000000000000000B / */
741 /* DATA LARGE(1) / 37757777777777777777B / */
742 /* DATA LARGE(2) / 37157777777777777777B / */
743 /* DATA RIGHT(1) / 15624000000000000000B / */
744 /* DATA RIGHT(2) / 00000000000000000000B / */
745 /* DATA DIVER(1) / 15634000000000000000B / */
746 /* DATA DIVER(2) / 00000000000000000000B / */
747 /* DATA LOG10(1) / 17164642023241175717B / */
748 /* DATA LOG10(2) / 16367571421742254654B / */
749 
750 /* MACHINE CONSTANTS FOR THE CELERITY C1260 */
751 
752 /* DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / */
753 /* DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / */
754 /* DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / */
755 /* DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / */
756 /* DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / */
757 
758 /* MACHINE CONSTANTS FOR THE CONVEX C-1 */
759 
760 /* DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / */
761 /* DATA LARGE(1), LARGE(2) / '7FFFFFFF'X,'FFFFFFFF'X / */
762 /* DATA RIGHT(1), RIGHT(2) / '3CC00000'X,'00000000'X / */
763 /* DATA DIVER(1), DIVER(2) / '3CD00000'X,'00000000'X / */
764 /* DATA LOG10(1), LOG10(2) / '3FF34413'X,'509F79FF'X / */
765 
766 /* MACHINE CONSTANTS FOR THE CRAY-1 */
767 
768 /* DATA SMALL(1) / 201354000000000000000B / */
769 /* DATA SMALL(2) / 000000000000000000000B / */
770 /* DATA LARGE(1) / 577767777777777777777B / */
771 /* DATA LARGE(2) / 000007777777777777774B / */
772 /* DATA RIGHT(1) / 376434000000000000000B / */
773 /* DATA RIGHT(2) / 000000000000000000000B / */
774 /* DATA DIVER(1) / 376444000000000000000B / */
775 /* DATA DIVER(2) / 000000000000000000000B / */
776 /* DATA LOG10(1) / 377774642023241175717B / */
777 /* DATA LOG10(2) / 000007571421742254654B / */
778 
779 /* MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 */
780 
781 /* NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD - */
782 /* STATIC DMACH(5) */
783 
784 /* DATA SMALL / 20K, 3*0 / */
785 /* DATA LARGE / 77777K, 3*177777K / */
786 /* DATA RIGHT / 31420K, 3*0 / */
787 /* DATA DIVER / 32020K, 3*0 / */
788 /* DATA LOG10 / 40423K, 42023K, 50237K, 74776K / */
789 
790 /* MACHINE CONSTANTS FOR THE ELXSI 6400 */
791 /* (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION) */
792 
793 /* DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X / */
794 /* DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X / */
795 /* DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X / */
796 /* DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X / */
797 /* DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X / */
798 
799 /* MACHINE CONSTANTS FOR THE HARRIS 220 */
800 
801 /* DATA SMALL(1), SMALL(2) / '20000000, '00000201 / */
802 /* DATA LARGE(1), LARGE(2) / '37777777, '37777577 / */
803 /* DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 / */
804 /* DATA DIVER(1), DIVER(2) / '20000000, '00000334 / */
805 /* DATA LOG10(1), LOG10(2) / '23210115, '10237777 / */
806 
807 /* MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES */
808 
809 /* DATA SMALL(1), SMALL(2) / O402400000000, O000000000000 / */
810 /* DATA LARGE(1), LARGE(2) / O376777777777, O777777777777 / */
811 /* DATA RIGHT(1), RIGHT(2) / O604400000000, O000000000000 / */
812 /* DATA DIVER(1), DIVER(2) / O606400000000, O000000000000 / */
813 /* DATA LOG10(1), LOG10(2) / O776464202324, O117571775714 / */
814 
815 /* MACHINE CONSTANTS FOR THE HP 2100 */
816 /* THREE WORD DOUBLE PRECISION OPTION WITH FTN4 */
817 
818 /* DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 / */
819 /* DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B / */
820 /* DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B / */
821 /* DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B / */
822 /* DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B / */
823 
824 /* MACHINE CONSTANTS FOR THE HP 2100 */
825 /* FOUR WORD DOUBLE PRECISION OPTION WITH FTN4 */
826 
827 /* DATA SMALL(1), SMALL(2) / 40000B, 0 / */
828 /* DATA SMALL(3), SMALL(4) / 0, 1 / */
829 /* DATA LARGE(1), LARGE(2) / 77777B, 177777B / */
830 /* DATA LARGE(3), LARGE(4) / 177777B, 177776B / */
831 /* DATA RIGHT(1), RIGHT(2) / 40000B, 0 / */
832 /* DATA RIGHT(3), RIGHT(4) / 0, 225B / */
833 /* DATA DIVER(1), DIVER(2) / 40000B, 0 / */
834 /* DATA DIVER(3), DIVER(4) / 0, 227B / */
835 /* DATA LOG10(1), LOG10(2) / 46420B, 46502B / */
836 /* DATA LOG10(3), LOG10(4) / 76747B, 176377B / */
837 
838 /* MACHINE CONSTANTS FOR THE HP 9000 */
839 
840 /* DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B / */
841 /* DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B / */
842 /* DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B / */
843 /* DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B / */
844 /* DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B / */
845 
846 /* MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, */
847 /* THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND */
848 /* THE PERKIN ELMER (INTERDATA) 7/32. */
849 
850 /* DATA SMALL(1), SMALL(2) / Z00100000, Z00000000 / */
851 /* DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF / */
852 /* DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 / */
853 /* DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 / */
854 /* DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF / */
855 
856 /* MACHINE CONSTANTS FOR THE IBM PC */
857 /* ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION */
858 /* ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087. */
859 
860 
861 /* MACHINE CONSTANTS FOR THE IBM RS 6000 */
862 
863 /* DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / */
864 /* DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / */
865 /* DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / */
866 /* DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / */
867 /* DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / */
868 
869 /* MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) */
870 
871 /* DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 / */
872 /* DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 / */
873 /* DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 / */
874 /* DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 / */
875 /* DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 / */
876 
877 /* MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) */
878 
879 /* DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 / */
880 /* DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 / */
881 /* DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 / */
882 /* DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 / */
883 /* DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 / */
884 
885 /* MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING */
886 /* 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). */
887 
888 /* DATA SMALL(1), SMALL(2) / 8388608, 0 / */
889 /* DATA LARGE(1), LARGE(2) / 2147483647, -1 / */
890 /* DATA RIGHT(1), RIGHT(2) / 612368384, 0 / */
891 /* DATA DIVER(1), DIVER(2) / 620756992, 0 / */
892 /* DATA LOG10(1), LOG10(2) / 1067065498, -2063872008 / */
893 
894 /* DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 / */
895 /* DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 / */
896 /* DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 / */
897 /* DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 / */
898 /* DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 / */
899 
900 /* MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING */
901 /* 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL). */
902 
903 /* DATA SMALL(1), SMALL(2) / 128, 0 / */
904 /* DATA SMALL(3), SMALL(4) / 0, 0 / */
905 /* DATA LARGE(1), LARGE(2) / 32767, -1 / */
906 /* DATA LARGE(3), LARGE(4) / -1, -1 / */
907 /* DATA RIGHT(1), RIGHT(2) / 9344, 0 / */
908 /* DATA RIGHT(3), RIGHT(4) / 0, 0 / */
909 /* DATA DIVER(1), DIVER(2) / 9472, 0 / */
910 /* DATA DIVER(3), DIVER(4) / 0, 0 / */
911 /* DATA LOG10(1), LOG10(2) / 16282, 8346 / */
912 /* DATA LOG10(3), LOG10(4) / -31493, -12296 / */
913 
914 /* DATA SMALL(1), SMALL(2) / O000200, O000000 / */
915 /* DATA SMALL(3), SMALL(4) / O000000, O000000 / */
916 /* DATA LARGE(1), LARGE(2) / O077777, O177777 / */
917 /* DATA LARGE(3), LARGE(4) / O177777, O177777 / */
918 /* DATA RIGHT(1), RIGHT(2) / O022200, O000000 / */
919 /* DATA RIGHT(3), RIGHT(4) / O000000, O000000 / */
920 /* DATA DIVER(1), DIVER(2) / O022400, O000000 / */
921 /* DATA DIVER(3), DIVER(4) / O000000, O000000 / */
922 /* DATA LOG10(1), LOG10(2) / O037632, O020232 / */
923 /* DATA LOG10(3), LOG10(4) / O102373, O147770 / */
924 
925 /* MACHINE CONSTANTS FOR THE SILICON GRAPHICS IRIS */
926 
927 /* data dmach(1) / 2.22507 38585 072012 d-308 / */
928 /* data dmach(2) / 1.79769 31348 623158 d+308 / */
929 /* data dmach(3) / 2.22044 60492 503131 d-16 / */
930 /* data dmach(4) / 4.44089 20985 006262 d-16 / */
931 /* data dmach(5) / 0.30102 99956 639812 / */
932 
933 /* DATA SMALL(1), SMALL(2) / Z'00100000',Z'00000000' / */
934 /* DATA LARGE(1), LARGE(2) / Z'7FEFFFFF',Z'FFFFFFFF' / */
935 /* DATA RIGHT(1), RIGHT(2) / Z'3CB00000',Z'00000000' / */
936 /* DATA DIVER(1), DIVER(2) / Z'3CC00000',Z'00000000' / */
937 /* DATA LOG10(1), LOG10(2) / Z'3FD34413',Z'509F79FF' / */
938 
939 /* MACHINE CONSTANTS FOR THE SUN */
940 
941 /* from SLATEC CML committee - work for Sun3, Sun4, and Sparc */
942 
943 /* DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' / */
944 /* DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' / */
945 /* DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' / */
946 /* DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' / */
947 /* DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' / */
948 
949 /* from Sun Microsystems - work for Sun 386i */
950 
951 /* DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000' / */
952 /* DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF' / */
953 /* DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000' / */
954 /* DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000' / */
955 /* DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413' / */
956 
957 /* MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER */
958 
959 /* DATA SMALL(1), SMALL(2) / O000040000000, O000000000000 / */
960 /* DATA LARGE(1), LARGE(2) / O377777777777, O777777777777 / */
961 /* DATA RIGHT(1), RIGHT(2) / O170540000000, O000000000000 / */
962 /* DATA DIVER(1), DIVER(2) / O170640000000, O000000000000 / */
963 /* DATA LOG10(1), LOG10(2) / O177746420232, O411757177572 / */
964 
965 /* MACHINE CONSTANTS FOR VAX 11/780 */
966 /* (EXPRESSED IN INTEGER AND HEXADECIMAL) */
967 /* THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSYEMS */
968 /* THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS */
969 
970 /* DATA SMALL(1), SMALL(2) / 128, 0 / */
971 /* DATA LARGE(1), LARGE(2) / -32769, -1 / */
972 /* DATA RIGHT(1), RIGHT(2) / 9344, 0 / */
973 /* DATA DIVER(1), DIVER(2) / 9472, 0 / */
974 /* DATA LOG10(1), LOG10(2) / 546979738, -805796613 / */
975 
976 /* DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 / */
977 /* DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / */
978 /* DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 / */
979 /* DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 / */
980 /* DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB / */
981 
982 /* MACHINE CONSTANTS FOR VAX 11/780 (G-FLOATING) */
983 /* (EXPRESSED IN INTEGER AND HEXADECIMAL) */
984 /* THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSYEMS */
985 /* THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS */
986 
987 /* DATA SMALL(1), SMALL(2) / 16, 0 / */
988 /* DATA LARGE(1), LARGE(2) / -32769, -1 / */
989 /* DATA RIGHT(1), RIGHT(2) / 15552, 0 / */
990 /* DATA DIVER(1), DIVER(2) / 15568, 0 / */
991 /* DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 / */
992 
993 /* DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 / */
994 /* DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF / */
995 /* DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 / */
996 /* DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 / */
997 /* DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F / */
998 
999 
1000 /* ***FIRST EXECUTABLE STATEMENT D1MACH */
1001  if (*i__ < 1 || *i__ > 5) {
1002  xerror_("D1MACH -- I OUT OF BOUNDS", &c__25, &c__1, &c__2, (ftnlen)25)
1003  ;
1004  }
1005 
1006  ret_val = dmach[*i__ - 1];
1007  return ret_val;
1008 
1009 } /* d1mach_ */
1010 
1011 #undef right
1012 #undef diver
1013 #undef small
1014 #undef large
1015 #undef dmach
1016 #undef log10
1017 
1018 
1019 doublereal dgamln_(doublereal* z__, integer* ierr)
1020 {
1021  /* Initialized data */
1022 
1023  static doublereal gln[100] = { 0.,0.,.693147180559945309,
1024  1.791759469228055,3.17805383034794562,4.78749174278204599,
1025  6.579251212010101,8.5251613610654143,10.6046029027452502,
1026  12.8018274800814696,15.1044125730755153,17.5023078458738858,
1027  19.9872144956618861,22.5521638531234229,25.1912211827386815,
1028  27.8992713838408916,30.6718601060806728,33.5050734501368889,
1029  36.3954452080330536,39.339884187199494,42.335616460753485,
1030  45.380138898476908,48.4711813518352239,51.6066755677643736,
1031  54.7847293981123192,58.0036052229805199,61.261701761002002,
1032  64.5575386270063311,67.889743137181535,71.257038967168009,
1033  74.6582363488301644,78.0922235533153106,81.5579594561150372,
1034  85.0544670175815174,88.5808275421976788,92.1361756036870925,
1035  95.7196945421432025,99.3306124547874269,102.968198614513813,
1036  106.631760260643459,110.320639714757395,114.034211781461703,
1037  117.771881399745072,121.533081515438634,125.317271149356895,
1038  129.123933639127215,132.95257503561631,136.802722637326368,
1039  140.673923648234259,144.565743946344886,148.477766951773032,
1040  152.409592584497358,156.360836303078785,160.331128216630907,
1041  164.320112263195181,168.327445448427652,172.352797139162802,
1042  176.395848406997352,180.456291417543771,184.533828861449491,
1043  188.628173423671591,192.739047287844902,196.866181672889994,
1044  201.009316399281527,205.168199482641199,209.342586752536836,
1045  213.532241494563261,217.736934113954227,221.956441819130334,
1046  226.190548323727593,230.439043565776952,234.701723442818268,
1047  238.978389561834323,243.268849002982714,247.572914096186884,
1048  251.890402209723194,256.221135550009525,260.564940971863209,
1049  264.921649798552801,269.291097651019823,273.673124285693704,
1050  278.067573440366143,282.474292687630396,286.893133295426994,
1051  291.323950094270308,295.766601350760624,300.220948647014132,
1052  304.686856765668715,309.164193580146922,313.652829949879062,
1053  318.152639620209327,322.663499126726177,327.185287703775217,
1054  331.717887196928473,336.261181979198477,340.815058870799018,
1055  345.379407062266854,349.954118040770237,354.539085519440809,
1056  359.134205369575399 };
1057  static doublereal cf[22] = { .0833333333333333333,-.00277777777777777778,
1058  7.93650793650793651e-4,-5.95238095238095238e-4,
1059  8.41750841750841751e-4,-.00191752691752691753,
1060  .00641025641025641026,-.0295506535947712418,.179644372368830573,
1061  -1.39243221690590112,13.402864044168392,-156.848284626002017,
1062  2193.10333333333333,-36108.7712537249894,691472.268851313067,
1063  -15238221.5394074162,382900751.391414141,-10882266035.7843911,
1064  347320283765.002252,-12369602142269.2745,488788064793079.335,
1065  -21320333960919373.9 };
1066  static doublereal con = 1.83787706640934548;
1067 
1068  /* System generated locals */
1069  integer i__1;
1070  doublereal ret_val = 0;
1071 
1072  /* Builtin functions */
1073 
1074  /* Local variables */
1075  static doublereal zinc, zmin, zdmy;
1076  static integer i__, k;
1077  static doublereal s, wdtol;
1078  static doublereal t1, fz, zm;
1079  static integer mz, nz;
1080  static doublereal zp;
1081  static integer i1m;
1082  static doublereal fln, tlg, rln, trm, tst, zsq;
1083 
1084 /* ***BEGIN PROLOGUE DGAMLN */
1085 /* ***DATE WRITTEN 830501 (YYMMDD) */
1086 /* ***REVISION DATE 830501 (YYMMDD) */
1087 /* ***CATEGORY NO. B5F */
1088 /* ***KEYWORDS GAMMA FUNCTION,LOGARITHM OF GAMMA FUNCTION */
1089 /* ***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES */
1090 /* ***PURPOSE TO COMPUTE THE LOGARITHM OF THE GAMMA FUNCTION */
1091 /* ***DESCRIPTION */
1092 
1093 /* **** A DOUBLE PRECISION ROUTINE **** */
1094 /* DGAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR */
1095 /* Z.GT.0. THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES */
1096 /* GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION */
1097 /* G(Z+1)=Z*G(Z) FOR Z.LE.ZMIN. THE FUNCTION WAS MADE AS */
1098 /* PORTABLE AS POSSIBLE BY COMPUTIMG ZMIN FROM THE NUMBER OF BASE */
1099 /* 10 DIGITS IN A WORD, RLN=AMAX1(-ALOG10(R1MACH(4)),0.5E-18) */
1100 /* LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY. */
1101 
1102 /* SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100 */
1103 /* VALUES IS USED FOR SPEED OF EXECUTION. */
1104 
1105 /* DESCRIPTION OF ARGUMENTS */
1106 
1107 /* INPUT Z IS D0UBLE PRECISION */
1108 /* Z - ARGUMENT, Z.GT.0.0D0 */
1109 
1110 /* OUTPUT DGAMLN IS DOUBLE PRECISION */
1111 /* DGAMLN - NATURAL LOG OF THE GAMMA FUNCTION AT Z.NE.0.0D0 */
1112 /* IERR - ERROR FLAG */
1113 /* IERR=0, NORMAL RETURN, COMPUTATION COMPLETED */
1114 /* IERR=1, Z.LE.0.0D0, NO COMPUTATION */
1115 
1116 
1117 /* ***REFERENCES COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT */
1118 /* BY D. E. AMOS, SAND83-0083, MAY, 1983. */
1119 /* ***ROUTINES CALLED I1MACH,D1MACH */
1120 /* ***END PROLOGUE DGAMLN */
1121 /* LNGAMMA(N), N=1,100 */
1122 /* COEFFICIENTS OF ASYMPTOTIC EXPANSION */
1123 
1124 /* LN(2*PI) */
1125 
1126 /* ***FIRST EXECUTABLE STATEMENT DGAMLN */
1127  *ierr = 0;
1128  if (*z__ <= 0.) {
1129  goto L70;
1130  }
1131  if (*z__ > 101.) {
1132  goto L10;
1133  }
1134  nz = (integer) ((real) (*z__));
1135  fz = *z__ - (real) nz;
1136  if (fz > 0.) {
1137  goto L10;
1138  }
1139  if (nz > 100) {
1140  goto L10;
1141  }
1142  ret_val = gln[nz - 1];
1143  return ret_val;
1144 L10:
1145  wdtol = d1mach_(&c__4);
1146  wdtol = max(wdtol,5e-19);
1147  i1m = i1mach_(&c__14);
1148  rln = d1mach_(&c__5) * (real) i1m;
1149  fln = min(rln,20.);
1150  fln = max(fln,3.);
1151  fln += -3.;
1152  zm = fln * .3875 + 1.8;
1153  mz = (integer) ((real) zm) + 1;
1154  zmin = (real) mz;
1155  zdmy = *z__;
1156  zinc = 0.;
1157  if (*z__ >= zmin) {
1158  goto L20;
1159  }
1160  zinc = zmin - (real) nz;
1161  zdmy = *z__ + zinc;
1162 L20:
1163  zp = 1. / zdmy;
1164  t1 = cf[0] * zp;
1165  s = t1;
1166  if (zp < wdtol) {
1167  goto L40;
1168  }
1169  zsq = zp * zp;
1170  tst = t1 * wdtol;
1171  for (k = 2; k <= 22; ++k) {
1172  zp *= zsq;
1173  trm = cf[k - 1] * zp;
1174  if (abs(trm) < tst) {
1175  goto L40;
1176  }
1177  s += trm;
1178 /* L30: */
1179  }
1180 L40:
1181  if (zinc != 0.) {
1182  goto L50;
1183  }
1184  tlg = log(*z__);
1185  ret_val = *z__ * (tlg - 1.) + (con - tlg) * .5 + s;
1186  return ret_val;
1187 L50:
1188  zp = 1.;
1189  nz = (integer) ((real) zinc);
1190  i__1 = nz;
1191  for (i__ = 1; i__ <= i__1; ++i__) {
1192  zp *= *z__ + (real) (i__ - 1);
1193 /* L60: */
1194  }
1195  tlg = log(zdmy);
1196  ret_val = zdmy * (tlg - 1.) - log(zp) + (con - tlg) * .5 + s;
1197  return ret_val;
1198 
1199 
1200 L70:
1201  *ierr = 1;
1202  return ret_val;
1203 } /* dgamln_ */
1204 
1205 /* DECK I1MACH */
1206 integer i1mach_(const integer* i__)
1207 {
1208  /* Initialized data */
1209 
1210  static struct {
1211  integer e_1[16];
1212  } equiv_0 = { {5, 6, 0, 0, 32, 4, 2, 31, 2147483647, 2, 24, -125, 127,
1213  53, -1021, 1023} };
1214 
1215 
1216  /* Format strings */
1217  static char fmt_9000[] = "(\0021ERROR 1 IN I1MACH - I OUT OF BOUND\
1218 S\002)";
1219 
1220  /* System generated locals */
1221  integer ret_val = 0;
1222 
1223  /* Builtin functions */
1224 
1225  /* Local variables */
1226 #define imach ((integer *)&equiv_0)
1227 #define output ((integer *)&equiv_0 + 3)
1228 
1229  /* Fortran I/O blocks */
1230  static cilist io___72 = { 0, 0, 0, fmt_9000, 0 };
1231 
1232 
1233 /* ***BEGIN PROLOGUE I1MACH */
1234 /* ***DATE WRITTEN 750101 (YYMMDD) */
1235 /* ***REVISION DATE 890213 (YYMMDD) */
1236 /* ***CATEGORY NO. R1 */
1237 /* ***KEYWORDS LIBRARY=SLATEC,TYPE=INTEGER(I1MACH-I),MACHINE CONSTANTS */
1238 /* ***AUTHOR FOX, P. A., (BELL LABS) */
1239 /* HALL, A. D., (BELL LABS) */
1240 /* SCHRYER, N. L., (BELL LABS) */
1241 /* ***PURPOSE Returns integer machine dependent constants */
1242 /* ***DESCRIPTION */
1243 
1244 /* I1MACH can be used to obtain machine-dependent parameters */
1245 /* for the local machine environment. It is a function */
1246 /* subroutine with one (input) argument, and can be called */
1247 /* as follows, for example */
1248 
1249 /* K = I1MACH(I) */
1250 
1251 /* where I=1,...,16. The (output) value of K above is */
1252 /* determined by the (input) value of I. The results for */
1253 /* various values of I are discussed below. */
1254 
1255 /* I/O unit numbers. */
1256 /* I1MACH( 1) = the standard input unit. */
1257 /* I1MACH( 2) = the standard output unit. */
1258 /* I1MACH( 3) = the standard punch unit. */
1259 /* I1MACH( 4) = the standard error message unit. */
1260 
1261 /* Words. */
1262 /* I1MACH( 5) = the number of bits per integer storage unit. */
1263 /* I1MACH( 6) = the number of characters per integer storage unit. */
1264 
1265 /* Integers. */
1266 /* assume integers are represented in the S-digit, base-A form */
1267 
1268 /* sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) ) */
1269 
1270 /* where 0 .LE. X(I) .LT. A for I=0,...,S-1. */
1271 /* I1MACH( 7) = A, the base. */
1272 /* I1MACH( 8) = S, the number of base-A digits. */
1273 /* I1MACH( 9) = A**S - 1, the largest magnitude. */
1274 
1275 /* Floating-Point Numbers. */
1276 /* Assume floating-point numbers are represented in the T-digit, */
1277 /* base-B form */
1278 /* sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) ) */
1279 
1280 /* where 0 .LE. X(I) .LT. B for I=1,...,T, */
1281 /* 0 .LT. X(1), and EMIN .LE. E .LE. EMAX. */
1282 /* I1MACH(10) = B, the base. */
1283 
1284 /* Single-Precision */
1285 /* I1MACH(11) = T, the number of base-B digits. */
1286 /* I1MACH(12) = EMIN, the smallest exponent E. */
1287 /* I1MACH(13) = EMAX, the largest exponent E. */
1288 
1289 /* Double-Precision */
1290 /* I1MACH(14) = T, the number of base-B digits. */
1291 /* I1MACH(15) = EMIN, the smallest exponent E. */
1292 /* I1MACH(16) = EMAX, the largest exponent E. */
1293 
1294 /* To alter this function for a particular environment, */
1295 /* the desired set of DATA statements should be activated by */
1296 /* removing the C from column 1. Also, the values of */
1297 /* I1MACH(1) - I1MACH(4) should be checked for consistency */
1298 /* with the local operating system. */
1299 
1300 /* ***REFERENCES FOX P.A., HALL A.D., SCHRYER N.L.,*FRAMEWORK FOR A */
1301 /* PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHEMATICAL */
1302 /* SOFTWARE, VOL. 4, NO. 2, JUNE 1978, PP. 177-188. */
1303 /* ***ROUTINES CALLED (NONE) */
1304 /* ***END PROLOGUE I1MACH */
1305 
1306 
1307 /* MACHINE CONSTANTS FOR THE AMIGA */
1308 /* ABSOFT COMPILER */
1309 
1310 /* DATA IMACH(1) / 5 / */
1311 /* DATA IMACH(2) / 6 / */
1312 /* DATA IMACH(3) / 5 / */
1313 /* DATA IMACH(4) / 6 / */
1314 /* DATA IMACH(5) / 32 / */
1315 /* DATA IMACH(6) / 4 / */
1316 /* DATA IMACH(7) / 2 / */
1317 /* DATA IMACH(8) / 31 / */
1318 /* DATA IMACH(9) / 2147483647 / */
1319 /* DATA IMACH(10)/ 2 / */
1320 /* DATA IMACH(11)/ 24 / */
1321 /* DATA IMACH(12)/ -126 / */
1322 /* DATA IMACH(13)/ 127 / */
1323 /* DATA IMACH(14)/ 53 / */
1324 /* DATA IMACH(15)/ -1022 / */
1325 /* DATA IMACH(16)/ 1023 / */
1326 
1327 /* MACHINE CONSTANTS FOR THE APOLLO */
1328 
1329 /* DATA IMACH(1) / 5 / */
1330 /* DATA IMACH(2) / 6 / */
1331 /* DATA IMACH(3) / 6 / */
1332 /* DATA IMACH(4) / 6 / */
1333 /* DATA IMACH(5) / 32 / */
1334 /* DATA IMACH(6) / 4 / */
1335 /* DATA IMACH(7) / 2 / */
1336 /* DATA IMACH(8) / 31 / */
1337 /* DATA IMACH(9) / 2147483647 / */
1338 /* DATA IMACH(10)/ 2 / */
1339 /* DATA IMACH(11)/ 24 / */
1340 /* DATA IMACH(12)/ -125 / */
1341 /* DATA IMACH(13)/ 129 / */
1342 /* DATA IMACH(14)/ 53 / */
1343 /* DATA IMACH(15)/ -1021 / */
1344 /* DATA IMACH(16)/ 1025 / */
1345 
1346 /* MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM */
1347 
1348 /* DATA IMACH( 1) / 7 / */
1349 /* DATA IMACH( 2) / 2 / */
1350 /* DATA IMACH( 3) / 2 / */
1351 /* DATA IMACH( 4) / 2 / */
1352 /* DATA IMACH( 5) / 36 / */
1353 /* DATA IMACH( 6) / 4 / */
1354 /* DATA IMACH( 7) / 2 / */
1355 /* DATA IMACH( 8) / 33 / */
1356 /* DATA IMACH( 9) / Z1FFFFFFFF / */
1357 /* DATA IMACH(10) / 2 / */
1358 /* DATA IMACH(11) / 24 / */
1359 /* DATA IMACH(12) / -256 / */
1360 /* DATA IMACH(13) / 255 / */
1361 /* DATA IMACH(14) / 60 / */
1362 /* DATA IMACH(15) / -256 / */
1363 /* DATA IMACH(16) / 255 / */
1364 
1365 /* MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM */
1366 
1367 /* DATA IMACH( 1) / 5 / */
1368 /* DATA IMACH( 2) / 6 / */
1369 /* DATA IMACH( 3) / 7 / */
1370 /* DATA IMACH( 4) / 6 / */
1371 /* DATA IMACH( 5) / 48 / */
1372 /* DATA IMACH( 6) / 6 / */
1373 /* DATA IMACH( 7) / 2 / */
1374 /* DATA IMACH( 8) / 39 / */
1375 /* DATA IMACH( 9) / O0007777777777777 / */
1376 /* DATA IMACH(10) / 8 / */
1377 /* DATA IMACH(11) / 13 / */
1378 /* DATA IMACH(12) / -50 / */
1379 /* DATA IMACH(13) / 76 / */
1380 /* DATA IMACH(14) / 26 / */
1381 /* DATA IMACH(15) / -50 / */
1382 /* DATA IMACH(16) / 76 / */
1383 
1384 /* MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS */
1385 
1386 /* DATA IMACH( 1) / 5 / */
1387 /* DATA IMACH( 2) / 6 / */
1388 /* DATA IMACH( 3) / 7 / */
1389 /* DATA IMACH( 4) / 6 / */
1390 /* DATA IMACH( 5) / 48 / */
1391 /* DATA IMACH( 6) / 6 / */
1392 /* DATA IMACH( 7) / 2 / */
1393 /* DATA IMACH( 8) / 39 / */
1394 /* DATA IMACH( 9) / O0007777777777777 / */
1395 /* DATA IMACH(10) / 8 / */
1396 /* DATA IMACH(11) / 13 / */
1397 /* DATA IMACH(12) / -50 / */
1398 /* DATA IMACH(13) / 76 / */
1399 /* DATA IMACH(14) / 26 / */
1400 /* DATA IMACH(15) / -32754 / */
1401 /* DATA IMACH(16) / 32780 / */
1402 
1403 /* MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE */
1404 
1405 /* DATA IMACH( 1) / 5 / */
1406 /* DATA IMACH( 2) / 6 / */
1407 /* DATA IMACH( 3) / 7 / */
1408 /* DATA IMACH( 4) / 6 / */
1409 /* DATA IMACH( 5) / 64 / */
1410 /* DATA IMACH( 6) / 8 / */
1411 /* DATA IMACH( 7) / 2 / */
1412 /* DATA IMACH( 8) / 63 / */
1413 /* DATA IMACH( 9) / 9223372036854775807 / */
1414 /* DATA IMACH(10) / 2 / */
1415 /* DATA IMACH(11) / 47 / */
1416 /* DATA IMACH(12) / -4095 / */
1417 /* DATA IMACH(13) / 4094 / */
1418 /* DATA IMACH(14) / 94 / */
1419 /* DATA IMACH(15) / -4095 / */
1420 /* DATA IMACH(16) / 4094 / */
1421 
1422 /* MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES */
1423 
1424 /* DATA IMACH( 1) / 5 / */
1425 /* DATA IMACH( 2) / 6 / */
1426 /* DATA IMACH( 3) / 7 / */
1427 /* DATA IMACH( 4) /6LOUTPUT/ */
1428 /* DATA IMACH( 5) / 60 / */
1429 /* DATA IMACH( 6) / 10 / */
1430 /* DATA IMACH( 7) / 2 / */
1431 /* DATA IMACH( 8) / 48 / */
1432 /* DATA IMACH( 9) / 00007777777777777777B / */
1433 /* DATA IMACH(10) / 2 / */
1434 /* DATA IMACH(11) / 47 / */
1435 /* DATA IMACH(12) / -929 / */
1436 /* DATA IMACH(13) / 1070 / */
1437 /* DATA IMACH(14) / 94 / */
1438 /* DATA IMACH(15) / -929 / */
1439 /* DATA IMACH(16) / 1069 / */
1440 
1441 /* MACHINE CONSTANTS FOR THE CELERITY C1260 */
1442 
1443 /* DATA IMACH(1) / 5 / */
1444 /* DATA IMACH(2) / 6 / */
1445 /* DATA IMACH(3) / 6 / */
1446 /* DATA IMACH(4) / 0 / */
1447 /* DATA IMACH(5) / 32 / */
1448 /* DATA IMACH(6) / 4 / */
1449 /* DATA IMACH(7) / 2 / */
1450 /* DATA IMACH(8) / 31 / */
1451 /* DATA IMACH(9) / Z'7FFFFFFF' / */
1452 /* DATA IMACH(10)/ 2 / */
1453 /* DATA IMACH(11)/ 24 / */
1454 /* DATA IMACH(12)/ -126 / */
1455 /* DATA IMACH(13)/ 127 / */
1456 /* DATA IMACH(14)/ 53 / */
1457 /* DATA IMACH(15)/ -1022 / */
1458 /* DATA IMACH(16)/ 1023 / */
1459 
1460 /* MACHINE CONSTANTS FOR THE CONVEX C-1 */
1461 
1462 /* DATA IMACH( 1) / 5/ */
1463 /* DATA IMACH( 2) / 6/ */
1464 /* DATA IMACH( 3) / 7/ */
1465 /* DATA IMACH( 4) / 6/ */
1466 /* DATA IMACH( 5) / 32/ */
1467 /* DATA IMACH( 6) / 4/ */
1468 /* DATA IMACH( 7) / 2/ */
1469 /* DATA IMACH( 8) / 31/ */
1470 /* DATA IMACH( 9) /2147483647/ */
1471 /* DATA IMACH(10) / 2/ */
1472 /* DATA IMACH(11) / 24/ */
1473 /* DATA IMACH(12) / -128/ */
1474 /* DATA IMACH(13) / 127/ */
1475 /* DATA IMACH(14) / 53/ */
1476 /* DATA IMACH(15) / -1024/ */
1477 /* DATA IMACH(16) / 1023/ */
1478 
1479 /* MACHINE CONSTANTS FOR THE CRAY-1 */
1480 
1481 /* DATA IMACH( 1) / 100 / */
1482 /* DATA IMACH( 2) / 101 / */
1483 /* DATA IMACH( 3) / 102 / */
1484 /* DATA IMACH( 4) / 101 / */
1485 /* DATA IMACH( 5) / 64 / */
1486 /* DATA IMACH( 6) / 8 / */
1487 /* DATA IMACH( 7) / 2 / */
1488 /* DATA IMACH( 8) / 63 / */
1489 /* DATA IMACH( 9) / 777777777777777777777B / */
1490 /* DATA IMACH(10) / 2 / */
1491 /* DATA IMACH(11) / 47 / */
1492 /* DATA IMACH(12) / -8189 / */
1493 /* DATA IMACH(13) / 8190 / */
1494 /* DATA IMACH(14) / 94 / */
1495 /* DATA IMACH(15) / -8099 / */
1496 /* DATA IMACH(16) / 8190 / */
1497 
1498 /* MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200 */
1499 
1500 /* DATA IMACH( 1) / 11 / */
1501 /* DATA IMACH( 2) / 12 / */
1502 /* DATA IMACH( 3) / 8 / */
1503 /* DATA IMACH( 4) / 10 / */
1504 /* DATA IMACH( 5) / 16 / */
1505 /* DATA IMACH( 6) / 2 / */
1506 /* DATA IMACH( 7) / 2 / */
1507 /* DATA IMACH( 8) / 15 / */
1508 /* DATA IMACH( 9) /32767 / */
1509 /* DATA IMACH(10) / 16 / */
1510 /* DATA IMACH(11) / 6 / */
1511 /* DATA IMACH(12) / -64 / */
1512 /* DATA IMACH(13) / 63 / */
1513 /* DATA IMACH(14) / 14 / */
1514 /* DATA IMACH(15) / -64 / */
1515 /* DATA IMACH(16) / 63 / */
1516 
1517 /* MACHINE CONSTANTS FOR THE ELXSI 6400 */
1518 
1519 /* DATA IMACH( 1) / 5/ */
1520 /* DATA IMACH( 2) / 6/ */
1521 /* DATA IMACH( 3) / 6/ */
1522 /* DATA IMACH( 4) / 6/ */
1523 /* DATA IMACH( 5) / 32/ */
1524 /* DATA IMACH( 6) / 4/ */
1525 /* DATA IMACH( 7) / 2/ */
1526 /* DATA IMACH( 8) / 32/ */
1527 /* DATA IMACH( 9) /2147483647/ */
1528 /* DATA IMACH(10) / 2/ */
1529 /* DATA IMACH(11) / 24/ */
1530 /* DATA IMACH(12) / -126/ */
1531 /* DATA IMACH(13) / 127/ */
1532 /* DATA IMACH(14) / 53/ */
1533 /* DATA IMACH(15) / -1022/ */
1534 /* DATA IMACH(16) / 1023/ */
1535 
1536 /* MACHINE CONSTANTS FOR THE HARRIS 220 */
1537 
1538 /* DATA IMACH( 1) / 5 / */
1539 /* DATA IMACH( 2) / 6 / */
1540 /* DATA IMACH( 3) / 0 / */
1541 /* DATA IMACH( 4) / 6 / */
1542 /* DATA IMACH( 5) / 24 / */
1543 /* DATA IMACH( 6) / 3 / */
1544 /* DATA IMACH( 7) / 2 / */
1545 /* DATA IMACH( 8) / 23 / */
1546 /* DATA IMACH( 9) / 8388607 / */
1547 /* DATA IMACH(10) / 2 / */
1548 /* DATA IMACH(11) / 23 / */
1549 /* DATA IMACH(12) / -127 / */
1550 /* DATA IMACH(13) / 127 / */
1551 /* DATA IMACH(14) / 38 / */
1552 /* DATA IMACH(15) / -127 / */
1553 /* DATA IMACH(16) / 127 / */
1554 
1555 /* MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES */
1556 
1557 /* DATA IMACH( 1) / 5 / */
1558 /* DATA IMACH( 2) / 6 / */
1559 /* DATA IMACH( 3) / 43 / */
1560 /* DATA IMACH( 4) / 6 / */
1561 /* DATA IMACH( 5) / 36 / */
1562 /* DATA IMACH( 6) / 6 / */
1563 /* DATA IMACH( 7) / 2 / */
1564 /* DATA IMACH( 8) / 35 / */
1565 /* DATA IMACH( 9) / O377777777777 / */
1566 /* DATA IMACH(10) / 2 / */
1567 /* DATA IMACH(11) / 27 / */
1568 /* DATA IMACH(12) / -127 / */
1569 /* DATA IMACH(13) / 127 / */
1570 /* DATA IMACH(14) / 63 / */
1571 /* DATA IMACH(15) / -127 / */
1572 /* DATA IMACH(16) / 127 / */
1573 
1574 /* MACHINE CONSTANTS FOR THE HP 2100 */
1575 /* 3 WORD DOUBLE PRECISION OPTION WITH FTN4 */
1576 
1577 /* DATA IMACH(1) / 5/ */
1578 /* DATA IMACH(2) / 6 / */
1579 /* DATA IMACH(3) / 4 / */
1580 /* DATA IMACH(4) / 1 / */
1581 /* DATA IMACH(5) / 16 / */
1582 /* DATA IMACH(6) / 2 / */
1583 /* DATA IMACH(7) / 2 / */
1584 /* DATA IMACH(8) / 15 / */
1585 /* DATA IMACH(9) / 32767 / */
1586 /* DATA IMACH(10)/ 2 / */
1587 /* DATA IMACH(11)/ 23 / */
1588 /* DATA IMACH(12)/ -128 / */
1589 /* DATA IMACH(13)/ 127 / */
1590 /* DATA IMACH(14)/ 39 / */
1591 /* DATA IMACH(15)/ -128 / */
1592 /* DATA IMACH(16)/ 127 / */
1593 
1594 /* MACHINE CONSTANTS FOR THE HP 2100 */
1595 /* 4 WORD DOUBLE PRECISION OPTION WITH FTN4 */
1596 
1597 /* DATA IMACH(1) / 5 / */
1598 /* DATA IMACH(2) / 6 / */
1599 /* DATA IMACH(3) / 4 / */
1600 /* DATA IMACH(4) / 1 / */
1601 /* DATA IMACH(5) / 16 / */
1602 /* DATA IMACH(6) / 2 / */
1603 /* DATA IMACH(7) / 2 / */
1604 /* DATA IMACH(8) / 15 / */
1605 /* DATA IMACH(9) / 32767 / */
1606 /* DATA IMACH(10)/ 2 / */
1607 /* DATA IMACH(11)/ 23 / */
1608 /* DATA IMACH(12)/ -128 / */
1609 /* DATA IMACH(13)/ 127 / */
1610 /* DATA IMACH(14)/ 55 / */
1611 /* DATA IMACH(15)/ -128 / */
1612 /* DATA IMACH(16)/ 127 / */
1613 
1614 /* MACHINE CONSTANTS FOR THE HP 9000 */
1615 
1616 /* DATA IMACH(1) / 5 / */
1617 /* DATA IMACH(2) / 6 / */
1618 /* DATA IMACH(3) / 6 / */
1619 /* DATA IMACH(3) / 7 / */
1620 /* DATA IMACH(5) / 32 / */
1621 /* DATA IMACH(6) / 4 / */
1622 /* DATA IMACH(7) / 2 / */
1623 /* DATA IMACH(8) / 32 / */
1624 /* DATA IMACH(9) /2147483647 / */
1625 /* DATA IMACH(10) / 2 / */
1626 /* DATA IMACH(11) / 24 / */
1627 /* DATA IMACH(12) / -126 / */
1628 /* DATA IMACH(13) / 127 / */
1629 /* DATA IMACH(14) / 53 / */
1630 /* DATA IMACH(15) /-1015 / */
1631 /* DATA IMACH(16) / 1017 / */
1632 
1633 /* MACHINE CONSTANTS FOR THE IBM 360/370 SERIES, */
1634 /* THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND */
1635 /* THE PERKIN ELMER (INTERDATA) 7/32. */
1636 
1637 /* DATA IMACH( 1) / 5 / */
1638 /* DATA IMACH( 2) / 6 / */
1639 /* DATA IMACH( 3) / 7 / */
1640 /* DATA IMACH( 4) / 6 / */
1641 /* DATA IMACH( 5) / 32 / */
1642 /* DATA IMACH( 6) / 4 / */
1643 /* DATA IMACH( 7) / 16 / */
1644 /* DATA IMACH( 8) / 31 / */
1645 /* DATA IMACH( 9) / Z7FFFFFFF / */
1646 /* DATA IMACH(10) / 16 / */
1647 /* DATA IMACH(11) / 6 / */
1648 /* DATA IMACH(12) / -64 / */
1649 /* DATA IMACH(13) / 63 / */
1650 /* DATA IMACH(14) / 14 / */
1651 /* DATA IMACH(15) / -64 / */
1652 /* DATA IMACH(16) / 63 / */
1653 
1654 /* MACHINE CONSTANTS FOR THE IBM PC */
1655 
1656 
1657 /* MACHINE CONSTANTS FOR THE IBM RS 6000 */
1658 
1659 /* DATA IMACH( 1) / 5 / */
1660 /* DATA IMACH( 2) / 6 / */
1661 /* DATA IMACH( 3) / 6 / */
1662 /* DATA IMACH( 4) / 0 / */
1663 /* DATA IMACH( 5) / 32 / */
1664 /* DATA IMACH( 6) / 4 / */
1665 /* DATA IMACH( 7) / 2 / */
1666 /* DATA IMACH( 8) / 31 / */
1667 /* DATA IMACH( 9) / 2147483647 / */
1668 /* DATA IMACH(10) / 2 / */
1669 /* DATA IMACH(11) / 24 / */
1670 /* DATA IMACH(12) / -125 / */
1671 /* DATA IMACH(13) / 128 / */
1672 /* DATA IMACH(14) / 53 / */
1673 /* DATA IMACH(15) / -1021 / */
1674 /* DATA IMACH(16) / 1024 / */
1675 
1676 /* MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR) */
1677 
1678 /* DATA IMACH( 1) / 5 / */
1679 /* DATA IMACH( 2) / 6 / */
1680 /* DATA IMACH( 3) / 5 / */
1681 /* DATA IMACH( 4) / 6 / */
1682 /* DATA IMACH( 5) / 36 / */
1683 /* DATA IMACH( 6) / 5 / */
1684 /* DATA IMACH( 7) / 2 / */
1685 /* DATA IMACH( 8) / 35 / */
1686 /* DATA IMACH( 9) / "377777777777 / */
1687 /* DATA IMACH(10) / 2 / */
1688 /* DATA IMACH(11) / 27 / */
1689 /* DATA IMACH(12) / -128 / */
1690 /* DATA IMACH(13) / 127 / */
1691 /* DATA IMACH(14) / 54 / */
1692 /* DATA IMACH(15) / -101 / */
1693 /* DATA IMACH(16) / 127 / */
1694 
1695 /* MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR) */
1696 
1697 /* DATA IMACH( 1) / 5 / */
1698 /* DATA IMACH( 2) / 6 / */
1699 /* DATA IMACH( 3) / 5 / */
1700 /* DATA IMACH( 4) / 6 / */
1701 /* DATA IMACH( 5) / 36 / */
1702 /* DATA IMACH( 6) / 5 / */
1703 /* DATA IMACH( 7) / 2 / */
1704 /* DATA IMACH( 8) / 35 / */
1705 /* DATA IMACH( 9) / "377777777777 / */
1706 /* DATA IMACH(10) / 2 / */
1707 /* DATA IMACH(11) / 27 / */
1708 /* DATA IMACH(12) / -128 / */
1709 /* DATA IMACH(13) / 127 / */
1710 /* DATA IMACH(14) / 62 / */
1711 /* DATA IMACH(15) / -128 / */
1712 /* DATA IMACH(16) / 127 / */
1713 
1714 /* MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING */
1715 /* 32-BIT INTEGER ARITHMETIC. */
1716 
1717 /* DATA IMACH( 1) / 5 / */
1718 /* DATA IMACH( 2) / 6 / */
1719 /* DATA IMACH( 3) / 5 / */
1720 /* DATA IMACH( 4) / 6 / */
1721 /* DATA IMACH( 5) / 32 / */
1722 /* DATA IMACH( 6) / 4 / */
1723 /* DATA IMACH( 7) / 2 / */
1724 /* DATA IMACH( 8) / 31 / */
1725 /* DATA IMACH( 9) / 2147483647 / */
1726 /* DATA IMACH(10) / 2 / */
1727 /* DATA IMACH(11) / 24 / */
1728 /* DATA IMACH(12) / -127 / */
1729 /* DATA IMACH(13) / 127 / */
1730 /* DATA IMACH(14) / 56 / */
1731 /* DATA IMACH(15) / -127 / */
1732 /* DATA IMACH(16) / 127 / */
1733 
1734 /* MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING */
1735 /* 16-BIT INTEGER ARITHMETIC. */
1736 
1737 /* DATA IMACH( 1) / 5 / */
1738 /* DATA IMACH( 2) / 6 / */
1739 /* DATA IMACH( 3) / 5 / */
1740 /* DATA IMACH( 4) / 6 / */
1741 /* DATA IMACH( 5) / 16 / */
1742 /* DATA IMACH( 6) / 2 / */
1743 /* DATA IMACH( 7) / 2 / */
1744 /* DATA IMACH( 8) / 15 / */
1745 /* DATA IMACH( 9) / 32767 / */
1746 /* DATA IMACH(10) / 2 / */
1747 /* DATA IMACH(11) / 24 / */
1748 /* DATA IMACH(12) / -127 / */
1749 /* DATA IMACH(13) / 127 / */
1750 /* DATA IMACH(14) / 56 / */
1751 /* DATA IMACH(15) / -127 / */
1752 /* DATA IMACH(16) / 127 / */
1753 
1754 /* MACHINE CONSTANTS FOR THE SILICON GRAPHICS IRIS */
1755 
1756 /* DATA IMACH( 1) / 5 / */
1757 /* DATA IMACH( 2) / 6 / */
1758 /* DATA IMACH( 3) / 6 / */
1759 /* DATA IMACH( 4) / 0 / */
1760 /* DATA IMACH( 5) / 32 / */
1761 /* DATA IMACH( 6) / 4 / */
1762 /* DATA IMACH( 7) / 2 / */
1763 /* DATA IMACH( 8) / 31 / */
1764 /* DATA IMACH( 9) / 2147483647 / */
1765 /* DATA IMACH(10) / 2 / */
1766 /* DATA IMACH(11) / 23 / */
1767 /* DATA IMACH(12) / -126 / */
1768 /* DATA IMACH(13) / 127 / */
1769 /* DATA IMACH(14) / 52 / */
1770 /* DATA IMACH(15) / -1022 / */
1771 /* DATA IMACH(16) / 1023 / */
1772 
1773 /* MACHINE CONSTANTS FOR THE SUN */
1774 
1775 /* DATA IMACH(1) / 5 / */
1776 /* DATA IMACH(2) / 6 / */
1777 /* DATA IMACH(3) / 6 / */
1778 /* DATA IMACH(4) / 6 / */
1779 /* DATA IMACH(5) / 32 / */
1780 /* DATA IMACH(6) / 4 / */
1781 /* DATA IMACH(7) / 2 / */
1782 /* DATA IMACH(8) / 31 / */
1783 /* DATA IMACH(9) /2147483647 / */
1784 /* DATA IMACH(10)/ 2 / */
1785 /* DATA IMACH(11)/ 24 / */
1786 /* DATA IMACH(12)/ -125 / */
1787 /* DATA IMACH(13)/ 128 / */
1788 /* DATA IMACH(14)/ 53 / */
1789 /* DATA IMACH(15)/ -1021 / */
1790 /* DATA IMACH(16)/ 1024 / */
1791 
1792 /* MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER */
1793 
1794 
1795 /* DATA IMACH( 1) / 5 / */
1796 /* DATA IMACH( 2) / 6 / */
1797 /* DATA IMACH( 3) / 1 / */
1798 /* DATA IMACH( 4) / 6 / */
1799 /* DATA IMACH( 5) / 36 / */
1800 /* DATA IMACH( 6) / 4 / */
1801 /* DATA IMACH( 7) / 2 / */
1802 /* DATA IMACH( 8) / 35 / */
1803 /* DATA IMACH( 9) / O377777777777 / */
1804 /* DATA IMACH(10) / 2 / */
1805 /* DATA IMACH(11) / 27 / */
1806 /* DATA IMACH(12) / -128 / */
1807 /* DATA IMACH(13) / 127 / */
1808 /* DATA IMACH(14) / 60 / */
1809 /* DATA IMACH(15) /-1024 / */
1810 /* DATA IMACH(16) / 1023 / */
1811 
1812 /* MACHINE CONSTANTS FOR THE VAX 11/780 */
1813 
1814 /* DATA IMACH(1) / 5 / */
1815 /* DATA IMACH(2) / 6 / */
1816 /* DATA IMACH(3) / 5 / */
1817 /* DATA IMACH(4) / 6 / */
1818 /* DATA IMACH(5) / 32 / */
1819 /* DATA IMACH(6) / 4 / */
1820 /* DATA IMACH(7) / 2 / */
1821 /* DATA IMACH(8) / 31 / */
1822 /* DATA IMACH(9) /2147483647 / */
1823 /* DATA IMACH(10)/ 2 / */
1824 /* DATA IMACH(11)/ 24 / */
1825 /* DATA IMACH(12)/ -127 / */
1826 /* DATA IMACH(13)/ 127 / */
1827 /* DATA IMACH(14)/ 56 / */
1828 /* DATA IMACH(15)/ -127 / */
1829 /* DATA IMACH(16)/ 127 / */
1830 
1831 /* MACHINE CONSTANTS FOR THE VAX 11/780, G-FLOAT OPTION */
1832 
1833 /* DATA IMACH(1) / 5 / */
1834 /* DATA IMACH(2) / 6 / */
1835 /* DATA IMACH(3) / 5 / */
1836 /* DATA IMACH(4) / 6 / */
1837 /* DATA IMACH(5) / 32 / */
1838 /* DATA IMACH(6) / 4 / */
1839 /* DATA IMACH(7) / 2 / */
1840 /* DATA IMACH(8) / 31 / */
1841 /* DATA IMACH(9) /2147483647 / */
1842 /* DATA IMACH(10)/ 2 / */
1843 /* DATA IMACH(11)/ 24 / */
1844 /* DATA IMACH(12)/ -127 / */
1845 /* DATA IMACH(13)/ 127 / */
1846 /* DATA IMACH(14)/ 53 / */
1847 /* DATA IMACH(15)/ -1022 / */
1848 /* DATA IMACH(16)/ 1023 / */
1849 
1850 /* MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR */
1851 
1852 /* DATA IMACH( 1) / 1/ */
1853 /* DATA IMACH( 2) / 1/ */
1854 /* DATA IMACH( 3) / 0/ */
1855 /* DATA IMACH( 4) / 1/ */
1856 /* DATA IMACH( 5) / 16/ */
1857 /* DATA IMACH( 6) / 2/ */
1858 /* DATA IMACH( 7) / 2/ */
1859 /* DATA IMACH( 8) / 15/ */
1860 /* DATA IMACH( 9) / 32767/ */
1861 /* DATA IMACH(10) / 2/ */
1862 /* DATA IMACH(11) / 24/ */
1863 /* DATA IMACH(12) / -127/ */
1864 /* DATA IMACH(13) / 127/ */
1865 /* DATA IMACH(14) / 56/ */
1866 /* DATA IMACH(15) / -127/ */
1867 /* DATA IMACH(16) / 127/ */
1868 
1869 
1870 /* ***FIRST EXECUTABLE STATEMENT I1MACH */
1871  if (*i__ < 1 || *i__ > 16) {
1872  goto L10;
1873  }
1874 
1875  ret_val = imach[*i__ - 1];
1876  return ret_val;
1877 
1878 L10:
1879  io___72.ciunit = *output;
1880  s_wsfe(&io___72);
1881  e_wsfe();
1882 
1883 /* CALL FDUMP */
1884 
1885 
1886  s_stop("", (ftnlen)0);
1887  return ret_val;
1888 } /* i1mach_ */
1889 
1890 #undef output
1891 #undef imach
1892 
1893 
1894 /* Subroutine */
1895 int xerror_(char* mess, integer* nmess,
1896  integer* l1, integer* l2, ftnlen mess_len)
1897 {
1898  /* Format strings */
1899  static char fmt_900[] = "(/)";
1900 
1901  /* System generated locals */
1902  integer i__1, i__2;
1903 
1904  /* Builtin functions */
1905 
1906  /* Local variables */
1907  static integer kmin, i__, k, nn, nr;
1908 
1909  /* Fortran I/O blocks */
1910  static cilist io___76 = { 0, 6, 0, fmt_900, 0 };
1911  static cilist io___79 = { 0, 6, 0, 0, 0 };
1912  static cilist io___80 = { 0, 6, 0, fmt_900, 0 };
1913 
1914 
1915 
1916 /* THIS IS A DUMMY XERROR ROUTINE TO PRINT ERROR MESSAGES WITH NMESS */
1917 /* CHARACTERS. L1 AND L2 ARE DUMMY PARAMETERS TO MAKE THIS CALL */
1918 /* COMPATIBLE WITH THE SLATEC XERROR ROUTINE. THIS IS A FORTRAN 77 */
1919 /* ROUTINE. */
1920 
1921  nn = *nmess / 70;
1922  nr = *nmess - nn * 70;
1923  if (nr != 0) {
1924  ++nn;
1925  }
1926  k = 1;
1927  s_wsfe(&io___76);
1928  e_wsfe();
1929  i__1 = nn;
1930  for (i__ = 1; i__ <= i__1; ++i__) {
1931 /* Computing MIN */
1932  i__2 = k + 69;
1933  kmin = min(i__2,*nmess);
1934  s_wsle(&io___79);
1935  do_lio(&c__9, &c__1, mess + (k - 1), kmin - (k - 1));
1936  e_wsle();
1937  k += 70;
1938 /* L10: */
1939  }
1940  s_wsfe(&io___80);
1941  e_wsfe();
1942  return 0;
1943 } /* xerror_ */
1944 
1945 doublereal myzabs_(const doublereal* zr, const doublereal* zi)
1946 {
1947  /* System generated locals */
1948  doublereal ret_val;
1949 
1950  /* Builtin functions */
1951 
1952  /* Local variables */
1953  static doublereal q, s, u, v;
1954 
1955 /* ***BEGIN PROLOGUE myzabs */
1956 /* ***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY */
1957 
1958 /* myzabs COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE */
1959 /* PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI) */
1960 
1961 /* ***ROUTINES CALLED (NONE) */
1962 /* ***END PROLOGUE myzabs */
1963  u = abs(*zr);
1964  v = abs(*zi);
1965  s = u + v;
1966 /* ----------------------------------------------------------------------- */
1967 /* S*1.0D0 MAKES AN UNNORMALIZED UNDERFLOW ON CDC MACHINES INTO A */
1968 /* TRUE FLOATING ZERO */
1969 /* ----------------------------------------------------------------------- */
1970  s *= 1.;
1971  if (s == 0.) {
1972  goto L20;
1973  }
1974  if (u > v) {
1975  goto L10;
1976  }
1977  q = u / v;
1978  ret_val = v * sqrt(q * q + 1.);
1979  return ret_val;
1980 L10:
1981  q = v / u;
1982  ret_val = u * sqrt(q * q + 1.);
1983  return ret_val;
1984 L20:
1985  ret_val = 0.;
1986  return ret_val;
1987 } /* myzabs_ */
1988 
1989 /* Subroutine */
1990 int zacai_(doublereal* zr, doublereal* zi, doublereal* fnu,
1991  integer* kode, integer* mr, integer* n,
1992  doublereal* yr, doublereal* yi,
1993  integer* nz,
1994  doublereal* rl, doublereal*tol,
1995  doublereal* elim, doublereal* alim)
1996 {
1997  /* Initialized data */
1998 
1999  static doublereal pi = 3.14159265358979324;
2000 
2001  /* Builtin functions */
2002 
2003  /* Local variables */
2004  static doublereal dfnu;
2005  static doublereal az;
2006  static integer nn, nw;
2007  static doublereal yy, c1i, c2i;
2008  static doublereal c1r, c2r, arg;
2009  static integer iuf;
2010  static doublereal cyi[2], fmr, sgn;
2011  static integer inu;
2012  static doublereal cyr[2], zni, znr;
2013 
2014 /* ***BEGIN PROLOGUE ZACAI */
2015 /* ***REFER TO ZAIRY */
2016 
2017 /* ZACAI APPLIES THE ANALYTIC CONTINUATION FORMULA */
2018 
2019 /* K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) */
2020 /* MP=PI*MR*CMPLX(0.0,1.0) */
2021 
2022 /* TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT */
2023 /* HALF Z PLANE FOR USE WITH ZAIRY WHERE FNU=1/3 OR 2/3 AND N=1. */
2024 /* ZACAI IS THE SAME AS ZACON WITH THE PARTS FOR LARGER ORDERS AND */
2025 /* RECURRENCE REMOVED. A RECURSIVE CALL TO ZACON CAN RESULT IF ZACON */
2026 /* IS CALLED FROM ZAIRY. */
2027 
2028 /* ***ROUTINES CALLED ZASYI,ZBKNU,ZMLRI,ZSERI,ZS1S2,D1MACH,myzabs */
2029 /* ***END PROLOGUE ZACAI */
2030 /* COMPLEX CSGN,CSPN,C1,C2,Y,Z,ZN,CY */
2031  /* Parameter adjustments */
2032  --yi;
2033  --yr;
2034 
2035  /* Function Body */
2036  *nz = 0;
2037  znr = -(*zr);
2038  zni = -(*zi);
2039  az = myzabs_(zr, zi);
2040  nn = *n;
2041  dfnu = *fnu + (doublereal) ((real) (*n - 1));
2042  if (az <= 2.) {
2043  goto L10;
2044  }
2045  if (az * az * .25 > dfnu + 1.) {
2046  goto L20;
2047  }
2048 L10:
2049 /* ----------------------------------------------------------------------- */
2050 /* POWER SERIES FOR THE I FUNCTION */
2051 /* ----------------------------------------------------------------------- */
2052  zseri_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, tol, elim, alim);
2053  goto L40;
2054 L20:
2055  if (az < *rl) {
2056  goto L30;
2057  }
2058 /* ----------------------------------------------------------------------- */
2059 /* ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I FUNCTION */
2060 /* ----------------------------------------------------------------------- */
2061  zasyi_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, rl, tol, elim,
2062  alim);
2063  if (nw < 0) {
2064  goto L80;
2065  }
2066  goto L40;
2067 L30:
2068 /* ----------------------------------------------------------------------- */
2069 /* MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION */
2070 /* ----------------------------------------------------------------------- */
2071  zmlri_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, tol);
2072  if (nw < 0) {
2073  goto L80;
2074  }
2075 L40:
2076 /* ----------------------------------------------------------------------- */
2077 /* ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION */
2078 /* ----------------------------------------------------------------------- */
2079  zbknu_(&znr, &zni, fnu, kode, &c__1, cyr, cyi, &nw, tol, elim, alim);
2080  if (nw != 0) {
2081  goto L80;
2082  }
2083  fmr = (doublereal) ((real) (*mr));
2084  sgn = -d_sign(&pi, &fmr);
2085  csgnr = 0.;
2086  csgni = sgn;
2087  if (*kode == 1) {
2088  goto L50;
2089  }
2090  yy = -zni;
2091  csgnr = -csgni * sin(yy);
2092  csgni *= cos(yy);
2093 L50:
2094 /* ----------------------------------------------------------------------- */
2095 /* CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE */
2096 /* WHEN FNU IS LARGE */
2097 /* ----------------------------------------------------------------------- */
2098  inu = (integer) ((real) (*fnu));
2099  arg = (*fnu - (doublereal) ((real) inu)) * sgn;
2100  cspnr = cos(arg);
2101  cspni = sin(arg);
2102  if (inu % 2 == 0) {
2103  goto L60;
2104  }
2105  cspnr = -cspnr;
2106  cspni = -cspni;
2107 L60:
2108  c1r = cyr[0];
2109  c1i = cyi[0];
2110  c2r = yr[1];
2111  c2i = yi[1];
2112  if (*kode == 1) {
2113  goto L70;
2114  }
2115  iuf = 0;
2116  ascle = d1mach_(&c__1) * 1e3 / *tol;
2117  zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
2118  *nz += nw;
2119 L70:
2120  yr[1] = cspnr * c1r - cspni * c1i + csgnr * c2r - csgni * c2i;
2121  yi[1] = cspnr * c1i + cspni * c1r + csgnr * c2i + csgni * c2r;
2122  return 0;
2123 L80:
2124  *nz = -1;
2125  if (nw == -2) {
2126  *nz = -2;
2127  }
2128  return 0;
2129 } /* zacai_ */
2130 
2131 /* Subroutine */ int zacon_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *rl, doublereal *fnul, doublereal *tol, doublereal *elim, doublereal *alim)
2132 {
2133  /* Initialized data */
2134 
2135  static doublereal pi = 3.14159265358979324;
2136  static doublereal zeror = 0.;
2137  static doublereal coner = 1.;
2138 
2139  /* System generated locals */
2140  integer i__1;
2141 
2142  /* Builtin functions */
2143 
2144  /* Local variables */
2145  static doublereal cscl, cscr, csrr[3], cssr[3], razn;
2146  static integer i__, kflag;
2147  static doublereal ascle, bscle, csgni, csgnr, cspni, cspnr;
2148  static doublereal fn;
2149  static integer nn, nw;
2150  static doublereal yy, c1i, c2i, c1m;
2151  static doublereal as2, c1r, c2r, s1i, s2i, s1r, s2r, cki, arg, ckr, cpn;
2152  static integer iuf;
2153  static doublereal cyi[2], fmr, csr, azn, sgn;
2154  static integer inu;
2155  static doublereal bry[3], cyr[2], pti, spn, sti, zni, rzi, ptr, str, znr,
2156  rzr, sc1i, sc2i, sc1r, sc2r;
2157 
2158 /* ***BEGIN PROLOGUE ZACON */
2159 /* ***REFER TO ZBESK,ZBESH */
2160 
2161 /* ZACON APPLIES THE ANALYTIC CONTINUATION FORMULA */
2162 
2163 /* K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) */
2164 /* MP=PI*MR*CMPLX(0.0,1.0) */
2165 
2166 /* TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT */
2167 /* HALF Z PLANE */
2168 
2169 /* ***ROUTINES CALLED ZBINU,ZBKNU,ZS1S2,D1MACH,myzabs,ZMLT */
2170 /* ***END PROLOGUE ZACON */
2171 /* COMPLEX CK,CONE,CSCL,CSCR,CSGN,CSPN,CY,CZERO,C1,C2,RZ,SC1,SC2,ST, */
2172 /* *S1,S2,Y,Z,ZN */
2173  /* Parameter adjustments */
2174  --yi;
2175  --yr;
2176 
2177  /* Function Body */
2178  *nz = 0;
2179  znr = -(*zr);
2180  zni = -(*zi);
2181  nn = *n;
2182  zbinu_(&znr, &zni, fnu, kode, &nn, &yr[1], &yi[1], &nw, rl, fnul, tol,
2183  elim, alim);
2184  if (nw < 0) {
2185  goto L90;
2186  }
2187 /* ----------------------------------------------------------------------- */
2188 /* ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION */
2189 /* ----------------------------------------------------------------------- */
2190  nn = min(2,*n);
2191  zbknu_(&znr, &zni, fnu, kode, &nn, cyr, cyi, &nw, tol, elim, alim);
2192  if (nw != 0) {
2193  goto L90;
2194  }
2195  s1r = cyr[0];
2196  s1i = cyi[0];
2197  fmr = (doublereal) ((real) (*mr));
2198  sgn = -d_sign(&pi, &fmr);
2199  csgnr = zeror;
2200  csgni = sgn;
2201  if (*kode == 1) {
2202  goto L10;
2203  }
2204  yy = -zni;
2205  cpn = cos(yy);
2206  spn = sin(yy);
2207  zmlt_(&csgnr, &csgni, &cpn, &spn, &csgnr, &csgni);
2208 L10:
2209 /* ----------------------------------------------------------------------- */
2210 /* CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE */
2211 /* WHEN FNU IS LARGE */
2212 /* ----------------------------------------------------------------------- */
2213  inu = (integer) ((real) (*fnu));
2214  arg = (*fnu - (doublereal) ((real) inu)) * sgn;
2215  cpn = cos(arg);
2216  spn = sin(arg);
2217  cspnr = cpn;
2218  cspni = spn;
2219  if (inu % 2 == 0) {
2220  goto L20;
2221  }
2222  cspnr = -cspnr;
2223  cspni = -cspni;
2224 L20:
2225  iuf = 0;
2226  c1r = s1r;
2227  c1i = s1i;
2228  c2r = yr[1];
2229  c2i = yi[1];
2230  ascle = d1mach_(&c__1) * 1e3 / *tol;
2231  if (*kode == 1) {
2232  goto L30;
2233  }
2234  zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
2235  *nz += nw;
2236  sc1r = c1r;
2237  sc1i = c1i;
2238 L30:
2239  zmlt_(&cspnr, &cspni, &c1r, &c1i, &str, &sti);
2240  zmlt_(&csgnr, &csgni, &c2r, &c2i, &ptr, &pti);
2241  yr[1] = str + ptr;
2242  yi[1] = sti + pti;
2243  if (*n == 1) {
2244  return 0;
2245  }
2246  cspnr = -cspnr;
2247  cspni = -cspni;
2248  s2r = cyr[1];
2249  s2i = cyi[1];
2250  c1r = s2r;
2251  c1i = s2i;
2252  c2r = yr[2];
2253  c2i = yi[2];
2254  if (*kode == 1) {
2255  goto L40;
2256  }
2257  zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
2258  *nz += nw;
2259  sc2r = c1r;
2260  sc2i = c1i;
2261 L40:
2262  zmlt_(&cspnr, &cspni, &c1r, &c1i, &str, &sti);
2263  zmlt_(&csgnr, &csgni, &c2r, &c2i, &ptr, &pti);
2264  yr[2] = str + ptr;
2265  yi[2] = sti + pti;
2266  if (*n == 2) {
2267  return 0;
2268  }
2269  cspnr = -cspnr;
2270  cspni = -cspni;
2271  azn = myzabs_(&znr, &zni);
2272  razn = 1. / azn;
2273  str = znr * razn;
2274  sti = -zni * razn;
2275  rzr = (str + str) * razn;
2276  rzi = (sti + sti) * razn;
2277  fn = *fnu + 1.;
2278  ckr = fn * rzr;
2279  cki = fn * rzi;
2280 /* ----------------------------------------------------------------------- */
2281 /* SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS */
2282 /* ----------------------------------------------------------------------- */
2283  cscl = 1. / *tol;
2284  cscr = *tol;
2285  cssr[0] = cscl;
2286  cssr[1] = coner;
2287  cssr[2] = cscr;
2288  csrr[0] = cscr;
2289  csrr[1] = coner;
2290  csrr[2] = cscl;
2291  bry[0] = ascle;
2292  bry[1] = 1. / ascle;
2293  bry[2] = d1mach_(&c__2);
2294  as2 = myzabs_(&s2r, &s2i);
2295  kflag = 2;
2296  if (as2 > bry[0]) {
2297  goto L50;
2298  }
2299  kflag = 1;
2300  goto L60;
2301 L50:
2302  if (as2 < bry[1]) {
2303  goto L60;
2304  }
2305  kflag = 3;
2306 L60:
2307  bscle = bry[kflag - 1];
2308  s1r *= cssr[kflag - 1];
2309  s1i *= cssr[kflag - 1];
2310  s2r *= cssr[kflag - 1];
2311  s2i *= cssr[kflag - 1];
2312  csr = csrr[kflag - 1];
2313  i__1 = *n;
2314  for (i__ = 3; i__ <= i__1; ++i__) {
2315  str = s2r;
2316  sti = s2i;
2317  s2r = ckr * str - cki * sti + s1r;
2318  s2i = ckr * sti + cki * str + s1i;
2319  s1r = str;
2320  s1i = sti;
2321  c1r = s2r * csr;
2322  c1i = s2i * csr;
2323  str = c1r;
2324  sti = c1i;
2325  c2r = yr[i__];
2326  c2i = yi[i__];
2327  if (*kode == 1) {
2328  goto L70;
2329  }
2330  if (iuf < 0) {
2331  goto L70;
2332  }
2333  zs1s2_(&znr, &zni, &c1r, &c1i, &c2r, &c2i, &nw, &ascle, alim, &iuf);
2334  *nz += nw;
2335  sc1r = sc2r;
2336  sc1i = sc2i;
2337  sc2r = c1r;
2338  sc2i = c1i;
2339  if (iuf != 3) {
2340  goto L70;
2341  }
2342  iuf = -4;
2343  s1r = sc1r * cssr[kflag - 1];
2344  s1i = sc1i * cssr[kflag - 1];
2345  s2r = sc2r * cssr[kflag - 1];
2346  s2i = sc2i * cssr[kflag - 1];
2347  str = sc2r;
2348  sti = sc2i;
2349 L70:
2350  ptr = cspnr * c1r - cspni * c1i;
2351  pti = cspnr * c1i + cspni * c1r;
2352  yr[i__] = ptr + csgnr * c2r - csgni * c2i;
2353  yi[i__] = pti + csgnr * c2i + csgni * c2r;
2354  ckr += rzr;
2355  cki += rzi;
2356  cspnr = -cspnr;
2357  cspni = -cspni;
2358  if (kflag >= 3) {
2359  goto L80;
2360  }
2361  ptr = abs(c1r);
2362  pti = abs(c1i);
2363  c1m = max(ptr,pti);
2364  if (c1m <= bscle) {
2365  goto L80;
2366  }
2367  ++kflag;
2368  bscle = bry[kflag - 1];
2369  s1r *= csr;
2370  s1i *= csr;
2371  s2r = str;
2372  s2i = sti;
2373  s1r *= cssr[kflag - 1];
2374  s1i *= cssr[kflag - 1];
2375  s2r *= cssr[kflag - 1];
2376  s2i *= cssr[kflag - 1];
2377  csr = csrr[kflag - 1];
2378 L80:
2379  ;
2380  }
2381  return 0;
2382 L90:
2383  *nz = -1;
2384  if (nw == -2) {
2385  *nz = -2;
2386  }
2387  return 0;
2388 } /* zacon_ */
2389 
2390 /* Subroutine */
2391 int zasyi_(doublereal *zr, doublereal *zi, doublereal *fnu,
2392  integer *kode, integer *n,
2393  doublereal *yr, doublereal *yi, integer *nz,
2394  doublereal *rl, doublereal *tol,
2395  doublereal *elim, doublereal *alim)
2396 {
2397  /* Initialized data */
2398 
2399  static doublereal pi = 3.14159265358979324;
2400  static doublereal rtpi = .159154943091895336;
2401  static doublereal zeror = 0.;
2402  static doublereal zeroi = 0.;
2403  static doublereal coner = 1.;
2404  static doublereal conei = 0.;
2405 
2406  /* System generated locals */
2407  integer i__1, i__2;
2408  doublereal d__1, d__2;
2409 
2410  /* Builtin functions */
2411 
2412  /* Local variables */
2413  static doublereal dfnu, atol;
2414  static integer i__, j, k, m;
2415  static doublereal s;
2416  static integer koded;
2417  static doublereal aa, bb;
2418  static integer ib;
2419  static doublereal ak, bk;
2420  static integer il, jl;
2421  static doublereal az;
2422  static integer nn;
2423  static doublereal p1i, s2i, p1r, s2r, cki, dki, fdn, arg, aez, arm, ckr,
2424  dkr, czi, ezi, sgn;
2425  static integer inu;
2426  static doublereal raz, czr, ezr, sqk, sti, rzi, tzi, str, rzr, tzr, ak1i,
2427  ak1r, cs1i, cs2i, cs1r, cs2r, dnu2, rtr1;
2428 
2429 /* ***BEGIN PROLOGUE ZASYI */
2430 /* ***REFER TO ZBESI,ZBESK */
2431 
2432 /* ZASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY */
2433 /* MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z) IN THE */
2434 /* REGION CABS(Z).GT.MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL RETURN. */
2435 /* NZ.LT.0 INDICATES AN OVERFLOW ON KODE=1. */
2436 
2437 /* ***ROUTINES CALLED D1MACH,myzabs,ZDIV,ZEXP,ZMLT,ZSQRT */
2438 /* ***END PROLOGUE ZASYI */
2439 /* COMPLEX AK1,CK,CONE,CS1,CS2,CZ,CZERO,DK,EZ,P1,RZ,S2,Y,Z */
2440  /* Parameter adjustments */
2441  --yi;
2442  --yr;
2443 
2444  /* Function Body */
2445 
2446  *nz = 0;
2447  az = myzabs_(zr, zi);
2448  arm = d1mach_(&c__1) * 1e3;
2449  rtr1 = sqrt(arm);
2450  il = min(2,*n);
2451  dfnu = *fnu + (doublereal) ((real) (*n - il));
2452 /* ----------------------------------------------------------------------- */
2453 /* OVERFLOW TEST */
2454 /* ----------------------------------------------------------------------- */
2455  raz = 1. / az;
2456  str = *zr * raz;
2457  sti = -(*zi) * raz;
2458  ak1r = rtpi * str * raz;
2459  ak1i = rtpi * sti * raz;
2460  zsqrt_(&ak1r, &ak1i, &ak1r, &ak1i);
2461  czr = *zr;
2462  czi = *zi;
2463  if (*kode != 2) {
2464  goto L10;
2465  }
2466  czr = zeror;
2467  czi = *zi;
2468 L10:
2469  if (abs(czr) > *elim) {
2470  goto L100;
2471  }
2472  dnu2 = dfnu + dfnu;
2473  koded = 1;
2474  if (abs(czr) > *alim && *n > 2) {
2475  goto L20;
2476  }
2477  koded = 0;
2478  zexp_(&czr, &czi, &str, &sti);
2479  zmlt_(&ak1r, &ak1i, &str, &sti, &ak1r, &ak1i);
2480 L20:
2481  fdn = 0.;
2482  if (dnu2 > rtr1) {
2483  fdn = dnu2 * dnu2;
2484  }
2485  ezr = *zr * 8.;
2486  ezi = *zi * 8.;
2487 /* ----------------------------------------------------------------------- */
2488 /* WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO THE */
2489 /* FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF THE */
2490 /* EXPANSION FOR THE IMAGINARY PART. */
2491 /* ----------------------------------------------------------------------- */
2492  aez = az * 8.;
2493  s = *tol / aez;
2494  jl = (integer) ((real) (*rl + *rl)) + 2;
2495  p1r = zeror;
2496  p1i = zeroi;
2497  if (*zi == 0.) {
2498  goto L30;
2499  }
2500 /* ----------------------------------------------------------------------- */
2501 /* CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF */
2502 /* SIGNIFICANCE WHEN FNU OR N IS LARGE */
2503 /* ----------------------------------------------------------------------- */
2504  inu = (integer) ((real) (*fnu));
2505  arg = (*fnu - (doublereal) ((real) inu)) * pi;
2506  inu = inu + *n - il;
2507  ak = -sin(arg);
2508  bk = cos(arg);
2509  if (*zi < 0.) {
2510  bk = -bk;
2511  }
2512  p1r = ak;
2513  p1i = bk;
2514  if (inu % 2 == 0) {
2515  goto L30;
2516  }
2517  p1r = -p1r;
2518  p1i = -p1i;
2519 L30:
2520  i__1 = il;
2521  for (k = 1; k <= i__1; ++k) {
2522  sqk = fdn - 1.;
2523  atol = s * abs(sqk);
2524  sgn = 1.;
2525  cs1r = coner;
2526  cs1i = conei;
2527  cs2r = coner;
2528  cs2i = conei;
2529  ckr = coner;
2530  cki = conei;
2531  ak = 0.;
2532  aa = 1.;
2533  bb = aez;
2534  dkr = ezr;
2535  dki = ezi;
2536  i__2 = jl;
2537  for (j = 1; j <= i__2; ++j) {
2538  zdiv_(&ckr, &cki, &dkr, &dki, &str, &sti);
2539  ckr = str * sqk;
2540  cki = sti * sqk;
2541  cs2r += ckr;
2542  cs2i += cki;
2543  sgn = -sgn;
2544  cs1r += ckr * sgn;
2545  cs1i += cki * sgn;
2546  dkr += ezr;
2547  dki += ezi;
2548  aa = aa * abs(sqk) / bb;
2549  bb += aez;
2550  ak += 8.;
2551  sqk -= ak;
2552  if (aa <= atol) {
2553  goto L50;
2554  }
2555 /* L40: */
2556  }
2557  goto L110;
2558 L50:
2559  s2r = cs1r;
2560  s2i = cs1i;
2561  if (*zr + *zr >= *elim) {
2562  goto L60;
2563  }
2564  tzr = *zr + *zr;
2565  tzi = *zi + *zi;
2566  d__1 = -tzr;
2567  d__2 = -tzi;
2568  zexp_(&d__1, &d__2, &str, &sti);
2569  zmlt_(&str, &sti, &p1r, &p1i, &str, &sti);
2570  zmlt_(&str, &sti, &cs2r, &cs2i, &str, &sti);
2571  s2r += str;
2572  s2i += sti;
2573 L60:
2574  fdn = fdn + dfnu * 8. + 4.;
2575  p1r = -p1r;
2576  p1i = -p1i;
2577  m = *n - il + k;
2578  yr[m] = s2r * ak1r - s2i * ak1i;
2579  yi[m] = s2r * ak1i + s2i * ak1r;
2580 /* L70: */
2581  }
2582  if (*n <= 2) {
2583  return 0;
2584  }
2585  nn = *n;
2586  k = nn - 2;
2587  ak = (doublereal) ((real) k);
2588  str = *zr * raz;
2589  sti = -(*zi) * raz;
2590  rzr = (str + str) * raz;
2591  rzi = (sti + sti) * raz;
2592  ib = 3;
2593  i__1 = nn;
2594  for (i__ = ib; i__ <= i__1; ++i__) {
2595  yr[k] = (ak + *fnu) * (rzr * yr[k + 1] - rzi * yi[k + 1]) + yr[k + 2];
2596  yi[k] = (ak + *fnu) * (rzr * yi[k + 1] + rzi * yr[k + 1]) + yi[k + 2];
2597  ak += -1.;
2598  --k;
2599 /* L80: */
2600  }
2601  if (koded == 0) {
2602  return 0;
2603  }
2604  zexp_(&czr, &czi, &ckr, &cki);
2605  i__1 = nn;
2606  for (i__ = 1; i__ <= i__1; ++i__) {
2607  str = yr[i__] * ckr - yi[i__] * cki;
2608  yi[i__] = yr[i__] * cki + yi[i__] * ckr;
2609  yr[i__] = str;
2610 /* L90: */
2611  }
2612  return 0;
2613 L100:
2614  *nz = -1;
2615  return 0;
2616 L110:
2617  *nz = -2;
2618  return 0;
2619 } /* zasyi_ */
2620 
2621 /* Subroutine */ int zbinu_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *n, doublereal *cyr, doublereal *cyi, integer *nz, doublereal *rl, doublereal *fnul, doublereal *tol, doublereal *elim, doublereal *alim)
2622 {
2623  /* Initialized data */
2624 
2625  static doublereal zeror = 0.;
2626  static doublereal zeroi = 0.;
2627 
2628  /* System generated locals */
2629  integer i__1;
2630 
2631  /* Local variables */
2632  static doublereal dfnu;
2633  static integer i__, nlast;
2634  static doublereal az;
2635  static integer nn, nw;
2636  static doublereal cwi[2], cwr[2];
2637  static integer nui, inw;
2638 
2639 /* ***BEGIN PROLOGUE ZBINU */
2640 /* ***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZAIRY,ZBIRY */
2641 
2642 /* ZBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE */
2643 
2644 /* ***ROUTINES CALLED myzabs,ZASYI,ZBUNI,ZMLRI,ZSERI,ZUOIK,ZWRSK */
2645 /* ***END PROLOGUE ZBINU */
2646  /* Parameter adjustments */
2647  --cyi;
2648  --cyr;
2649 
2650  /* Function Body */
2651 
2652  *nz = 0;
2653  az = myzabs_(zr, zi);
2654  nn = *n;
2655  dfnu = *fnu + (doublereal) ((real) (*n - 1));
2656  if (az <= 2.) {
2657  goto L10;
2658  }
2659  if (az * az * .25 > dfnu + 1.) {
2660  goto L20;
2661  }
2662 L10:
2663 /* ----------------------------------------------------------------------- */
2664 /* POWER SERIES */
2665 /* ----------------------------------------------------------------------- */
2666  zseri_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, tol, elim, alim);
2667  inw = abs(nw);
2668  *nz += inw;
2669  nn -= inw;
2670  if (nn == 0) {
2671  return 0;
2672  }
2673  if (nw >= 0) {
2674  goto L120;
2675  }
2676  dfnu = *fnu + (doublereal) ((real) (nn - 1));
2677 L20:
2678  if (az < *rl) {
2679  goto L40;
2680  }
2681  if (dfnu <= 1.) {
2682  goto L30;
2683  }
2684  if (az + az < dfnu * dfnu) {
2685  goto L50;
2686  }
2687 /* ----------------------------------------------------------------------- */
2688 /* ASYMPTOTIC EXPANSION FOR LARGE Z */
2689 /* ----------------------------------------------------------------------- */
2690 L30:
2691  zasyi_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, rl, tol, elim, alim)
2692  ;
2693  if (nw < 0) {
2694  goto L130;
2695  }
2696  goto L120;
2697 L40:
2698  if (dfnu <= 1.) {
2699  goto L70;
2700  }
2701 L50:
2702 /* ----------------------------------------------------------------------- */
2703 /* OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM */
2704 /* ----------------------------------------------------------------------- */
2705  zuoik_(zr, zi, fnu, kode, &c__1, &nn, &cyr[1], &cyi[1], &nw, tol, elim,
2706  alim);
2707  if (nw < 0) {
2708  goto L130;
2709  }
2710  *nz += nw;
2711  nn -= nw;
2712  if (nn == 0) {
2713  return 0;
2714  }
2715  dfnu = *fnu + (doublereal) ((real) (nn - 1));
2716  if (dfnu > *fnul) {
2717  goto L110;
2718  }
2719  if (az > *fnul) {
2720  goto L110;
2721  }
2722 L60:
2723  if (az > *rl) {
2724  goto L80;
2725  }
2726 L70:
2727 /* ----------------------------------------------------------------------- */
2728 /* MILLER ALGORITHM NORMALIZED BY THE SERIES */
2729 /* ----------------------------------------------------------------------- */
2730  zmlri_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, tol);
2731  if (nw < 0) {
2732  goto L130;
2733  }
2734  goto L120;
2735 L80:
2736 /* ----------------------------------------------------------------------- */
2737 /* MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN */
2738 /* ----------------------------------------------------------------------- */
2739 /* ----------------------------------------------------------------------- */
2740 /* OVERFLOW TEST ON K FUNCTIONS USED IN WRONSKIAN */
2741 /* ----------------------------------------------------------------------- */
2742  zuoik_(zr, zi, fnu, kode, &c__2, &c__2, cwr, cwi, &nw, tol, elim, alim);
2743  if (nw >= 0) {
2744  goto L100;
2745  }
2746  *nz = nn;
2747  i__1 = nn;
2748  for (i__ = 1; i__ <= i__1; ++i__) {
2749  cyr[i__] = zeror;
2750  cyi[i__] = zeroi;
2751 /* L90: */
2752  }
2753  return 0;
2754 L100:
2755  if (nw > 0) {
2756  goto L130;
2757  }
2758  zwrsk_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, cwr, cwi, tol, elim,
2759  alim);
2760  if (nw < 0) {
2761  goto L130;
2762  }
2763  goto L120;
2764 L110:
2765 /* ----------------------------------------------------------------------- */
2766 /* INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD */
2767 /* ----------------------------------------------------------------------- */
2768  nui = (integer) ((real) (*fnul - dfnu)) + 1;
2769  nui = max(nui,0);
2770  zbuni_(zr, zi, fnu, kode, &nn, &cyr[1], &cyi[1], &nw, &nui, &nlast, fnul,
2771  tol, elim, alim);
2772  if (nw < 0) {
2773  goto L130;
2774  }
2775  *nz += nw;
2776  if (nlast == 0) {
2777  goto L120;
2778  }
2779  nn = nlast;
2780  goto L60;
2781 L120:
2782  return 0;
2783 L130:
2784  *nz = -1;
2785  if (nw == -2) {
2786  *nz = -2;
2787  }
2788  return 0;
2789 } /* zbinu_ */
2790 
2791 /* Subroutine */
2792 int zbknu_(doublereal *zr, doublereal *zi, doublereal *fnu,
2793  integer *kode, integer *n,
2794  doublereal *yr, doublereal *yi,
2795  integer *nz, doublereal *tol,
2796  doublereal *elim, doublereal *alim)
2797 {
2798  /* Initialized data */
2799 
2800  static integer kmax = 30;
2801  static doublereal czeror = 0.;
2802  static doublereal czeroi = 0.;
2803  static doublereal coner = 1.;
2804  static doublereal conei = 0.;
2805  static doublereal ctwor = 2.;
2806  static doublereal r1 = 2.;
2807  static doublereal dpi = 3.14159265358979324;
2808  static doublereal rthpi = 1.25331413731550025;
2809  static doublereal spi = 1.90985931710274403;
2810  static doublereal hpi = 1.57079632679489662;
2811  static doublereal fpi = 1.89769999331517738;
2812  static doublereal tth = .666666666666666666;
2813  static doublereal cc[8] = { .577215664901532861,-.0420026350340952355,
2814  -.0421977345555443367,.00721894324666309954,
2815  -2.15241674114950973e-4,-2.01348547807882387e-5,
2816  1.13302723198169588e-6,6.11609510448141582e-9 };
2817 
2818  /* System generated locals */
2819  integer i__1;
2820  doublereal d__1;
2821 
2822  /* Builtin functions */
2823 
2824  /* Local variables */
2825  static doublereal cchi, cchr, alas, cshi;
2826  static integer inub, idum;
2827  static doublereal cshr, fmui, rcaz, csrr[3], cssr[3], fmur;
2828  static doublereal smui;
2829  static doublereal smur;
2830  static integer i__, j, k, iflag;
2831  static doublereal s;
2832  static integer kflag;
2833  static doublereal coefi;
2834  static integer koded;
2835  static doublereal ascle, coefr, helim, celmr, csclr, crscr;
2836  static doublereal a1, a2, etest;
2837  static doublereal g1, g2;
2838  static doublereal t1, t2;
2839  static doublereal aa, bb, fc, ak, bk;
2840  static integer ic;
2841  static doublereal fi, fk, as;
2842  static integer kk;
2843  static doublereal fr, pi, qi, tm, pr, qr;
2844  static integer nw;
2845  static doublereal p1i, p2i, s1i, s2i, p2m, p1r, p2r, s1r, s2r, cbi, cbr,
2846  cki, caz, csi, ckr, fhs, fks, rak, czi, dnu, csr, elm, zdi, bry[3]
2847  , pti, czr, sti, zdr, cyr[2], rzi, ptr, cyi[2];
2848  static integer inu;
2849  static doublereal str, rzr, dnu2;
2850 
2851 /* ***BEGIN PROLOGUE ZBKNU */
2852 /* ***REFER TO ZBESI,ZBESK,ZAIRY,ZBESH */
2853 
2854 /* ZBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE. */
2855 
2856 /* ***ROUTINES CALLED DGAMLN,I1MACH,D1MACH,ZKSCL,ZSHCH,ZUCHK,myzabs,ZDIV, */
2857 /* ZEXP,ZLOG,ZMLT,ZSQRT */
2858 /* ***END PROLOGUE ZBKNU */
2859 
2860 /* COMPLEX Z,Y,A,B,RZ,SMU,FU,FMU,F,FLRZ,CZ,S1,S2,CSH,CCH */
2861 /* COMPLEX CK,P,Q,COEF,P1,P2,CBK,PT,CZERO,CONE,CTWO,ST,EZ,CS,DK */
2862 
2863  /* Parameter adjustments */
2864  --yi;
2865  --yr;
2866 
2867  /* Function Body */
2868 
2869  caz = myzabs_(zr, zi);
2870  csclr = 1. / *tol;
2871  crscr = *tol;
2872  cssr[0] = csclr;
2873  cssr[1] = 1.;
2874  cssr[2] = crscr;
2875  csrr[0] = crscr;
2876  csrr[1] = 1.;
2877  csrr[2] = csclr;
2878  bry[0] = d1mach_(&c__1) * 1e3 / *tol;
2879  bry[1] = 1. / bry[0];
2880  bry[2] = d1mach_(&c__2);
2881  *nz = 0;
2882  iflag = 0;
2883  koded = *kode;
2884  rcaz = 1. / caz;
2885  str = *zr * rcaz;
2886  sti = -(*zi) * rcaz;
2887  rzr = (str + str) * rcaz;
2888  rzi = (sti + sti) * rcaz;
2889  inu = (integer) ((real) (*fnu + .5));
2890  dnu = *fnu - (doublereal) ((real) inu);
2891  if (abs(dnu) == .5) {
2892  goto L110;
2893  }
2894  dnu2 = 0.;
2895  if (abs(dnu) > *tol) {
2896  dnu2 = dnu * dnu;
2897  }
2898  if (caz > r1) {
2899  goto L110;
2900  }
2901 /* ----------------------------------------------------------------------- */
2902 /* SERIES FOR CABS(Z).LE.R1 */
2903 /* ----------------------------------------------------------------------- */
2904  fc = 1.;
2905  zlog_(&rzr, &rzi, &smur, &smui, &idum);
2906  fmur = smur * dnu;
2907  fmui = smui * dnu;
2908  zshch_(&fmur, &fmui, &cshr, &cshi, &cchr, &cchi);
2909  if (dnu == 0.) {
2910  goto L10;
2911  }
2912  fc = dnu * dpi;
2913  fc /= sin(fc);
2914  smur = cshr / dnu;
2915  smui = cshi / dnu;
2916 L10:
2917  a2 = dnu + 1.;
2918 /* ----------------------------------------------------------------------- */
2919 /* GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU), T2=1/GAM(1+DNU) */
2920 /* ----------------------------------------------------------------------- */
2921  t2 = exp(-dgamln_(&a2, &idum));
2922  t1 = 1. / (t2 * fc);
2923  if (abs(dnu) > .1) {
2924  goto L40;
2925  }
2926 /* ----------------------------------------------------------------------- */
2927 /* SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU) */
2928 /* ----------------------------------------------------------------------- */
2929  ak = 1.;
2930  s = cc[0];
2931  for (k = 2; k <= 8; ++k) {
2932  ak *= dnu2;
2933  tm = cc[k - 1] * ak;
2934  s += tm;
2935  if (abs(tm) < *tol) {
2936  goto L30;
2937  }
2938 /* L20: */
2939  }
2940 L30:
2941  g1 = -s;
2942  goto L50;
2943 L40:
2944  g1 = (t1 - t2) / (dnu + dnu);
2945 L50:
2946  g2 = (t1 + t2) * .5;
2947  fr = fc * (cchr * g1 + smur * g2);
2948  fi = fc * (cchi * g1 + smui * g2);
2949  zexp_(&fmur, &fmui, &str, &sti);
2950  pr = str * .5 / t2;
2951  pi = sti * .5 / t2;
2952  zdiv_(&c_b147, &c_b148, &str, &sti, &ptr, &pti);
2953  qr = ptr / t1;
2954  qi = pti / t1;
2955  s1r = fr;
2956  s1i = fi;
2957  s2r = pr;
2958  s2i = pi;
2959  ak = 1.;
2960  a1 = 1.;
2961  ckr = coner;
2962  cki = conei;
2963  bk = 1. - dnu2;
2964  if (inu > 0 || *n > 1) {
2965  goto L80;
2966  }
2967 /* ----------------------------------------------------------------------- */
2968 /* GENERATE K(FNU,Z), 0.0D0 .LE. FNU .LT. 0.5D0 AND N=1 */
2969 /* ----------------------------------------------------------------------- */
2970  if (caz < *tol) {
2971  goto L70;
2972  }
2973  zmlt_(zr, zi, zr, zi, &czr, &czi);
2974  czr *= .25;
2975  czi *= .25;
2976  t1 = caz * .25 * caz;
2977 L60:
2978  fr = (fr * ak + pr + qr) / bk;
2979  fi = (fi * ak + pi + qi) / bk;
2980  str = 1. / (ak - dnu);
2981  pr *= str;
2982  pi *= str;
2983  str = 1. / (ak + dnu);
2984  qr *= str;
2985  qi *= str;
2986  str = ckr * czr - cki * czi;
2987  rak = 1. / ak;
2988  cki = (ckr * czi + cki * czr) * rak;
2989  ckr = str * rak;
2990  s1r = ckr * fr - cki * fi + s1r;
2991  s1i = ckr * fi + cki * fr + s1i;
2992  a1 = a1 * t1 * rak;
2993  bk = bk + ak + ak + 1.;
2994  ak += 1.;
2995  if (a1 > *tol) {
2996  goto L60;
2997  }
2998 L70:
2999  yr[1] = s1r;
3000  yi[1] = s1i;
3001  if (koded == 1) {
3002  return 0;
3003  }
3004  zexp_(zr, zi, &str, &sti);
3005  zmlt_(&s1r, &s1i, &str, &sti, &yr[1], &yi[1]);
3006  return 0;
3007 /* ----------------------------------------------------------------------- */
3008 /* GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE */
3009 /* ----------------------------------------------------------------------- */
3010 L80:
3011  if (caz < *tol) {
3012  goto L100;
3013  }
3014  zmlt_(zr, zi, zr, zi, &czr, &czi);
3015  czr *= .25;
3016  czi *= .25;
3017  t1 = caz * .25 * caz;
3018 L90:
3019  fr = (fr * ak + pr + qr) / bk;
3020  fi = (fi * ak + pi + qi) / bk;
3021  str = 1. / (ak - dnu);
3022  pr *= str;
3023  pi *= str;
3024  str = 1. / (ak + dnu);
3025  qr *= str;
3026  qi *= str;
3027  str = ckr * czr - cki * czi;
3028  rak = 1. / ak;
3029  cki = (ckr * czi + cki * czr) * rak;
3030  ckr = str * rak;
3031  s1r = ckr * fr - cki * fi + s1r;
3032  s1i = ckr * fi + cki * fr + s1i;
3033  str = pr - fr * ak;
3034  sti = pi - fi * ak;
3035  s2r = ckr * str - cki * sti + s2r;
3036  s2i = ckr * sti + cki * str + s2i;
3037  a1 = a1 * t1 * rak;
3038  bk = bk + ak + ak + 1.;
3039  ak += 1.;
3040  if (a1 > *tol) {
3041  goto L90;
3042  }
3043 L100:
3044  kflag = 2;
3045  a1 = *fnu + 1.;
3046  ak = a1 * abs(smur);
3047  if (ak > *alim) {
3048  kflag = 3;
3049  }
3050  str = cssr[kflag - 1];
3051  p2r = s2r * str;
3052  p2i = s2i * str;
3053  zmlt_(&p2r, &p2i, &rzr, &rzi, &s2r, &s2i);
3054  s1r *= str;
3055  s1i *= str;
3056  if (koded == 1) {
3057  goto L210;
3058  }
3059  zexp_(zr, zi, &fr, &fi);
3060  zmlt_(&s1r, &s1i, &fr, &fi, &s1r, &s1i);
3061  zmlt_(&s2r, &s2i, &fr, &fi, &s2r, &s2i);
3062  goto L210;
3063 /* ----------------------------------------------------------------------- */
3064 /* IFLAG=0 MEANS NO UNDERFLOW OCCURRED */
3065 /* IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH */
3066 /* KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD */
3067 /* RECURSION */
3068 /* ----------------------------------------------------------------------- */
3069 L110:
3070  zsqrt_(zr, zi, &str, &sti);
3071  zdiv_(&rthpi, &czeroi, &str, &sti, &coefr, &coefi);
3072  kflag = 2;
3073  if (koded == 2) {
3074  goto L120;
3075  }
3076  if (*zr > *alim) {
3077  goto L290;
3078  }
3079 /* BLANK LINE */
3080  str = exp(-(*zr)) * cssr[kflag - 1];
3081  sti = -str * sin(*zi);
3082  str *= cos(*zi);
3083  zmlt_(&coefr, &coefi, &str, &sti, &coefr, &coefi);
3084 L120:
3085  if (abs(dnu) == .5) {
3086  goto L300;
3087  }
3088 /* ----------------------------------------------------------------------- */
3089 /* MILLER ALGORITHM FOR CABS(Z).GT.R1 */
3090 /* ----------------------------------------------------------------------- */
3091  ak = cos(dpi * dnu);
3092  ak = abs(ak);
3093  if (ak == czeror) {
3094  goto L300;
3095  }
3096  fhs = (d__1 = .25 - dnu2, abs(d__1));
3097  if (fhs == czeror) {
3098  goto L300;
3099  }
3100 /* ----------------------------------------------------------------------- */
3101 /* COMPUTE R2=F(E). IF CABS(Z).GE.R2, USE FORWARD RECURRENCE TO */
3102 /* DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT LINE ON */
3103 /* 12.LE.E.LE.60. E IS COMPUTED FROM 2**(-E)=B**(1-I1MACH(14))= */
3104 /* TOL WHERE B IS THE BASE OF THE ARITHMETIC. */
3105 /* ----------------------------------------------------------------------- */
3106  t1 = (doublereal) ((real) (i1mach_(&c__14) - 1));
3107  t1 = t1 * d1mach_(&c__5) * 3.321928094;
3108  t1 = max(t1,12.);
3109  t1 = min(t1,60.);
3110  t2 = tth * t1 - 6.;
3111  if (*zr != 0.) {
3112  goto L130;
3113  }
3114  t1 = hpi;
3115  goto L140;
3116 L130:
3117  t1 = atan(*zi / *zr);
3118  t1 = abs(t1);
3119 L140:
3120  if (t2 > caz) {
3121  goto L170;
3122  }
3123 /* ----------------------------------------------------------------------- */
3124 /* FORWARD RECURRENCE LOOP WHEN CABS(Z).GE.R2 */
3125 /* ----------------------------------------------------------------------- */
3126  etest = ak / (dpi * caz * *tol);
3127  fk = coner;
3128  if (etest < coner) {
3129  goto L180;
3130  }
3131  fks = ctwor;
3132  ckr = caz + caz + ctwor;
3133  p1r = czeror;
3134  p2r = coner;
3135  i__1 = kmax;
3136  for (i__ = 1; i__ <= i__1; ++i__) {
3137  ak = fhs / fks;
3138  cbr = ckr / (fk + coner);
3139  ptr = p2r;
3140  p2r = cbr * p2r - p1r * ak;
3141  p1r = ptr;
3142  ckr += ctwor;
3143  fks = fks + fk + fk + ctwor;
3144  fhs = fhs + fk + fk;
3145  fk += coner;
3146  str = abs(p2r) * fk;
3147  if (etest < str) {
3148  goto L160;
3149  }
3150 /* L150: */
3151  }
3152  goto L310;
3153 L160:
3154  fk += spi * t1 * sqrt(t2 / caz);
3155  fhs = (d__1 = .25 - dnu2, abs(d__1));
3156  goto L180;
3157 L170:
3158 /* ----------------------------------------------------------------------- */
3159 /* COMPUTE BACKWARD INDEX K FOR CABS(Z).LT.R2 */
3160 /* ----------------------------------------------------------------------- */
3161  a2 = sqrt(caz);
3162  ak = fpi * ak / (*tol * sqrt(a2));
3163  aa = t1 * 3. / (caz + 1.);
3164  bb = t1 * 14.7 / (caz + 28.);
3165  ak = (log(ak) + caz * cos(aa) / (caz * .008 + 1.)) / cos(bb);
3166  fk = ak * .12125 * ak / caz + 1.5;
3167 L180:
3168 /* ----------------------------------------------------------------------- */
3169 /* BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM */
3170 /* ----------------------------------------------------------------------- */
3171  k = (integer) ((real) fk);
3172  fk = (doublereal) ((real) k);
3173  fks = fk * fk;
3174  p1r = czeror;
3175  p1i = czeroi;
3176  p2r = *tol;
3177  p2i = czeroi;
3178  csr = p2r;
3179  csi = p2i;
3180  i__1 = k;
3181  for (i__ = 1; i__ <= i__1; ++i__) {
3182  a1 = fks - fk;
3183  ak = (fks + fk) / (a1 + fhs);
3184  rak = 2. / (fk + coner);
3185  cbr = (fk + *zr) * rak;
3186  cbi = *zi * rak;
3187  ptr = p2r;
3188  pti = p2i;
3189  p2r = (ptr * cbr - pti * cbi - p1r) * ak;
3190  p2i = (pti * cbr + ptr * cbi - p1i) * ak;
3191  p1r = ptr;
3192  p1i = pti;
3193  csr += p2r;
3194  csi += p2i;
3195  fks = a1 - fk + coner;
3196  fk -= coner;
3197 /* L190: */
3198  }
3199 /* ----------------------------------------------------------------------- */
3200 /* COMPUTE (P2/CS)=(P2/CABS(CS))*(CONJG(CS)/CABS(CS)) FOR BETTER */
3201 /* SCALING */
3202 /* ----------------------------------------------------------------------- */
3203  tm = myzabs_(&csr, &csi);
3204  ptr = 1. / tm;
3205  s1r = p2r * ptr;
3206  s1i = p2i * ptr;
3207  csr *= ptr;
3208  csi = -csi * ptr;
3209  zmlt_(&coefr, &coefi, &s1r, &s1i, &str, &sti);
3210  zmlt_(&str, &sti, &csr, &csi, &s1r, &s1i);
3211  if (inu > 0 || *n > 1) {
3212  goto L200;
3213  }
3214  zdr = *zr;
3215  zdi = *zi;
3216  if (iflag == 1) {
3217  goto L270;
3218  }
3219  goto L240;
3220 L200:
3221 /* ----------------------------------------------------------------------- */
3222 /* COMPUTE P1/P2=(P1/CABS(P2)*CONJG(P2)/CABS(P2) FOR SCALING */
3223 /* ----------------------------------------------------------------------- */
3224  tm = myzabs_(&p2r, &p2i);
3225  ptr = 1. / tm;
3226  p1r *= ptr;
3227  p1i *= ptr;
3228  p2r *= ptr;
3229  p2i = -p2i * ptr;
3230  zmlt_(&p1r, &p1i, &p2r, &p2i, &ptr, &pti);
3231  str = dnu + .5 - ptr;
3232  sti = -pti;
3233  zdiv_(&str, &sti, zr, zi, &str, &sti);
3234  str += 1.;
3235  zmlt_(&str, &sti, &s1r, &s1i, &s2r, &s2i);
3236 /* ----------------------------------------------------------------------- */
3237 /* FORWARD RECURSION ON THE THREE TERM RECURSION WITH RELATION WITH */
3238 /* SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3 */
3239 /* ----------------------------------------------------------------------- */
3240 L210:
3241  str = dnu + 1.;
3242  ckr = str * rzr;
3243  cki = str * rzi;
3244  if (*n == 1) {
3245  --inu;
3246  }
3247  if (inu > 0) {
3248  goto L220;
3249  }
3250  if (*n > 1) {
3251  goto L215;
3252  }
3253  s1r = s2r;
3254  s1i = s2i;
3255 L215:
3256  zdr = *zr;
3257  zdi = *zi;
3258  if (iflag == 1) {
3259  goto L270;
3260  }
3261  goto L240;
3262 L220:
3263  inub = 1;
3264  if (iflag == 1) {
3265  goto L261;
3266  }
3267 L225:
3268  p1r = csrr[kflag - 1];
3269  ascle = bry[kflag - 1];
3270  i__1 = inu;
3271  for (i__ = inub; i__ <= i__1; ++i__) {
3272  str = s2r;
3273  sti = s2i;
3274  s2r = ckr * str - cki * sti + s1r;
3275  s2i = ckr * sti + cki * str + s1i;
3276  s1r = str;
3277  s1i = sti;
3278  ckr += rzr;
3279  cki += rzi;
3280  if (kflag >= 3) {
3281  goto L230;
3282  }
3283  p2r = s2r * p1r;
3284  p2i = s2i * p1r;
3285  str = abs(p2r);
3286  sti = abs(p2i);
3287  p2m = max(str,sti);
3288  if (p2m <= ascle) {
3289  goto L230;
3290  }
3291  ++kflag;
3292  ascle = bry[kflag - 1];
3293  s1r *= p1r;
3294  s1i *= p1r;
3295  s2r = p2r;
3296  s2i = p2i;
3297  str = cssr[kflag - 1];
3298  s1r *= str;
3299  s1i *= str;
3300  s2r *= str;
3301  s2i *= str;
3302  p1r = csrr[kflag - 1];
3303 L230:
3304  ;
3305  }
3306  if (*n != 1) {
3307  goto L240;
3308  }
3309  s1r = s2r;
3310  s1i = s2i;
3311 L240:
3312  str = csrr[kflag - 1];
3313  yr[1] = s1r * str;
3314  yi[1] = s1i * str;
3315  if (*n == 1) {
3316  return 0;
3317  }
3318  yr[2] = s2r * str;
3319  yi[2] = s2i * str;
3320  if (*n == 2) {
3321  return 0;
3322  }
3323  kk = 2;
3324 L250:
3325  ++kk;
3326  if (kk > *n) {
3327  return 0;
3328  }
3329  p1r = csrr[kflag - 1];
3330  ascle = bry[kflag - 1];
3331  i__1 = *n;
3332  for (i__ = kk; i__ <= i__1; ++i__) {
3333  p2r = s2r;
3334  p2i = s2i;
3335  s2r = ckr * p2r - cki * p2i + s1r;
3336  s2i = cki * p2r + ckr * p2i + s1i;
3337  s1r = p2r;
3338  s1i = p2i;
3339  ckr += rzr;
3340  cki += rzi;
3341  p2r = s2r * p1r;
3342  p2i = s2i * p1r;
3343  yr[i__] = p2r;
3344  yi[i__] = p2i;
3345  if (kflag >= 3) {
3346  goto L260;
3347  }
3348  str = abs(p2r);
3349  sti = abs(p2i);
3350  p2m = max(str,sti);
3351  if (p2m <= ascle) {
3352  goto L260;
3353  }
3354  ++kflag;
3355  ascle = bry[kflag - 1];
3356  s1r *= p1r;
3357  s1i *= p1r;
3358  s2r = p2r;
3359  s2i = p2i;
3360  str = cssr[kflag - 1];
3361  s1r *= str;
3362  s1i *= str;
3363  s2r *= str;
3364  s2i *= str;
3365  p1r = csrr[kflag - 1];
3366 L260:
3367  ;
3368  }
3369  return 0;
3370 /* ----------------------------------------------------------------------- */
3371 /* IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW */
3372 /* ----------------------------------------------------------------------- */
3373 L261:
3374  helim = *elim * .5;
3375  elm = exp(-(*elim));
3376  celmr = elm;
3377  ascle = bry[0];
3378  zdr = *zr;
3379  zdi = *zi;
3380  ic = -1;
3381  j = 2;
3382  i__1 = inu;
3383  for (i__ = 1; i__ <= i__1; ++i__) {
3384  str = s2r;
3385  sti = s2i;
3386  s2r = str * ckr - sti * cki + s1r;
3387  s2i = sti * ckr + str * cki + s1i;
3388  s1r = str;
3389  s1i = sti;
3390  ckr += rzr;
3391  cki += rzi;
3392  as = myzabs_(&s2r, &s2i);
3393  alas = log(as);
3394  p2r = -zdr + alas;
3395  if (p2r < -(*elim)) {
3396  goto L263;
3397  }
3398  zlog_(&s2r, &s2i, &str, &sti, &idum);
3399  p2r = -zdr + str;
3400  p2i = -zdi + sti;
3401  p2m = exp(p2r) / *tol;
3402  p1r = p2m * cos(p2i);
3403  p1i = p2m * sin(p2i);
3404  zuchk_(&p1r, &p1i, &nw, &ascle, tol);
3405  if (nw != 0) {
3406  goto L263;
3407  }
3408  j = 3 - j;
3409  cyr[j - 1] = p1r;
3410  cyi[j - 1] = p1i;
3411  if (ic == i__ - 1) {
3412  goto L264;
3413  }
3414  ic = i__;
3415  goto L262;
3416 L263:
3417  if (alas < helim) {
3418  goto L262;
3419  }
3420  zdr -= *elim;
3421  s1r *= celmr;
3422  s1i *= celmr;
3423  s2r *= celmr;
3424  s2i *= celmr;
3425 L262:
3426  ;
3427  }
3428  if (*n != 1) {
3429  goto L270;
3430  }
3431  s1r = s2r;
3432  s1i = s2i;
3433  goto L270;
3434 L264:
3435  kflag = 1;
3436  inub = i__ + 1;
3437  s2r = cyr[j - 1];
3438  s2i = cyi[j - 1];
3439  j = 3 - j;
3440  s1r = cyr[j - 1];
3441  s1i = cyi[j - 1];
3442  if (inub <= inu) {
3443  goto L225;
3444  }
3445  if (*n != 1) {
3446  goto L240;
3447  }
3448  s1r = s2r;
3449  s1i = s2i;
3450  goto L240;
3451 L270:
3452  yr[1] = s1r;
3453  yi[1] = s1i;
3454  if (*n == 1) {
3455  goto L280;
3456  }
3457  yr[2] = s2r;
3458  yi[2] = s2i;
3459 L280:
3460  ascle = bry[0];
3461  zkscl_(&zdr, &zdi, fnu, n, &yr[1], &yi[1], nz, &rzr, &rzi, &ascle, tol,
3462  elim);
3463  inu = *n - *nz;
3464  if (inu <= 0) {
3465  return 0;
3466  }
3467  kk = *nz + 1;
3468  s1r = yr[kk];
3469  s1i = yi[kk];
3470  yr[kk] = s1r * csrr[0];
3471  yi[kk] = s1i * csrr[0];
3472  if (inu == 1) {
3473  return 0;
3474  }
3475  kk = *nz + 2;
3476  s2r = yr[kk];
3477  s2i = yi[kk];
3478  yr[kk] = s2r * csrr[0];
3479  yi[kk] = s2i * csrr[0];
3480  if (inu == 2) {
3481  return 0;
3482  }
3483  t2 = *fnu + (doublereal) ((real) (kk - 1));
3484  ckr = t2 * rzr;
3485  cki = t2 * rzi;
3486  kflag = 1;
3487  goto L250;
3488 L290:
3489 /* ----------------------------------------------------------------------- */
3490 /* SCALE BY DEXP(Z), IFLAG = 1 CASES */
3491 /* ----------------------------------------------------------------------- */
3492  koded = 2;
3493  iflag = 1;
3494  kflag = 2;
3495  goto L120;
3496 /* ----------------------------------------------------------------------- */
3497 /* FNU=HALF ODD INTEGER CASE, DNU=-0.5 */
3498 /* ----------------------------------------------------------------------- */
3499 L300:
3500  s1r = coefr;
3501  s1i = coefi;
3502  s2r = coefr;
3503  s2i = coefi;
3504  goto L210;
3505 
3506 
3507 L310:
3508  *nz = -2;
3509  return 0;
3510 } /* zbknu_ */
3511 
3512 /* Subroutine */ int zbuni_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *nz, integer *nui, integer *nlast, doublereal *fnul, doublereal *tol, doublereal *elim, doublereal *alim)
3513 {
3514  /* System generated locals */
3515  integer i__1;
3516 
3517  /* Local variables */
3518  static doublereal dfnu, fnui;
3519  static integer i__, k, iflag;
3520  static doublereal ascle, csclr, cscrr;
3521  static integer iform;
3522  static doublereal ax, ay;
3523  static integer nl, nw;
3524  static doublereal c1i, c1m;
3525  static doublereal c1r, s1i, s2i, s1r, s2r, cyi[2], gnu, raz, cyr[2], sti,
3526  bry[3], rzi, str, rzr;
3527 
3528 /* ***BEGIN PROLOGUE ZBUNI */
3529 /* ***REFER TO ZBESI,ZBESK */
3530 
3531 /* ZBUNI COMPUTES THE I BESSEL FUNCTION FOR LARGE CABS(Z).GT. */
3532 /* FNUL AND FNU+N-1.LT.FNUL. THE ORDER IS INCREASED FROM */
3533 /* FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING */
3534 /* ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z) */
3535 /* ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2 */
3536 
3537 /* ***ROUTINES CALLED ZUNI1,ZUNI2,myzabs,D1MACH */
3538 /* ***END PROLOGUE ZBUNI */
3539 /* COMPLEX CSCL,CSCR,CY,RZ,ST,S1,S2,Y,Z */
3540  /* Parameter adjustments */
3541  --yi;
3542  --yr;
3543 
3544  /* Function Body */
3545  *nz = 0;
3546  ax = abs(*zr) * 1.7321;
3547  ay = abs(*zi);
3548  iform = 1;
3549  if (ay > ax) {
3550  iform = 2;
3551  }
3552  if (*nui == 0) {
3553  goto L60;
3554  }
3555  fnui = (doublereal) ((real) (*nui));
3556  dfnu = *fnu + (doublereal) ((real) (*n - 1));
3557  gnu = dfnu + fnui;
3558  if (iform == 2) {
3559  goto L10;
3560  }
3561 /* ----------------------------------------------------------------------- */
3562 /* ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN */
3563 /* -PI/3.LE.ARG(Z).LE.PI/3 */
3564 /* ----------------------------------------------------------------------- */
3565  zuni1_(zr, zi, &gnu, kode, &c__2, cyr, cyi, &nw, nlast, fnul, tol, elim,
3566  alim);
3567  goto L20;
3568 L10:
3569 /* ----------------------------------------------------------------------- */
3570 /* ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU */
3571 /* APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I */
3572 /* AND HPI=PI/2 */
3573 /* ----------------------------------------------------------------------- */
3574  zuni2_(zr, zi, &gnu, kode, &c__2, cyr, cyi, &nw, nlast, fnul, tol, elim,
3575  alim);
3576 L20:
3577  if (nw < 0) {
3578  goto L50;
3579  }
3580  if (nw != 0) {
3581  goto L90;
3582  }
3583  str = myzabs_(cyr, cyi);
3584 /* ---------------------------------------------------------------------- */
3585 /* SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER USED */
3586 /* ---------------------------------------------------------------------- */
3587  bry[0] = d1mach_(&c__1) * 1e3 / *tol;
3588  bry[1] = 1. / bry[0];
3589  bry[2] = bry[1];
3590  iflag = 2;
3591  ascle = bry[1];
3592  csclr = 1.;
3593  if (str > bry[0]) {
3594  goto L21;
3595  }
3596  iflag = 1;
3597  ascle = bry[0];
3598  csclr = 1. / *tol;
3599  goto L25;
3600 L21:
3601  if (str < bry[1]) {
3602  goto L25;
3603  }
3604  iflag = 3;
3605  ascle = bry[2];
3606  csclr = *tol;
3607 L25:
3608  cscrr = 1. / csclr;
3609  s1r = cyr[1] * csclr;
3610  s1i = cyi[1] * csclr;
3611  s2r = cyr[0] * csclr;
3612  s2i = cyi[0] * csclr;
3613  raz = 1. / myzabs_(zr, zi);
3614  str = *zr * raz;
3615  sti = -(*zi) * raz;
3616  rzr = (str + str) * raz;
3617  rzi = (sti + sti) * raz;
3618  i__1 = *nui;
3619  for (i__ = 1; i__ <= i__1; ++i__) {
3620  str = s2r;
3621  sti = s2i;
3622  s2r = (dfnu + fnui) * (rzr * str - rzi * sti) + s1r;
3623  s2i = (dfnu + fnui) * (rzr * sti + rzi * str) + s1i;
3624  s1r = str;
3625  s1i = sti;
3626  fnui += -1.;
3627  if (iflag >= 3) {
3628  goto L30;
3629  }
3630  str = s2r * cscrr;
3631  sti = s2i * cscrr;
3632  c1r = abs(str);
3633  c1i = abs(sti);
3634  c1m = max(c1r,c1i);
3635  if (c1m <= ascle) {
3636  goto L30;
3637  }
3638  ++iflag;
3639  ascle = bry[iflag - 1];
3640  s1r *= cscrr;
3641  s1i *= cscrr;
3642  s2r = str;
3643  s2i = sti;
3644  csclr *= *tol;
3645  cscrr = 1. / csclr;
3646  s1r *= csclr;
3647  s1i *= csclr;
3648  s2r *= csclr;
3649  s2i *= csclr;
3650 L30:
3651  ;
3652  }
3653  yr[*n] = s2r * cscrr;
3654  yi[*n] = s2i * cscrr;
3655  if (*n == 1) {
3656  return 0;
3657  }
3658  nl = *n - 1;
3659  fnui = (doublereal) ((real) nl);
3660  k = nl;
3661  i__1 = nl;
3662  for (i__ = 1; i__ <= i__1; ++i__) {
3663  str = s2r;
3664  sti = s2i;
3665  s2r = (*fnu + fnui) * (rzr * str - rzi * sti) + s1r;
3666  s2i = (*fnu + fnui) * (rzr * sti + rzi * str) + s1i;
3667  s1r = str;
3668  s1i = sti;
3669  str = s2r * cscrr;
3670  sti = s2i * cscrr;
3671  yr[k] = str;
3672  yi[k] = sti;
3673  fnui += -1.;
3674  --k;
3675  if (iflag >= 3) {
3676  goto L40;
3677  }
3678  c1r = abs(str);
3679  c1i = abs(sti);
3680  c1m = max(c1r,c1i);
3681  if (c1m <= ascle) {
3682  goto L40;
3683  }
3684  ++iflag;
3685  ascle = bry[iflag - 1];
3686  s1r *= cscrr;
3687  s1i *= cscrr;
3688  s2r = str;
3689  s2i = sti;
3690  csclr *= *tol;
3691  cscrr = 1. / csclr;
3692  s1r *= csclr;
3693  s1i *= csclr;
3694  s2r *= csclr;
3695  s2i *= csclr;
3696 L40:
3697  ;
3698  }
3699  return 0;
3700 L50:
3701  *nz = -1;
3702  if (nw == -2) {
3703  *nz = -2;
3704  }
3705  return 0;
3706 L60:
3707  if (iform == 2) {
3708  goto L70;
3709  }
3710 /* ----------------------------------------------------------------------- */
3711 /* ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN */
3712 /* -PI/3.LE.ARG(Z).LE.PI/3 */
3713 /* ----------------------------------------------------------------------- */
3714  zuni1_(zr, zi, fnu, kode, n, &yr[1], &yi[1], &nw, nlast, fnul, tol, elim,
3715  alim);
3716  goto L80;
3717 L70:
3718 /* ----------------------------------------------------------------------- */
3719 /* ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU */
3720 /* APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I */
3721 /* AND HPI=PI/2 */
3722 /* ----------------------------------------------------------------------- */
3723  zuni2_(zr, zi, fnu, kode, n, &yr[1], &yi[1], &nw, nlast, fnul, tol, elim,
3724  alim);
3725 L80:
3726  if (nw < 0) {
3727  goto L50;
3728  }
3729  *nz = nw;
3730  return 0;
3731 L90:
3732  *nlast = *n;
3733  return 0;
3734 } /* zbuni_ */
3735 
3736 /* Subroutine */ int zbunk_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *tol, doublereal *elim, doublereal *alim)
3737 {
3738  static doublereal ax, ay;
3739 
3740 /* ***BEGIN PROLOGUE ZBUNK */
3741 /* ***REFER TO ZBESK,ZBESH */
3742 
3743 /* ZBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU.GT.FNUL. */
3744 /* ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z) */
3745 /* IN ZUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN ZUNK2 */
3746 
3747 /* ***ROUTINES CALLED ZUNK1,ZUNK2 */
3748 /* ***END PROLOGUE ZBUNK */
3749 /* COMPLEX Y,Z */
3750  /* Parameter adjustments */
3751  --yi;
3752  --yr;
3753 
3754  /* Function Body */
3755  *nz = 0;
3756  ax = abs(*zr) * 1.7321;
3757  ay = abs(*zi);
3758  if (ay > ax) {
3759  goto L10;
3760  }
3761 /* ----------------------------------------------------------------------- */
3762 /* ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN */
3763 /* -PI/3.LE.ARG(Z).LE.PI/3 */
3764 /* ----------------------------------------------------------------------- */
3765  zunk1_(zr, zi, fnu, kode, mr, n, &yr[1], &yi[1], nz, tol, elim, alim);
3766  goto L20;
3767 L10:
3768 /* ----------------------------------------------------------------------- */
3769 /* ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU */
3770 /* APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I */
3771 /* AND HPI=PI/2 */
3772 /* ----------------------------------------------------------------------- */
3773  zunk2_(zr, zi, fnu, kode, mr, n, &yr[1], &yi[1], nz, tol, elim, alim);
3774 L20:
3775  return 0;
3776 } /* zbunk_ */
3777 
3778 /* Subroutine */ int zdiv_(doublereal *ar, doublereal *ai, doublereal *br, doublereal *bi, doublereal *cr, doublereal *ci)
3779 {
3780  static doublereal ca, cb, cc, cd, bm;
3781 
3782 /* ***BEGIN PROLOGUE ZDIV */
3783 /* ***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY */
3784 
3785 /* DOUBLE PRECISION COMPLEX DIVIDE C=A/B. */
3786 
3787 /* ***ROUTINES CALLED myzabs */
3788 /* ***END PROLOGUE ZDIV */
3789  bm = 1. / myzabs_(br, bi);
3790  cc = *br * bm;
3791  cd = *bi * bm;
3792  ca = (*ar * cc + *ai * cd) * bm;
3793  cb = (*ai * cc - *ar * cd) * bm;
3794  *cr = ca;
3795  *ci = cb;
3796  return 0;
3797 } /* zdiv_ */
3798 
3799 /* Subroutine */ int zexp_(const doublereal *ar, const doublereal *ai, doublereal *br, doublereal *bi)
3800 {
3801  /* Builtin functions */
3802 
3803  /* Local variables */
3804  static doublereal ca, cb, zm;
3805 
3806 /* ***BEGIN PROLOGUE ZEXP */
3807 /* ***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY */
3808 
3809 /* DOUBLE PRECISION COMPLEX EXPONENTIAL FUNCTION B=EXP(A) */
3810 
3811 /* ***ROUTINES CALLED (NONE) */
3812 /* ***END PROLOGUE ZEXP */
3813  zm = exp(*ar);
3814  ca = zm * cos(*ai);
3815  cb = zm * sin(*ai);
3816  *br = ca;
3817  *bi = cb;
3818  return 0;
3819 } /* zexp_ */
3820 
3821 /* Subroutine */ int zkscl_(doublereal *zrr, doublereal *zri, doublereal *fnu, integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *rzr, doublereal *rzi, doublereal *ascle, doublereal *tol, doublereal *elim)
3822 {
3823  /* Initialized data */
3824 
3825  static doublereal zeror = 0.;
3826  static doublereal zeroi = 0.;
3827 
3828  /* System generated locals */
3829  integer i__1;
3830 
3831  /* Builtin functions */
3832 
3833  /* Local variables */
3834  static doublereal alas;
3835  static integer idum;
3836  static integer i__;
3837  static doublereal helim, celmr;
3838  static integer ic;
3839  static doublereal as, fn;
3840  static integer kk, nn, nw;
3841  static doublereal s1i, s2i, s1r, s2r, acs, cki, elm, csi, ckr, cyi[2],
3842  zdi, csr, cyr[2], zdr, str;
3843 
3844 /* ***BEGIN PROLOGUE ZKSCL */
3845 /* ***REFER TO ZBESK */
3846 
3847 /* SET K FUNCTIONS TO ZERO ON UNDERFLOW, CONTINUE RECURRENCE */
3848 /* ON SCALED FUNCTIONS UNTIL TWO MEMBERS COME ON SCALE, THEN */
3849 /* RETURN WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL. */
3850 
3851 /* ***ROUTINES CALLED ZUCHK,myzabs,ZLOG */
3852 /* ***END PROLOGUE ZKSCL */
3853 /* COMPLEX CK,CS,CY,CZERO,RZ,S1,S2,Y,ZR,ZD,CELM */
3854  /* Parameter adjustments */
3855  --yi;
3856  --yr;
3857 
3858  /* Function Body */
3859 
3860  *nz = 0;
3861  ic = 0;
3862  nn = min(2,*n);
3863  i__1 = nn;
3864  for (i__ = 1; i__ <= i__1; ++i__) {
3865  s1r = yr[i__];
3866  s1i = yi[i__];
3867  cyr[i__ - 1] = s1r;
3868  cyi[i__ - 1] = s1i;
3869  as = myzabs_(&s1r, &s1i);
3870  acs = -(*zrr) + log(as);
3871  ++(*nz);
3872  yr[i__] = zeror;
3873  yi[i__] = zeroi;
3874  if (acs < -(*elim)) {
3875  goto L10;
3876  }
3877  zlog_(&s1r, &s1i, &csr, &csi, &idum);
3878  csr -= *zrr;
3879  csi -= *zri;
3880  str = exp(csr) / *tol;
3881  csr = str * cos(csi);
3882  csi = str * sin(csi);
3883  zuchk_(&csr, &csi, &nw, ascle, tol);
3884  if (nw != 0) {
3885  goto L10;
3886  }
3887  yr[i__] = csr;
3888  yi[i__] = csi;
3889  ic = i__;
3890  --(*nz);
3891 L10:
3892  ;
3893  }
3894  if (*n == 1) {
3895  return 0;
3896  }
3897  if (ic > 1) {
3898  goto L20;
3899  }
3900  yr[1] = zeror;
3901  yi[1] = zeroi;
3902  *nz = 2;
3903 L20:
3904  if (*n == 2) {
3905  return 0;
3906  }
3907  if (*nz == 0) {
3908  return 0;
3909  }
3910  fn = *fnu + 1.;
3911  ckr = fn * *rzr;
3912  cki = fn * *rzi;
3913  s1r = cyr[0];
3914  s1i = cyi[0];
3915  s2r = cyr[1];
3916  s2i = cyi[1];
3917  helim = *elim * .5;
3918  elm = exp(-(*elim));
3919  celmr = elm;
3920  zdr = *zrr;
3921  zdi = *zri;
3922 
3923 /* FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE RECURRENCE IF */
3924 /* S2 GETS LARGER THAN EXP(ELIM/2) */
3925 
3926  i__1 = *n;
3927  for (i__ = 3; i__ <= i__1; ++i__) {
3928  kk = i__;
3929  csr = s2r;
3930  csi = s2i;
3931  s2r = ckr * csr - cki * csi + s1r;
3932  s2i = cki * csr + ckr * csi + s1i;
3933  s1r = csr;
3934  s1i = csi;
3935  ckr += *rzr;
3936  cki += *rzi;
3937  as = myzabs_(&s2r, &s2i);
3938  alas = log(as);
3939  acs = -zdr + alas;
3940  ++(*nz);
3941  yr[i__] = zeror;
3942  yi[i__] = zeroi;
3943  if (acs < -(*elim)) {
3944  goto L25;
3945  }
3946  zlog_(&s2r, &s2i, &csr, &csi, &idum);
3947  csr -= zdr;
3948  csi -= zdi;
3949  str = exp(csr) / *tol;
3950  csr = str * cos(csi);
3951  csi = str * sin(csi);
3952  zuchk_(&csr, &csi, &nw, ascle, tol);
3953  if (nw != 0) {
3954  goto L25;
3955  }
3956  yr[i__] = csr;
3957  yi[i__] = csi;
3958  --(*nz);
3959  if (ic == kk - 1) {
3960  goto L40;
3961  }
3962  ic = kk;
3963  goto L30;
3964 L25:
3965  if (alas < helim) {
3966  goto L30;
3967  }
3968  zdr -= *elim;
3969  s1r *= celmr;
3970  s1i *= celmr;
3971  s2r *= celmr;
3972  s2i *= celmr;
3973 L30:
3974  ;
3975  }
3976  *nz = *n;
3977  if (ic == *n) {
3978  *nz = *n - 1;
3979  }
3980  goto L45;
3981 L40:
3982  *nz = kk - 2;
3983 L45:
3984  i__1 = *nz;
3985  for (i__ = 1; i__ <= i__1; ++i__) {
3986  yr[i__] = zeror;
3987  yi[i__] = zeroi;
3988 /* L50: */
3989  }
3990  return 0;
3991 } /* zkscl_ */
3992 
3993 /* Subroutine */ int zlog_(doublereal *ar, doublereal *ai, doublereal *br, doublereal *bi, integer *ierr)
3994 {
3995  /* Initialized data */
3996 
3997  static doublereal dpi = 3.141592653589793238462643383;
3998  static doublereal dhpi = 1.570796326794896619231321696;
3999 
4000  /* Builtin functions */
4001 
4002  /* Local variables */
4003  static doublereal zm, dtheta;
4004 
4005 /* ***BEGIN PROLOGUE ZLOG */
4006 /* ***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY */
4007 
4008 /* DOUBLE PRECISION COMPLEX LOGARITHM B=CLOG(A) */
4009 /* IERR=0,NORMAL RETURN IERR=1, Z=CMPLX(0.0,0.0) */
4010 /* ***ROUTINES CALLED myzabs */
4011 /* ***END PROLOGUE ZLOG */
4012 
4013  *ierr = 0;
4014  if (*ar == 0.) {
4015  goto L10;
4016  }
4017  if (*ai == 0.) {
4018  goto L20;
4019  }
4020  dtheta = atan(*ai / *ar);
4021  if (dtheta <= 0.) {
4022  goto L40;
4023  }
4024  if (*ar < 0.) {
4025  dtheta -= dpi;
4026  }
4027  goto L50;
4028 L10:
4029  if (*ai == 0.) {
4030  goto L60;
4031  }
4032  *bi = dhpi;
4033  *br = log((abs(*ai)));
4034  if (*ai < 0.) {
4035  *bi = -(*bi);
4036  }
4037  return 0;
4038 L20:
4039  if (*ar > 0.) {
4040  goto L30;
4041  }
4042  *br = log((abs(*ar)));
4043  *bi = dpi;
4044  return 0;
4045 L30:
4046  *br = log(*ar);
4047  *bi = 0.;
4048  return 0;
4049 L40:
4050  if (*ar < 0.) {
4051  dtheta += dpi;
4052  }
4053 L50:
4054  zm = myzabs_(ar, ai);
4055  *br = log(zm);
4056  *bi = dtheta;
4057  return 0;
4058 L60:
4059  *ierr = 1;
4060  return 0;
4061 } /* zlog_ */
4062 
4063 /* Subroutine */
4064 int zmlri_(doublereal *zr, doublereal *zi, doublereal *fnu,
4065  integer *kode, integer *n,
4066  doublereal *yr, doublereal *yi, integer *nz, doublereal *tol)
4067 {
4068  /* Initialized data */
4069 
4070  static doublereal zeror = 0.;
4071  static doublereal zeroi = 0.;
4072  static doublereal coner = 1.;
4073  static doublereal conei = 0.;
4074 
4075  /* System generated locals */
4076  integer i__1, i__2;
4077  doublereal d__1, d__2, d__3;
4078 
4079  /* Builtin functions */
4080 
4081  /* Local variables */
4082  static doublereal flam, fkap, scle, tfnf;
4083  static integer idum, ifnu;
4084  static doublereal sumi, sumr;
4085  static integer i__, k, m, itime;
4086  static doublereal ak, bk, ap, at;
4087  static integer kk, km;
4088  static doublereal az;
4089  static doublereal cnormi, cnormr;
4090  static doublereal p1i, p2i, p1r, p2r, ack, cki, fnf, fkk, ckr;
4091  static integer iaz;
4092  static doublereal rho;
4093  static integer inu;
4094  static doublereal pti, raz, sti, rzi, ptr, str, tst, rzr, rho2;
4095 
4096 /* ***BEGIN PROLOGUE ZMLRI */
4097 /* ***REFER TO ZBESI,ZBESK */
4098 
4099 /* ZMLRI COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY THE */
4100 /* MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES. */
4101 
4102 /* ***ROUTINES CALLED DGAMLN,D1MACH,myzabs,ZEXP,ZLOG,ZMLT */
4103 /* ***END PROLOGUE ZMLRI */
4104 /* COMPLEX CK,CNORM,CONE,CTWO,CZERO,PT,P1,P2,RZ,SUM,Y,Z */
4105  /* Parameter adjustments */
4106  --yi;
4107  --yr;
4108 
4109  /* Function Body */
4110  scle = d1mach_(&c__1) / *tol;
4111  *nz = 0;
4112  az = myzabs_(zr, zi);
4113  iaz = (integer) ((real) az);
4114  ifnu = (integer) ((real) (*fnu));
4115  inu = ifnu + *n - 1;
4116  at = (doublereal) ((real) iaz) + 1.;
4117  raz = 1. / az;
4118  str = *zr * raz;
4119  sti = -(*zi) * raz;
4120  ckr = str * at * raz;
4121  cki = sti * at * raz;
4122  rzr = (str + str) * raz;
4123  rzi = (sti + sti) * raz;
4124  p1r = zeror;
4125  p1i = zeroi;
4126  p2r = coner;
4127  p2i = conei;
4128  ack = (at + 1.) * raz;
4129  rho = ack + sqrt(ack * ack - 1.);
4130  rho2 = rho * rho;
4131  tst = (rho2 + rho2) / ((rho2 - 1.) * (rho - 1.));
4132  tst /= *tol;
4133 /* ----------------------------------------------------------------------- */
4134 /* COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES */
4135 /* ----------------------------------------------------------------------- */
4136  ak = at;
4137  for (i__ = 1; i__ <= 80; ++i__) {
4138  ptr = p2r;
4139  pti = p2i;
4140  p2r = p1r - (ckr * ptr - cki * pti);
4141  p2i = p1i - (cki * ptr + ckr * pti);
4142  p1r = ptr;
4143  p1i = pti;
4144  ckr += rzr;
4145  cki += rzi;
4146  ap = myzabs_(&p2r, &p2i);
4147  if (ap > tst * ak * ak) {
4148  goto L20;
4149  }
4150  ak += 1.;
4151 /* L10: */
4152  }
4153  goto L110;
4154 L20:
4155  ++i__;
4156  k = 0;
4157  if (inu < iaz) {
4158  goto L40;
4159  }
4160 /* ----------------------------------------------------------------------- */
4161 /* COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS */
4162 /* ----------------------------------------------------------------------- */
4163  p1r = zeror;
4164  p1i = zeroi;
4165  p2r = coner;
4166  p2i = conei;
4167  at = (doublereal) ((real) inu) + 1.;
4168  str = *zr * raz;
4169  sti = -(*zi) * raz;
4170  ckr = str * at * raz;
4171  cki = sti * at * raz;
4172  ack = at * raz;
4173  tst = sqrt(ack / *tol);
4174  itime = 1;
4175  for (k = 1; k <= 80; ++k) {
4176  ptr = p2r;
4177  pti = p2i;
4178  p2r = p1r - (ckr * ptr - cki * pti);
4179  p2i = p1i - (ckr * pti + cki * ptr);
4180  p1r = ptr;
4181  p1i = pti;
4182  ckr += rzr;
4183  cki += rzi;
4184  ap = myzabs_(&p2r, &p2i);
4185  if (ap < tst) {
4186  goto L30;
4187  }
4188  if (itime == 2) {
4189  goto L40;
4190  }
4191  ack = myzabs_(&ckr, &cki);
4192  flam = ack + sqrt(ack * ack - 1.);
4193  fkap = ap / myzabs_(&p1r, &p1i);
4194  rho = min(flam,fkap);
4195  tst *= sqrt(rho / (rho * rho - 1.));
4196  itime = 2;
4197 L30:
4198  ;
4199  }
4200  goto L110;
4201 L40:
4202 /* ----------------------------------------------------------------------- */
4203 /* BACKWARD RECURRENCE AND SUM NORMALIZING RELATION */
4204 /* ----------------------------------------------------------------------- */
4205  ++k;
4206 /* Computing MAX */
4207  i__1 = i__ + iaz, i__2 = k + inu;
4208  kk = max(i__1,i__2);
4209  fkk = (doublereal) ((real) kk);
4210  p1r = zeror;
4211  p1i = zeroi;
4212 /* ----------------------------------------------------------------------- */
4213 /* SCALE P2 AND SUM BY SCLE */
4214 /* ----------------------------------------------------------------------- */
4215  p2r = scle;
4216  p2i = zeroi;
4217  fnf = *fnu - (doublereal) ((real) ifnu);
4218  tfnf = fnf + fnf;
4219  d__1 = fkk + tfnf + 1.;
4220  d__2 = fkk + 1.;
4221  d__3 = tfnf + 1.;
4222  bk = dgamln_(&d__1, &idum) - dgamln_(&d__2, &idum) - dgamln_(&d__3, &idum)
4223  ;
4224  bk = exp(bk);
4225  sumr = zeror;
4226  sumi = zeroi;
4227  km = kk - inu;
4228  i__1 = km;
4229  for (i__ = 1; i__ <= i__1; ++i__) {
4230  ptr = p2r;
4231  pti = p2i;
4232  p2r = p1r + (fkk + fnf) * (rzr * ptr - rzi * pti);
4233  p2i = p1i + (fkk + fnf) * (rzi * ptr + rzr * pti);
4234  p1r = ptr;
4235  p1i = pti;
4236  ak = 1. - tfnf / (fkk + tfnf);
4237  ack = bk * ak;
4238  sumr += (ack + bk) * p1r;
4239  sumi += (ack + bk) * p1i;
4240  bk = ack;
4241  fkk += -1.;
4242 /* L50: */
4243  }
4244  yr[*n] = p2r;
4245  yi[*n] = p2i;
4246  if (*n == 1) {
4247  goto L70;
4248  }
4249  i__1 = *n;
4250  for (i__ = 2; i__ <= i__1; ++i__) {
4251  ptr = p2r;
4252  pti = p2i;
4253  p2r = p1r + (fkk + fnf) * (rzr * ptr - rzi * pti);
4254  p2i = p1i + (fkk + fnf) * (rzi * ptr + rzr * pti);
4255  p1r = ptr;
4256  p1i = pti;
4257  ak = 1. - tfnf / (fkk + tfnf);
4258  ack = bk * ak;
4259  sumr += (ack + bk) * p1r;
4260  sumi += (ack + bk) * p1i;
4261  bk = ack;
4262  fkk += -1.;
4263  m = *n - i__ + 1;
4264  yr[m] = p2r;
4265  yi[m] = p2i;
4266 /* L60: */
4267  }
4268 L70:
4269  if (ifnu <= 0) {
4270  goto L90;
4271  }
4272  i__1 = ifnu;
4273  for (i__ = 1; i__ <= i__1; ++i__) {
4274  ptr = p2r;
4275  pti = p2i;
4276  p2r = p1r + (fkk + fnf) * (rzr * ptr - rzi * pti);
4277  p2i = p1i + (fkk + fnf) * (rzr * pti + rzi * ptr);
4278  p1r = ptr;
4279  p1i = pti;
4280  ak = 1. - tfnf / (fkk + tfnf);
4281  ack = bk * ak;
4282  sumr += (ack + bk) * p1r;
4283  sumi += (ack + bk) * p1i;
4284  bk = ack;
4285  fkk += -1.;
4286 /* L80: */
4287  }
4288 L90:
4289  ptr = *zr;
4290  pti = *zi;
4291  if (*kode == 2) {
4292  ptr = zeror;
4293  }
4294  zlog_(&rzr, &rzi, &str, &sti, &idum);
4295  p1r = -fnf * str + ptr;
4296  p1i = -fnf * sti + pti;
4297  d__1 = fnf + 1.;
4298  ap = dgamln_(&d__1, &idum);
4299  ptr = p1r - ap;
4300  pti = p1i;
4301 /* ----------------------------------------------------------------------- */
4302 /* THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW */
4303 /* IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES */
4304 /* ----------------------------------------------------------------------- */
4305  p2r += sumr;
4306  p2i += sumi;
4307  ap = myzabs_(&p2r, &p2i);
4308  p1r = 1. / ap;
4309  zexp_(&ptr, &pti, &str, &sti);
4310  ckr = str * p1r;
4311  cki = sti * p1r;
4312  ptr = p2r * p1r;
4313  pti = -p2i * p1r;
4314  zmlt_(&ckr, &cki, &ptr, &pti, &cnormr, &cnormi);
4315  i__1 = *n;
4316  for (i__ = 1; i__ <= i__1; ++i__) {
4317  str = yr[i__] * cnormr - yi[i__] * cnormi;
4318  yi[i__] = yr[i__] * cnormi + yi[i__] * cnormr;
4319  yr[i__] = str;
4320 /* L100: */
4321  }
4322  return 0;
4323 L110:
4324  *nz = -2;
4325  return 0;
4326 } /* zmlri_ */
4327 
4328 /* Subroutine */ int zmlt_(doublereal *ar, doublereal *ai, doublereal *br, doublereal *bi, doublereal *cr, doublereal *ci)
4329 {
4330  static doublereal ca, cb;
4331 
4332 /* ***BEGIN PROLOGUE ZMLT */
4333 /* ***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY */
4334 
4335 /* DOUBLE PRECISION COMPLEX MULTIPLY, C=A*B. */
4336 
4337 /* ***ROUTINES CALLED (NONE) */
4338 /* ***END PROLOGUE ZMLT */
4339  ca = *ar * *br - *ai * *bi;
4340  cb = *ar * *bi + *ai * *br;
4341  *cr = ca;
4342  *ci = cb;
4343  return 0;
4344 } /* zmlt_ */
4345 
4346 /* Subroutine */ int zrati_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *n, doublereal *cyr, doublereal *cyi, doublereal *tol)
4347 {
4348  /* Initialized data */
4349 
4350  static doublereal czeror = 0.;
4351  static doublereal czeroi = 0.;
4352  static doublereal coner = 1.;
4353  static doublereal conei = 0.;
4354  static doublereal rt2 = 1.41421356237309505;
4355 
4356  /* System generated locals */
4357  integer i__1;
4358  doublereal d__1;
4359 
4360  /* Builtin functions */
4361 
4362  /* Local variables */
4363  static doublereal flam, dfnu, fdnu;
4364  static integer magz, idnu;
4365  static doublereal fnup;
4366  static doublereal test, test1;
4367  static integer i__, k;
4368  static doublereal amagz;
4369  static integer itime;
4370  static doublereal ak;
4371  static integer id, kk;
4372  static doublereal az, cdfnui, cdfnur, ap1, ap2;
4373  static doublereal p1i, p2i, t1i, p1r, p2r, t1r, arg, rak, rho;
4374  static integer inu;
4375  static doublereal pti, tti, rzi, ptr, ttr, rzr, rap1;
4376 
4377 /* ***BEGIN PROLOGUE ZRATI */
4378 /* ***REFER TO ZBESI,ZBESK,ZBESH */
4379 
4380 /* ZRATI COMPUTES RATIOS OF I BESSEL FUNCTIONS BY BACKWARD */
4381 /* RECURRENCE. THE STARTING INDEX IS DETERMINED BY FORWARD */
4382 /* RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B, */
4383 /* MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973, */
4384 /* BESSEL FUNCTIONS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER, */
4385 /* BY D. J. SOOKNE. */
4386 
4387 /* ***ROUTINES CALLED myzabs,ZDIV */
4388 /* ***END PROLOGUE ZRATI */
4389 /* COMPLEX Z,CY(1),CONE,CZERO,P1,P2,T1,RZ,PT,CDFNU */
4390  /* Parameter adjustments */
4391  --cyi;
4392  --cyr;
4393 
4394  /* Function Body */
4395  az = myzabs_(zr, zi);
4396  inu = (integer) ((real) (*fnu));
4397  idnu = inu + *n - 1;
4398  magz = (integer) ((real) az);
4399  amagz = (doublereal) ((real) (magz + 1));
4400  fdnu = (doublereal) ((real) idnu);
4401  fnup = max(amagz,fdnu);
4402  id = idnu - magz - 1;
4403  itime = 1;
4404  k = 1;
4405  ptr = 1. / az;
4406  rzr = ptr * (*zr + *zr) * ptr;
4407  rzi = -ptr * (*zi + *zi) * ptr;
4408  t1r = rzr * fnup;
4409  t1i = rzi * fnup;
4410  p2r = -t1r;
4411  p2i = -t1i;
4412  p1r = coner;
4413  p1i = conei;
4414  t1r += rzr;
4415  t1i += rzi;
4416  if (id > 0) {
4417  id = 0;
4418  }
4419  ap2 = myzabs_(&p2r, &p2i);
4420  ap1 = myzabs_(&p1r, &p1i);
4421 /* ----------------------------------------------------------------------- */
4422 /* THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNU */
4423 /* GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT */
4424 /* P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR */
4425 /* PREMATURELY. */
4426 /* ----------------------------------------------------------------------- */
4427  arg = (ap2 + ap2) / (ap1 * *tol);
4428  test1 = sqrt(arg);
4429  test = test1;
4430  rap1 = 1. / ap1;
4431  p1r *= rap1;
4432  p1i *= rap1;
4433  p2r *= rap1;
4434  p2i *= rap1;
4435  ap2 *= rap1;
4436 L10:
4437  ++k;
4438  ap1 = ap2;
4439  ptr = p2r;
4440  pti = p2i;
4441  p2r = p1r - (t1r * ptr - t1i * pti);
4442  p2i = p1i - (t1r * pti + t1i * ptr);
4443  p1r = ptr;
4444  p1i = pti;
4445  t1r += rzr;
4446  t1i += rzi;
4447  ap2 = myzabs_(&p2r, &p2i);
4448  if (ap1 <= test) {
4449  goto L10;
4450  }
4451  if (itime == 2) {
4452  goto L20;
4453  }
4454  ak = myzabs_(&t1r, &t1i) * .5;
4455  flam = ak + sqrt(ak * ak - 1.);
4456 /* Computing MIN */
4457  d__1 = ap2 / ap1;
4458  rho = min(d__1,flam);
4459  test = test1 * sqrt(rho / (rho * rho - 1.));
4460  itime = 2;
4461  goto L10;
4462 L20:
4463  kk = k + 1 - id;
4464  ak = (doublereal) ((real) kk);
4465  t1r = ak;
4466  t1i = czeroi;
4467  dfnu = *fnu + (doublereal) ((real) (*n - 1));
4468  p1r = 1. / ap2;
4469  p1i = czeroi;
4470  p2r = czeror;
4471  p2i = czeroi;
4472  i__1 = kk;
4473  for (i__ = 1; i__ <= i__1; ++i__) {
4474  ptr = p1r;
4475  pti = p1i;
4476  rap1 = dfnu + t1r;
4477  ttr = rzr * rap1;
4478  tti = rzi * rap1;
4479  p1r = ptr * ttr - pti * tti + p2r;
4480  p1i = ptr * tti + pti * ttr + p2i;
4481  p2r = ptr;
4482  p2i = pti;
4483  t1r -= coner;
4484 /* L30: */
4485  }
4486  if (p1r != czeror || p1i != czeroi) {
4487  goto L40;
4488  }
4489  p1r = *tol;
4490  p1i = *tol;
4491 L40:
4492  zdiv_(&p2r, &p2i, &p1r, &p1i, &cyr[*n], &cyi[*n]);
4493  if (*n == 1) {
4494  return 0;
4495  }
4496  k = *n - 1;
4497  ak = (doublereal) ((real) k);
4498  t1r = ak;
4499  t1i = czeroi;
4500  cdfnur = *fnu * rzr;
4501  cdfnui = *fnu * rzi;
4502  i__1 = *n;
4503  for (i__ = 2; i__ <= i__1; ++i__) {
4504  ptr = cdfnur + (t1r * rzr - t1i * rzi) + cyr[k + 1];
4505  pti = cdfnui + (t1r * rzi + t1i * rzr) + cyi[k + 1];
4506  ak = myzabs_(&ptr, &pti);
4507  if (ak != czeror) {
4508  goto L50;
4509  }
4510  ptr = *tol;
4511  pti = *tol;
4512  ak = *tol * rt2;
4513 L50:
4514  rak = coner / ak;
4515  cyr[k] = rak * ptr * rak;
4516  cyi[k] = -rak * pti * rak;
4517  t1r -= coner;
4518  --k;
4519 /* L60: */
4520  }
4521  return 0;
4522 } /* zrati_ */
4523 
4524 /* Subroutine */ int zs1s2_(doublereal *zrr, doublereal *zri, doublereal *s1r, doublereal *s1i, doublereal *s2r, doublereal *s2i, integer *nz, doublereal *ascle, doublereal *alim, integer *iuf)
4525 {
4526  /* Initialized data */
4527 
4528  static doublereal zeror = 0.;
4529  static doublereal zeroi = 0.;
4530 
4531  /* Builtin functions */
4532 
4533  /* Local variables */
4534  static integer idum;
4535  static doublereal aa, c1i, as1, as2, c1r;
4536  static doublereal aln, s1di, s1dr;
4537 
4538 /* ***BEGIN PROLOGUE ZS1S2 */
4539 /* ***REFER TO ZBESK,ZAIRY */
4540 
4541 /* ZS1S2 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE */
4542 /* ADDITION OF THE I AND K FUNCTIONS IN THE ANALYTIC CON- */
4543 /* TINUATION FORMULA WHERE S1=K FUNCTION AND S2=I FUNCTION. */
4544 /* ON KODE=1 THE I AND K FUNCTIONS ARE DIFFERENT ORDERS OF */
4545 /* MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER */
4546 /* OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE */
4547 /* PRECISION ABOVE THE UNDERFLOW LIMIT. */
4548 
4549 /* ***ROUTINES CALLED myzabs,ZEXP,ZLOG */
4550 /* ***END PROLOGUE ZS1S2 */
4551 /* COMPLEX CZERO,C1,S1,S1D,S2,ZR */
4552  *nz = 0;
4553  as1 = myzabs_(s1r, s1i);
4554  as2 = myzabs_(s2r, s2i);
4555  if (*s1r == 0. && *s1i == 0.) {
4556  goto L10;
4557  }
4558  if (as1 == 0.) {
4559  goto L10;
4560  }
4561  aln = -(*zrr) - *zrr + log(as1);
4562  s1dr = *s1r;
4563  s1di = *s1i;
4564  *s1r = zeror;
4565  *s1i = zeroi;
4566  as1 = zeror;
4567  if (aln < -(*alim)) {
4568  goto L10;
4569  }
4570  zlog_(&s1dr, &s1di, &c1r, &c1i, &idum);
4571  c1r = c1r - *zrr - *zrr;
4572  c1i = c1i - *zri - *zri;
4573  zexp_(&c1r, &c1i, s1r, s1i);
4574  as1 = myzabs_(s1r, s1i);
4575  ++(*iuf);
4576 L10:
4577  aa = max(as1,as2);
4578  if (aa > *ascle) {
4579  return 0;
4580  }
4581  *s1r = zeror;
4582  *s1i = zeroi;
4583  *s2r = zeror;
4584  *s2i = zeroi;
4585  *nz = 1;
4586  *iuf = 0;
4587  return 0;
4588 } /* zs1s2_ */
4589 
4590 /* Subroutine */
4591 int zseri_(doublereal *zr, doublereal *zi, doublereal *fnu,
4592  integer *kode, integer *n, doublereal *yr, doublereal *yi,
4593  integer *nz,
4594  doublereal *tol, doublereal *elim, doublereal *alim)
4595 {
4596  /* Initialized data */
4597 
4598  static doublereal zeror = 0.;
4599  static doublereal zeroi = 0.;
4600  static doublereal coner = 1.;
4601  static doublereal conei = 0.;
4602 
4603  /* System generated locals */
4604  integer i__1;
4605 
4606  /* Builtin functions */
4607 
4608  /* Local variables */
4609  static doublereal dfnu;
4610  static integer idum;
4611  static doublereal atol, fnup;
4612  static integer i__, k, l, m, iflag;
4613  static doublereal s, coefi, ascle, coefr, crscr;
4614  static doublereal aa;
4615  static integer ib;
4616  static doublereal ak;
4617  static integer il;
4618  static doublereal az;
4619  static integer nn;
4620  static doublereal wi[2];
4621  static doublereal rs, ss;
4622  static integer nw;
4623  static doublereal wr[2];
4624  static doublereal s1i, s2i, s1r, s2r, cki, acz, arm, ckr, czi, hzi, raz,
4625  czr, sti, hzr, rzi, str, rzr, ak1i, ak1r, rtr1;
4626 
4627 /* ***BEGIN PROLOGUE ZSERI */
4628 /* ***REFER TO ZBESI,ZBESK */
4629 
4630 /* ZSERI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY */
4631 /* MEANS OF THE POWER SERIES FOR LARGE CABS(Z) IN THE */
4632 /* REGION CABS(Z).LE.2*SQRT(FNU+1). NZ=0 IS A NORMAL RETURN. */
4633 /* NZ.GT.0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO */
4634 /* DUE TO UNDERFLOW. NZ.LT.0 MEANS UNDERFLOW OCCURRED, BUT THE */
4635 /* CONDITION CABS(Z).LE.2*SQRT(FNU+1) WAS VIOLATED AND THE */
4636 /* COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ). */
4637 
4638 /* ***ROUTINES CALLED DGAMLN,D1MACH,ZUCHK,myzabs,ZDIV,ZLOG,ZMLT */
4639 /* ***END PROLOGUE ZSERI */
4640 /* COMPLEX AK1,CK,COEF,CONE,CRSC,CSCL,CZ,CZERO,HZ,RZ,S1,S2,Y,Z */
4641  /* Parameter adjustments */
4642  --yi;
4643  --yr;
4644 
4645  /* Function Body */
4646 
4647  *nz = 0;
4648  az = myzabs_(zr, zi);
4649  if (az == 0.) {
4650  goto L160;
4651  }
4652  arm = d1mach_(&c__1) * 1e3;
4653  rtr1 = sqrt(arm);
4654  crscr = 1.;
4655  iflag = 0;
4656  if (az < arm) {
4657  goto L150;
4658  }
4659  hzr = *zr * .5;
4660  hzi = *zi * .5;
4661  czr = zeror;
4662  czi = zeroi;
4663  if (az <= rtr1) {
4664  goto L10;
4665  }
4666  zmlt_(&hzr, &hzi, &hzr, &hzi, &czr, &czi);
4667 L10:
4668  acz = myzabs_(&czr, &czi);
4669  nn = *n;
4670  zlog_(&hzr, &hzi, &ckr, &cki, &idum);
4671 L20:
4672  dfnu = *fnu + (doublereal) ((real) (nn - 1));
4673  fnup = dfnu + 1.;
4674 /* ----------------------------------------------------------------------- */
4675 /* UNDERFLOW TEST */
4676 /* ----------------------------------------------------------------------- */
4677  ak1r = ckr * dfnu;
4678  ak1i = cki * dfnu;
4679  ak = dgamln_(&fnup, &idum);
4680  ak1r -= ak;
4681  if (*kode == 2) {
4682  ak1r -= *zr;
4683  }
4684  if (ak1r > -(*elim)) {
4685  goto L40;
4686  }
4687 L30:
4688  ++(*nz);
4689  yr[nn] = zeror;
4690  yi[nn] = zeroi;
4691  if (acz > dfnu) {
4692  goto L190;
4693  }
4694  --nn;
4695  if (nn == 0) {
4696  return 0;
4697  }
4698  goto L20;
4699 L40:
4700  if (ak1r > -(*alim)) {
4701  goto L50;
4702  }
4703  iflag = 1;
4704  ss = 1. / *tol;
4705  crscr = *tol;
4706  ascle = arm * ss;
4707 L50:
4708  aa = exp(ak1r);
4709  if (iflag == 1) {
4710  aa *= ss;
4711  }
4712  coefr = aa * cos(ak1i);
4713  coefi = aa * sin(ak1i);
4714  atol = *tol * acz / fnup;
4715  il = min(2,nn);
4716  i__1 = il;
4717  for (i__ = 1; i__ <= i__1; ++i__) {
4718  dfnu = *fnu + (doublereal) ((real) (nn - i__));
4719  fnup = dfnu + 1.;
4720  s1r = coner;
4721  s1i = conei;
4722  if (acz < *tol * fnup) {
4723  goto L70;
4724  }
4725  ak1r = coner;
4726  ak1i = conei;
4727  ak = fnup + 2.;
4728  s = fnup;
4729  aa = 2.;
4730 L60:
4731  rs = 1. / s;
4732  str = ak1r * czr - ak1i * czi;
4733  sti = ak1r * czi + ak1i * czr;
4734  ak1r = str * rs;
4735  ak1i = sti * rs;
4736  s1r += ak1r;
4737  s1i += ak1i;
4738  s += ak;
4739  ak += 2.;
4740  aa = aa * acz * rs;
4741  if (aa > atol) {
4742  goto L60;
4743  }
4744 L70:
4745  s2r = s1r * coefr - s1i * coefi;
4746  s2i = s1r * coefi + s1i * coefr;
4747  wr[i__ - 1] = s2r;
4748  wi[i__ - 1] = s2i;
4749  if (iflag == 0) {
4750  goto L80;
4751  }
4752  zuchk_(&s2r, &s2i, &nw, &ascle, tol);
4753  if (nw != 0) {
4754  goto L30;
4755  }
4756 L80:
4757  m = nn - i__ + 1;
4758  yr[m] = s2r * crscr;
4759  yi[m] = s2i * crscr;
4760  if (i__ == il) {
4761  goto L90;
4762  }
4763  zdiv_(&coefr, &coefi, &hzr, &hzi, &str, &sti);
4764  coefr = str * dfnu;
4765  coefi = sti * dfnu;
4766 L90:
4767  ;
4768  }
4769  if (nn <= 2) {
4770  return 0;
4771  }
4772  k = nn - 2;
4773  ak = (doublereal) ((real) k);
4774  raz = 1. / az;
4775  str = *zr * raz;
4776  sti = -(*zi) * raz;
4777  rzr = (str + str) * raz;
4778  rzi = (sti + sti) * raz;
4779  if (iflag == 1) {
4780  goto L120;
4781  }
4782  ib = 3;
4783 L100:
4784  i__1 = nn;
4785  for (i__ = ib; i__ <= i__1; ++i__) {
4786  yr[k] = (ak + *fnu) * (rzr * yr[k + 1] - rzi * yi[k + 1]) + yr[k + 2];
4787  yi[k] = (ak + *fnu) * (rzr * yi[k + 1] + rzi * yr[k + 1]) + yi[k + 2];
4788  ak += -1.;
4789  --k;
4790 /* L110: */
4791  }
4792  return 0;
4793 /* ----------------------------------------------------------------------- */
4794 /* RECUR BACKWARD WITH SCALED VALUES */
4795 /* ----------------------------------------------------------------------- */
4796 L120:
4797 /* ----------------------------------------------------------------------- */
4798 /* EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE */
4799 /* UNDERFLOW LIMIT = ASCLE = D1MACH(1)*SS*1.0D+3 */
4800 /* ----------------------------------------------------------------------- */
4801  s1r = wr[0];
4802  s1i = wi[0];
4803  s2r = wr[1];
4804  s2i = wi[1];
4805  i__1 = nn;
4806  for (l = 3; l <= i__1; ++l) {
4807  ckr = s2r;
4808  cki = s2i;
4809  s2r = s1r + (ak + *fnu) * (rzr * ckr - rzi * cki);
4810  s2i = s1i + (ak + *fnu) * (rzr * cki + rzi * ckr);
4811  s1r = ckr;
4812  s1i = cki;
4813  ckr = s2r * crscr;
4814  cki = s2i * crscr;
4815  yr[k] = ckr;
4816  yi[k] = cki;
4817  ak += -1.;
4818  --k;
4819  if (myzabs_(&ckr, &cki) > ascle) {
4820  goto L140;
4821  }
4822 /* L130: */
4823  }
4824  return 0;
4825 L140:
4826  ib = l + 1;
4827  if (ib > nn) {
4828  return 0;
4829  }
4830  goto L100;
4831 L150:
4832  *nz = *n;
4833  if (*fnu == 0.) {
4834  --(*nz);
4835  }
4836 L160:
4837  yr[1] = zeror;
4838  yi[1] = zeroi;
4839  if (*fnu != 0.) {
4840  goto L170;
4841  }
4842  yr[1] = coner;
4843  yi[1] = conei;
4844 L170:
4845  if (*n == 1) {
4846  return 0;
4847  }
4848  i__1 = *n;
4849  for (i__ = 2; i__ <= i__1; ++i__) {
4850  yr[i__] = zeror;
4851  yi[i__] = zeroi;
4852 /* L180: */
4853  }
4854  return 0;
4855 /* ----------------------------------------------------------------------- */
4856 /* RETURN WITH NZ.LT.0 IF CABS(Z*Z/4).GT.FNU+N-NZ-1 COMPLETE */
4857 /* THE CALCULATION IN CBINU WITH N=N-IABS(NZ) */
4858 /* ----------------------------------------------------------------------- */
4859 L190:
4860  *nz = -(*nz);
4861  return 0;
4862 } /* zseri_ */
4863 
4864 /* Subroutine */ int zshch_(doublereal *zr, doublereal *zi, doublereal *cshr, doublereal *cshi, doublereal *cchr, doublereal *cchi)
4865 {
4866  /* Builtin functions */
4867 
4868  /* Local variables */
4869  static doublereal ch, cn, sh, sn;
4870 
4871 /* ***BEGIN PROLOGUE ZSHCH */
4872 /* ***REFER TO ZBESK,ZBESH */
4873 
4874 /* ZSHCH COMPUTES THE COMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y) */
4875 /* AND CCH=COSH(X+I*Y), WHERE I**2=-1. */
4876 
4877 /* ***ROUTINES CALLED (NONE) */
4878 /* ***END PROLOGUE ZSHCH */
4879 
4880  sh = sinh(*zr);
4881  ch = cosh(*zr);
4882  sn = sin(*zi);
4883  cn = cos(*zi);
4884  *cshr = sh * cn;
4885  *cshi = ch * sn;
4886  *cchr = ch * cn;
4887  *cchi = sh * sn;
4888  return 0;
4889 } /* zshch_ */
4890 
4891 /* Subroutine */ int zsqrt_(const doublereal *ar, const doublereal *ai, doublereal *br, doublereal *bi)
4892 {
4893  /* Initialized data */
4894 
4895  static doublereal drt = .7071067811865475244008443621;
4896  static doublereal dpi = 3.141592653589793238462643383;
4897 
4898  /* Builtin functions */
4899  /* Local variables */
4900  static doublereal zm, dtheta;
4901 
4902 /* ***BEGIN PROLOGUE ZSQRT */
4903 /* ***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY */
4904 
4905 /* DOUBLE PRECISION COMPLEX SQUARE ROOT, B=CSQRT(A) */
4906 
4907 /* ***ROUTINES CALLED myzabs */
4908 /* ***END PROLOGUE ZSQRT */
4909  zm = myzabs_(ar, ai);
4910  zm = sqrt(zm);
4911  if (*ar == 0.) {
4912  goto L10;
4913  }
4914  if (*ai == 0.) {
4915  goto L20;
4916  }
4917  dtheta = atan(*ai / *ar);
4918  if (dtheta <= 0.) {
4919  goto L40;
4920  }
4921  if (*ar < 0.) {
4922  dtheta -= dpi;
4923  }
4924  goto L50;
4925 L10:
4926  if (*ai > 0.) {
4927  goto L60;
4928  }
4929  if (*ai < 0.) {
4930  goto L70;
4931  }
4932  *br = 0.;
4933  *bi = 0.;
4934  return 0;
4935 L20:
4936  if (*ar > 0.) {
4937  goto L30;
4938  }
4939  *br = 0.;
4940  *bi = sqrt((abs(*ar)));
4941  return 0;
4942 L30:
4943  *br = sqrt(*ar);
4944  *bi = 0.;
4945  return 0;
4946 L40:
4947  if (*ar < 0.) {
4948  dtheta += dpi;
4949  }
4950 L50:
4951  dtheta *= .5;
4952  *br = zm * cos(dtheta);
4953  *bi = zm * sin(dtheta);
4954  return 0;
4955 L60:
4956  *br = zm * drt;
4957  *bi = zm * drt;
4958  return 0;
4959 L70:
4960  *br = zm * drt;
4961  *bi = -zm * drt;
4962  return 0;
4963 } /* zsqrt_ */
4964 
4965 /* Subroutine */ int zuchk_(doublereal *yr, doublereal *yi, integer *nz, doublereal *ascle, doublereal *tol)
4966 {
4967  static doublereal wi, ss, st, wr;
4968 
4969 /* ***BEGIN PROLOGUE ZUCHK */
4970 /* ***REFER TO ZSERI,ZUOIK,ZUNK1,ZUNK2,ZUNI1,ZUNI2,ZKSCL */
4971 
4972 /* Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN */
4973 /* EXP(-ALIM)=ASCLE=1.0E+3*D1MACH(1)/TOL. THE TEST IS MADE TO SEE */
4974 /* IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDERFLOW */
4975 /* WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED */
4976 /* IF THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE */
4977 /* OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE */
4978 /* ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED. */
4979 
4980 /* ***ROUTINES CALLED (NONE) */
4981 /* ***END PROLOGUE ZUCHK */
4982 
4983 /* COMPLEX Y */
4984  *nz = 0;
4985  wr = abs(*yr);
4986  wi = abs(*yi);
4987  st = min(wr,wi);
4988  if (st > *ascle) {
4989  return 0;
4990  }
4991  ss = max(wr,wi);
4992  st /= *tol;
4993  if (ss < st) {
4994  *nz = 1;
4995  }
4996  return 0;
4997 } /* zuchk_ */
4998 
4999 /* Subroutine */ int zunhj_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *ipmtr, doublereal *tol, doublereal *phir, doublereal *phii, doublereal *argr, doublereal *argi, doublereal *zeta1r, doublereal *zeta1i, doublereal *zeta2r, doublereal *zeta2i, doublereal *asumr, doublereal *asumi, doublereal *bsumr, doublereal *bsumi)
5000 {
5001  /* Initialized data */
5002 
5003  static doublereal ar[14] = { 1.,.104166666666666667,.0835503472222222222,
5004  .12822657455632716,.291849026464140464,.881627267443757652,
5005  3.32140828186276754,14.9957629868625547,78.9230130115865181,
5006  474.451538868264323,3207.49009089066193,24086.5496408740049,
5007  198923.119169509794,1791902.00777534383 };
5008  static doublereal br[14] = { 1.,-.145833333333333333,
5009  -.0987413194444444444,-.143312053915895062,-.317227202678413548,
5010  -.942429147957120249,-3.51120304082635426,-15.7272636203680451,
5011  -82.2814390971859444,-492.355370523670524,-3316.21856854797251,
5012  -24827.6742452085896,-204526.587315129788,-1838444.9170682099 };
5013  static doublereal c__[105] = { 1.,-.208333333333333333,.125,
5014  .334201388888888889,-.401041666666666667,.0703125,
5015  -1.02581259645061728,1.84646267361111111,-.8912109375,.0732421875,
5016  4.66958442342624743,-11.2070026162229938,8.78912353515625,
5017  -2.3640869140625,.112152099609375,-28.2120725582002449,
5018  84.6362176746007346,-91.8182415432400174,42.5349987453884549,
5019  -7.3687943594796317,.227108001708984375,212.570130039217123,
5020  -765.252468141181642,1059.99045252799988,-699.579627376132541,
5021  218.19051174421159,-26.4914304869515555,.572501420974731445,
5022  -1919.457662318407,8061.72218173730938,-13586.5500064341374,
5023  11655.3933368645332,-5305.64697861340311,1200.90291321635246,
5024  -108.090919788394656,1.7277275025844574,20204.2913309661486,
5025  -96980.5983886375135,192547.001232531532,-203400.177280415534,
5026  122200.46498301746,-41192.6549688975513,7109.51430248936372,
5027  -493.915304773088012,6.07404200127348304,-242919.187900551333,
5028  1311763.6146629772,-2998015.91853810675,3763271.297656404,
5029  -2813563.22658653411,1268365.27332162478,-331645.172484563578,
5030  45218.7689813627263,-2499.83048181120962,24.3805296995560639,
5031  3284469.85307203782,-19706819.1184322269,50952602.4926646422,
5032  -74105148.2115326577,66344512.2747290267,-37567176.6607633513,
5033  13288767.1664218183,-2785618.12808645469,308186.404612662398,
5034  -13886.0897537170405,110.017140269246738,-49329253.664509962,
5035  325573074.185765749,-939462359.681578403,1553596899.57058006,
5036  -1621080552.10833708,1106842816.82301447,-495889784.275030309,
5037  142062907.797533095,-24474062.7257387285,2243768.17792244943,
5038  -84005.4336030240853,551.335896122020586,814789096.118312115,
5039  -5866481492.05184723,18688207509.2958249,-34632043388.1587779,
5040  41280185579.753974,-33026599749.8007231,17954213731.1556001,
5041  -6563293792.61928433,1559279864.87925751,-225105661.889415278,
5042  17395107.5539781645,-549842.327572288687,3038.09051092238427,
5043  -14679261247.6956167,114498237732.02581,-399096175224.466498,
5044  819218669548.577329,-1098375156081.22331,1008158106865.38209,
5045  -645364869245.376503,287900649906.150589,-87867072178.0232657,
5046  17634730606.8349694,-2167164983.22379509,143157876.718888981,
5047  -3871833.44257261262,18257.7554742931747 };
5048  static doublereal alfa[180] = { -.00444444444444444444,
5049  -9.22077922077922078e-4,-8.84892884892884893e-5,
5050  1.65927687832449737e-4,2.4669137274179291e-4,
5051  2.6599558934625478e-4,2.61824297061500945e-4,
5052  2.48730437344655609e-4,2.32721040083232098e-4,
5053  2.16362485712365082e-4,2.00738858762752355e-4,
5054  1.86267636637545172e-4,1.73060775917876493e-4,
5055  1.61091705929015752e-4,1.50274774160908134e-4,
5056  1.40503497391269794e-4,1.31668816545922806e-4,
5057  1.23667445598253261e-4,1.16405271474737902e-4,
5058  1.09798298372713369e-4,1.03772410422992823e-4,
5059  9.82626078369363448e-5,9.32120517249503256e-5,
5060  8.85710852478711718e-5,8.42963105715700223e-5,
5061  8.03497548407791151e-5,7.66981345359207388e-5,
5062  7.33122157481777809e-5,7.01662625163141333e-5,
5063  6.72375633790160292e-5,6.93735541354588974e-4,
5064  2.32241745182921654e-4,-1.41986273556691197e-5,
5065  -1.1644493167204864e-4,-1.50803558053048762e-4,
5066  -1.55121924918096223e-4,-1.46809756646465549e-4,
5067  -1.33815503867491367e-4,-1.19744975684254051e-4,
5068  -1.0618431920797402e-4,-9.37699549891194492e-5,
5069  -8.26923045588193274e-5,-7.29374348155221211e-5,
5070  -6.44042357721016283e-5,-5.69611566009369048e-5,
5071  -5.04731044303561628e-5,-4.48134868008882786e-5,
5072  -3.98688727717598864e-5,-3.55400532972042498e-5,
5073  -3.1741425660902248e-5,-2.83996793904174811e-5,
5074  -2.54522720634870566e-5,-2.28459297164724555e-5,
5075  -2.05352753106480604e-5,-1.84816217627666085e-5,
5076  -1.66519330021393806e-5,-1.50179412980119482e-5,
5077  -1.35554031379040526e-5,-1.22434746473858131e-5,
5078  -1.10641884811308169e-5,-3.54211971457743841e-4,
5079  -1.56161263945159416e-4,3.0446550359493641e-5,
5080  1.30198655773242693e-4,1.67471106699712269e-4,
5081  1.70222587683592569e-4,1.56501427608594704e-4,
5082  1.3633917097744512e-4,1.14886692029825128e-4,
5083  9.45869093034688111e-5,7.64498419250898258e-5,
5084  6.07570334965197354e-5,4.74394299290508799e-5,
5085  3.62757512005344297e-5,2.69939714979224901e-5,
5086  1.93210938247939253e-5,1.30056674793963203e-5,
5087  7.82620866744496661e-6,3.59257485819351583e-6,
5088  1.44040049814251817e-7,-2.65396769697939116e-6,
5089  -4.9134686709848591e-6,-6.72739296091248287e-6,
5090  -8.17269379678657923e-6,-9.31304715093561232e-6,
5091  -1.02011418798016441e-5,-1.0880596251059288e-5,
5092  -1.13875481509603555e-5,-1.17519675674556414e-5,
5093  -1.19987364870944141e-5,3.78194199201772914e-4,
5094  2.02471952761816167e-4,-6.37938506318862408e-5,
5095  -2.38598230603005903e-4,-3.10916256027361568e-4,
5096  -3.13680115247576316e-4,-2.78950273791323387e-4,
5097  -2.28564082619141374e-4,-1.75245280340846749e-4,
5098  -1.25544063060690348e-4,-8.22982872820208365e-5,
5099  -4.62860730588116458e-5,-1.72334302366962267e-5,
5100  5.60690482304602267e-6,2.313954431482868e-5,
5101  3.62642745856793957e-5,4.58006124490188752e-5,
5102  5.2459529495911405e-5,5.68396208545815266e-5,
5103  5.94349820393104052e-5,6.06478527578421742e-5,
5104  6.08023907788436497e-5,6.01577894539460388e-5,
5105  5.891996573446985e-5,5.72515823777593053e-5,
5106  5.52804375585852577e-5,5.3106377380288017e-5,
5107  5.08069302012325706e-5,4.84418647620094842e-5,
5108  4.6056858160747537e-5,-6.91141397288294174e-4,
5109  -4.29976633058871912e-4,1.83067735980039018e-4,
5110  6.60088147542014144e-4,8.75964969951185931e-4,
5111  8.77335235958235514e-4,7.49369585378990637e-4,
5112  5.63832329756980918e-4,3.68059319971443156e-4,
5113  1.88464535514455599e-4,3.70663057664904149e-5,
5114  -8.28520220232137023e-5,-1.72751952869172998e-4,
5115  -2.36314873605872983e-4,-2.77966150694906658e-4,
5116  -3.02079514155456919e-4,-3.12594712643820127e-4,
5117  -3.12872558758067163e-4,-3.05678038466324377e-4,
5118  -2.93226470614557331e-4,-2.77255655582934777e-4,
5119  -2.59103928467031709e-4,-2.39784014396480342e-4,
5120  -2.20048260045422848e-4,-2.00443911094971498e-4,
5121  -1.81358692210970687e-4,-1.63057674478657464e-4,
5122  -1.45712672175205844e-4,-1.29425421983924587e-4,
5123  -1.14245691942445952e-4,.00192821964248775885,
5124  .00135592576302022234,-7.17858090421302995e-4,
5125  -.00258084802575270346,-.00349271130826168475,
5126  -.00346986299340960628,-.00282285233351310182,
5127  -.00188103076404891354,-8.895317183839476e-4,
5128  3.87912102631035228e-6,7.28688540119691412e-4,
5129  .00126566373053457758,.00162518158372674427,.00183203153216373172,
5130  .00191588388990527909,.00190588846755546138,.00182798982421825727,
5131  .0017038950642112153,.00155097127171097686,.00138261421852276159,
5132  .00120881424230064774,.00103676532638344962,
5133  8.71437918068619115e-4,7.16080155297701002e-4,
5134  5.72637002558129372e-4,4.42089819465802277e-4,
5135  3.24724948503090564e-4,2.20342042730246599e-4,
5136  1.28412898401353882e-4,4.82005924552095464e-5 };
5137  static doublereal beta[210] = { .0179988721413553309,
5138  .00559964911064388073,.00288501402231132779,.00180096606761053941,
5139  .00124753110589199202,9.22878876572938311e-4,
5140  7.14430421727287357e-4,5.71787281789704872e-4,
5141  4.69431007606481533e-4,3.93232835462916638e-4,
5142  3.34818889318297664e-4,2.88952148495751517e-4,
5143  2.52211615549573284e-4,2.22280580798883327e-4,
5144  1.97541838033062524e-4,1.76836855019718004e-4,
5145  1.59316899661821081e-4,1.44347930197333986e-4,
5146  1.31448068119965379e-4,1.20245444949302884e-4,
5147  1.10449144504599392e-4,1.01828770740567258e-4,
5148  9.41998224204237509e-5,8.74130545753834437e-5,
5149  8.13466262162801467e-5,7.59002269646219339e-5,
5150  7.09906300634153481e-5,6.65482874842468183e-5,
5151  6.25146958969275078e-5,5.88403394426251749e-5,
5152  -.00149282953213429172,-8.78204709546389328e-4,
5153  -5.02916549572034614e-4,-2.94822138512746025e-4,
5154  -1.75463996970782828e-4,-1.04008550460816434e-4,
5155  -5.96141953046457895e-5,-3.1203892907609834e-5,
5156  -1.26089735980230047e-5,-2.42892608575730389e-7,
5157  8.05996165414273571e-6,1.36507009262147391e-5,
5158  1.73964125472926261e-5,1.9867297884213378e-5,
5159  2.14463263790822639e-5,2.23954659232456514e-5,
5160  2.28967783814712629e-5,2.30785389811177817e-5,
5161  2.30321976080909144e-5,2.28236073720348722e-5,
5162  2.25005881105292418e-5,2.20981015361991429e-5,
5163  2.16418427448103905e-5,2.11507649256220843e-5,
5164  2.06388749782170737e-5,2.01165241997081666e-5,
5165  1.95913450141179244e-5,1.9068936791043674e-5,
5166  1.85533719641636667e-5,1.80475722259674218e-5,
5167  5.5221307672129279e-4,4.47932581552384646e-4,
5168  2.79520653992020589e-4,1.52468156198446602e-4,
5169  6.93271105657043598e-5,1.76258683069991397e-5,
5170  -1.35744996343269136e-5,-3.17972413350427135e-5,
5171  -4.18861861696693365e-5,-4.69004889379141029e-5,
5172  -4.87665447413787352e-5,-4.87010031186735069e-5,
5173  -4.74755620890086638e-5,-4.55813058138628452e-5,
5174  -4.33309644511266036e-5,-4.09230193157750364e-5,
5175  -3.84822638603221274e-5,-3.60857167535410501e-5,
5176  -3.37793306123367417e-5,-3.15888560772109621e-5,
5177  -2.95269561750807315e-5,-2.75978914828335759e-5,
5178  -2.58006174666883713e-5,-2.413083567612802e-5,
5179  -2.25823509518346033e-5,-2.11479656768912971e-5,
5180  -1.98200638885294927e-5,-1.85909870801065077e-5,
5181  -1.74532699844210224e-5,-1.63997823854497997e-5,
5182  -4.74617796559959808e-4,-4.77864567147321487e-4,
5183  -3.20390228067037603e-4,-1.61105016119962282e-4,
5184  -4.25778101285435204e-5,3.44571294294967503e-5,
5185  7.97092684075674924e-5,1.031382367082722e-4,
5186  1.12466775262204158e-4,1.13103642108481389e-4,
5187  1.08651634848774268e-4,1.01437951597661973e-4,
5188  9.29298396593363896e-5,8.40293133016089978e-5,
5189  7.52727991349134062e-5,6.69632521975730872e-5,
5190  5.92564547323194704e-5,5.22169308826975567e-5,
5191  4.58539485165360646e-5,4.01445513891486808e-5,
5192  3.50481730031328081e-5,3.05157995034346659e-5,
5193  2.64956119950516039e-5,2.29363633690998152e-5,
5194  1.97893056664021636e-5,1.70091984636412623e-5,
5195  1.45547428261524004e-5,1.23886640995878413e-5,
5196  1.04775876076583236e-5,8.79179954978479373e-6,
5197  7.36465810572578444e-4,8.72790805146193976e-4,
5198  6.22614862573135066e-4,2.85998154194304147e-4,
5199  3.84737672879366102e-6,-1.87906003636971558e-4,
5200  -2.97603646594554535e-4,-3.45998126832656348e-4,
5201  -3.53382470916037712e-4,-3.35715635775048757e-4,
5202  -3.04321124789039809e-4,-2.66722723047612821e-4,
5203  -2.27654214122819527e-4,-1.89922611854562356e-4,
5204  -1.5505891859909387e-4,-1.2377824076187363e-4,
5205  -9.62926147717644187e-5,-7.25178327714425337e-5,
5206  -5.22070028895633801e-5,-3.50347750511900522e-5,
5207  -2.06489761035551757e-5,-8.70106096849767054e-6,
5208  1.1369868667510029e-6,9.16426474122778849e-6,
5209  1.5647778542887262e-5,2.08223629482466847e-5,
5210  2.48923381004595156e-5,2.80340509574146325e-5,
5211  3.03987774629861915e-5,3.21156731406700616e-5,
5212  -.00180182191963885708,-.00243402962938042533,
5213  -.00183422663549856802,-7.62204596354009765e-4,
5214  2.39079475256927218e-4,9.49266117176881141e-4,
5215  .00134467449701540359,.00148457495259449178,.00144732339830617591,
5216  .00130268261285657186,.00110351597375642682,
5217  8.86047440419791759e-4,6.73073208165665473e-4,
5218  4.77603872856582378e-4,3.05991926358789362e-4,
5219  1.6031569459472163e-4,4.00749555270613286e-5,
5220  -5.66607461635251611e-5,-1.32506186772982638e-4,
5221  -1.90296187989614057e-4,-2.32811450376937408e-4,
5222  -2.62628811464668841e-4,-2.82050469867598672e-4,
5223  -2.93081563192861167e-4,-2.97435962176316616e-4,
5224  -2.96557334239348078e-4,-2.91647363312090861e-4,
5225  -2.83696203837734166e-4,-2.73512317095673346e-4,
5226  -2.6175015580676858e-4,.00638585891212050914,
5227  .00962374215806377941,.00761878061207001043,.00283219055545628054,
5228  -.0020984135201272009,-.00573826764216626498,
5229  -.0077080424449541462,-.00821011692264844401,
5230  -.00765824520346905413,-.00647209729391045177,
5231  -.00499132412004966473,-.0034561228971313328,
5232  -.00201785580014170775,-7.59430686781961401e-4,
5233  2.84173631523859138e-4,.00110891667586337403,
5234  .00172901493872728771,.00216812590802684701,.00245357710494539735,
5235  .00261281821058334862,.00267141039656276912,.0026520307339598043,
5236  .00257411652877287315,.00245389126236094427,.00230460058071795494,
5237  .00213684837686712662,.00195896528478870911,.00177737008679454412,
5238  .00159690280765839059,.00142111975664438546 };
5239  static doublereal gama[30] = { .629960524947436582,.251984209978974633,
5240  .154790300415655846,.110713062416159013,.0857309395527394825,
5241  .0697161316958684292,.0586085671893713576,.0504698873536310685,
5242  .0442600580689154809,.0393720661543509966,.0354283195924455368,
5243  .0321818857502098231,.0294646240791157679,.0271581677112934479,
5244  .0251768272973861779,.0234570755306078891,.0219508390134907203,
5245  .020621082823564624,.0194388240897880846,.0183810633800683158,
5246  .0174293213231963172,.0165685837786612353,.0157865285987918445,
5247  .0150729501494095594,.0144193250839954639,.0138184805735341786,
5248  .0132643378994276568,.0127517121970498651,.0122761545318762767,
5249  .0118338262398482403 };
5250  static doublereal ex1 = .333333333333333333;
5251  static doublereal ex2 = .666666666666666667;
5252  static doublereal hpi = 1.57079632679489662;
5253  static doublereal gpi = 3.14159265358979324;
5254  static doublereal thpi = 4.71238898038468986;
5255  static doublereal zeror = 0.;
5256  static doublereal zeroi = 0.;
5257  static doublereal coner = 1.;
5258  static doublereal conei = 0.;
5259 
5260  /* System generated locals */
5261  integer i__1, i__2;
5262  doublereal d__1;
5263 
5264  /* Builtin functions */
5265 
5266  /* Local variables */
5267  static doublereal rfn13;
5268  static integer idum;
5269  static doublereal atol, btol, tfni;
5270  static integer kmax;
5271  static doublereal azth, tzai, tfnr, rfnu;
5272  static doublereal zthi, test, tzar, zthr, rfnu2;
5273  static integer j, k, l, m;
5274  static doublereal zetai, ptfni, sumai, sumbi, zetar, ptfnr, razth, sumar,
5275  sumbr, rzthi;
5276  static integer l1, l2;
5277  static doublereal rzthr, rtzti;
5278  static doublereal rtztr, ac, ap[30], pi[30];
5279  static integer is, jr, ks, ju;
5280  static doublereal pp, wi, pr[30];
5281  static integer lr;
5282  static doublereal wr;
5283  static doublereal aw2;
5284  static integer kp1;
5285  static doublereal przthi, t2i, w2i, t2r, przthr, w2r, ang, fn13, fn23;
5286  static integer ias;
5287  static doublereal cri[14], dri[14];
5288  static integer ibs;
5289  static doublereal zai, zbi, zci, crr[14], drr[14], raw, zar, upi[14], sti,
5290  zbr, zcr, upr[14], str, raw2;
5291  static integer lrp1;
5292 
5293 /* ***BEGIN PROLOGUE ZUNHJ */
5294 /* ***REFER TO ZBESI,ZBESK */
5295 
5296 /* REFERENCES */
5297 /* HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ AND I.A. */
5298 /* STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9. */
5299 
5300 /* ASYMPTOTICS AND SPECIAL FUNCTIONS BY F.W.J. OLVER, ACADEMIC */
5301 /* PRESS, N.Y., 1974, PAGE 420 */
5302 
5303 /* ABSTRACT */
5304 /* ZUNHJ COMPUTES PARAMETERS FOR BESSEL FUNCTIONS C(FNU,Z) = */
5305 /* J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU */
5306 /* BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION */
5307 
5308 /* C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) ) */
5309 
5310 /* FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS */
5311 /* AN AIRY FUNCTION AND DAIRY IS ITS DERIVATIVE. */
5312 
5313 /* (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2, */
5314 
5315 /* ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING */
5316 /* PURPOSES IN AIRY FUNCTIONS FROM CAIRY OR CBIRY. */
5317 
5318 /* MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND */
5319 /* MUST BE SPECIFIED. IPMTR=0 RETURNS ALL PARAMETERS. IPMTR= */
5320 /* 1 COMPUTES ALL EXCEPT ASUM AND BSUM. */
5321 
5322 /* ***ROUTINES CALLED myzabs,ZDIV,ZLOG,ZSQRT,D1MACH */
5323 /* ***END PROLOGUE ZUNHJ */
5324 /* COMPLEX ARG,ASUM,BSUM,CFNU,CONE,CR,CZERO,DR,P,PHI,PRZTH,PTFN, */
5325 /* *RFN13,RTZTA,RZTH,SUMA,SUMB,TFN,T2,UP,W,W2,Z,ZA,ZB,ZC,ZETA,ZETA1, */
5326 /* *ZETA2,ZTH */
5327 
5328  rfnu = 1. / *fnu;
5329 /* ----------------------------------------------------------------------- */
5330 /* OVERFLOW TEST (Z/FNU TOO SMALL) */
5331 /* ----------------------------------------------------------------------- */
5332  test = d1mach_(&c__1) * 1e3;
5333  ac = *fnu * test;
5334  if (abs(*zr) > ac || abs(*zi) > ac) {
5335  goto L15;
5336  }
5337  *zeta1r = (d__1 = log(test), abs(d__1)) * 2. + *fnu;
5338  *zeta1i = 0.;
5339  *zeta2r = *fnu;
5340  *zeta2i = 0.;
5341  *phir = 1.;
5342  *phii = 0.;
5343  *argr = 1.;
5344  *argi = 0.;
5345  return 0;
5346 L15:
5347  zbr = *zr * rfnu;
5348  zbi = *zi * rfnu;
5349  rfnu2 = rfnu * rfnu;
5350 /* ----------------------------------------------------------------------- */
5351 /* COMPUTE IN THE FOURTH QUADRANT */
5352 /* ----------------------------------------------------------------------- */
5353  fn13 = pow_dd(fnu, &ex1);
5354  fn23 = fn13 * fn13;
5355  rfn13 = 1. / fn13;
5356  w2r = coner - zbr * zbr + zbi * zbi;
5357  w2i = conei - zbr * zbi - zbr * zbi;
5358  aw2 = myzabs_(&w2r, &w2i);
5359  if (aw2 > .25) {
5360  goto L130;
5361  }
5362 /* ----------------------------------------------------------------------- */
5363 /* POWER SERIES FOR CABS(W2).LE.0.25D0 */
5364 /* ----------------------------------------------------------------------- */
5365  k = 1;
5366  pr[0] = coner;
5367  pi[0] = conei;
5368  sumar = gama[0];
5369  sumai = zeroi;
5370  ap[0] = 1.;
5371  if (aw2 < *tol) {
5372  goto L20;
5373  }
5374  for (k = 2; k <= 30; ++k) {
5375  pr[k - 1] = pr[k - 2] * w2r - pi[k - 2] * w2i;
5376  pi[k - 1] = pr[k - 2] * w2i + pi[k - 2] * w2r;
5377  sumar += pr[k - 1] * gama[k - 1];
5378  sumai += pi[k - 1] * gama[k - 1];
5379  ap[k - 1] = ap[k - 2] * aw2;
5380  if (ap[k - 1] < *tol) {
5381  goto L20;
5382  }
5383 /* L10: */
5384  }
5385  k = 30;
5386 L20:
5387  kmax = k;
5388  zetar = w2r * sumar - w2i * sumai;
5389  zetai = w2r * sumai + w2i * sumar;
5390  *argr = zetar * fn23;
5391  *argi = zetai * fn23;
5392  zsqrt_(&sumar, &sumai, &zar, &zai);
5393  zsqrt_(&w2r, &w2i, &str, &sti);
5394  *zeta2r = str * *fnu;
5395  *zeta2i = sti * *fnu;
5396  str = coner + ex2 * (zetar * zar - zetai * zai);
5397  sti = conei + ex2 * (zetar * zai + zetai * zar);
5398  *zeta1r = str * *zeta2r - sti * *zeta2i;
5399  *zeta1i = str * *zeta2i + sti * *zeta2r;
5400  zar += zar;
5401  zai += zai;
5402  zsqrt_(&zar, &zai, &str, &sti);
5403  *phir = str * rfn13;
5404  *phii = sti * rfn13;
5405  if (*ipmtr == 1) {
5406  goto L120;
5407  }
5408 /* ----------------------------------------------------------------------- */
5409 /* SUM SERIES FOR ASUM AND BSUM */
5410 /* ----------------------------------------------------------------------- */
5411  sumbr = zeror;
5412  sumbi = zeroi;
5413  i__1 = kmax;
5414  for (k = 1; k <= i__1; ++k) {
5415  sumbr += pr[k - 1] * beta[k - 1];
5416  sumbi += pi[k - 1] * beta[k - 1];
5417 /* L30: */
5418  }
5419  *asumr = zeror;
5420  *asumi = zeroi;
5421  *bsumr = sumbr;
5422  *bsumi = sumbi;
5423  l1 = 0;
5424  l2 = 30;
5425  btol = *tol * (abs(*bsumr) + abs(*bsumi));
5426  atol = *tol;
5427  pp = 1.;
5428  ias = 0;
5429  ibs = 0;
5430  if (rfnu2 < *tol) {
5431  goto L110;
5432  }
5433  for (is = 2; is <= 7; ++is) {
5434  atol /= rfnu2;
5435  pp *= rfnu2;
5436  if (ias == 1) {
5437  goto L60;
5438  }
5439  sumar = zeror;
5440  sumai = zeroi;
5441  i__1 = kmax;
5442  for (k = 1; k <= i__1; ++k) {
5443  m = l1 + k;
5444  sumar += pr[k - 1] * alfa[m - 1];
5445  sumai += pi[k - 1] * alfa[m - 1];
5446  if (ap[k - 1] < atol) {
5447  goto L50;
5448  }
5449 /* L40: */
5450  }
5451 L50:
5452  *asumr += sumar * pp;
5453  *asumi += sumai * pp;
5454  if (pp < *tol) {
5455  ias = 1;
5456  }
5457 L60:
5458  if (ibs == 1) {
5459  goto L90;
5460  }
5461  sumbr = zeror;
5462  sumbi = zeroi;
5463  i__1 = kmax;
5464  for (k = 1; k <= i__1; ++k) {
5465  m = l2 + k;
5466  sumbr += pr[k - 1] * beta[m - 1];
5467  sumbi += pi[k - 1] * beta[m - 1];
5468  if (ap[k - 1] < atol) {
5469  goto L80;
5470  }
5471 /* L70: */
5472  }
5473 L80:
5474  *bsumr += sumbr * pp;
5475  *bsumi += sumbi * pp;
5476  if (pp < btol) {
5477  ibs = 1;
5478  }
5479 L90:
5480  if (ias == 1 && ibs == 1) {
5481  goto L110;
5482  }
5483  l1 += 30;
5484  l2 += 30;
5485 /* L100: */
5486  }
5487 L110:
5488  *asumr += coner;
5489  pp = rfnu * rfn13;
5490  *bsumr *= pp;
5491  *bsumi *= pp;
5492 L120:
5493  return 0;
5494 /* ----------------------------------------------------------------------- */
5495 /* CABS(W2).GT.0.25D0 */
5496 /* ----------------------------------------------------------------------- */
5497 L130:
5498  zsqrt_(&w2r, &w2i, &wr, &wi);
5499  if (wr < 0.) {
5500  wr = 0.;
5501  }
5502  if (wi < 0.) {
5503  wi = 0.;
5504  }
5505  str = coner + wr;
5506  sti = wi;
5507  zdiv_(&str, &sti, &zbr, &zbi, &zar, &zai);
5508  zlog_(&zar, &zai, &zcr, &zci, &idum);
5509  if (zci < 0.) {
5510  zci = 0.;
5511  }
5512  if (zci > hpi) {
5513  zci = hpi;
5514  }
5515  if (zcr < 0.) {
5516  zcr = 0.;
5517  }
5518  zthr = (zcr - wr) * 1.5;
5519  zthi = (zci - wi) * 1.5;
5520  *zeta1r = zcr * *fnu;
5521  *zeta1i = zci * *fnu;
5522  *zeta2r = wr * *fnu;
5523  *zeta2i = wi * *fnu;
5524  azth = myzabs_(&zthr, &zthi);
5525  ang = thpi;
5526  if (zthr >= 0. && zthi < 0.) {
5527  goto L140;
5528  }
5529  ang = hpi;
5530  if (zthr == 0.) {
5531  goto L140;
5532  }
5533  ang = atan(zthi / zthr);
5534  if (zthr < 0.) {
5535  ang += gpi;
5536  }
5537 L140:
5538  pp = pow_dd(&azth, &ex2);
5539  ang *= ex2;
5540  zetar = pp * cos(ang);
5541  zetai = pp * sin(ang);
5542  if (zetai < 0.) {
5543  zetai = 0.;
5544  }
5545  *argr = zetar * fn23;
5546  *argi = zetai * fn23;
5547  zdiv_(&zthr, &zthi, &zetar, &zetai, &rtztr, &rtzti);
5548  zdiv_(&rtztr, &rtzti, &wr, &wi, &zar, &zai);
5549  tzar = zar + zar;
5550  tzai = zai + zai;
5551  zsqrt_(&tzar, &tzai, &str, &sti);
5552  *phir = str * rfn13;
5553  *phii = sti * rfn13;
5554  if (*ipmtr == 1) {
5555  goto L120;
5556  }
5557  raw = 1. / sqrt(aw2);
5558  str = wr * raw;
5559  sti = -wi * raw;
5560  tfnr = str * rfnu * raw;
5561  tfni = sti * rfnu * raw;
5562  razth = 1. / azth;
5563  str = zthr * razth;
5564  sti = -zthi * razth;
5565  rzthr = str * razth * rfnu;
5566  rzthi = sti * razth * rfnu;
5567  zcr = rzthr * ar[1];
5568  zci = rzthi * ar[1];
5569  raw2 = 1. / aw2;
5570  str = w2r * raw2;
5571  sti = -w2i * raw2;
5572  t2r = str * raw2;
5573  t2i = sti * raw2;
5574  str = t2r * c__[1] + c__[2];
5575  sti = t2i * c__[1];
5576  upr[1] = str * tfnr - sti * tfni;
5577  upi[1] = str * tfni + sti * tfnr;
5578  *bsumr = upr[1] + zcr;
5579  *bsumi = upi[1] + zci;
5580  *asumr = zeror;
5581  *asumi = zeroi;
5582  if (rfnu < *tol) {
5583  goto L220;
5584  }
5585  przthr = rzthr;
5586  przthi = rzthi;
5587  ptfnr = tfnr;
5588  ptfni = tfni;
5589  upr[0] = coner;
5590  upi[0] = conei;
5591  pp = 1.;
5592  btol = *tol * (abs(*bsumr) + abs(*bsumi));
5593  ks = 0;
5594  kp1 = 2;
5595  l = 3;
5596  ias = 0;
5597  ibs = 0;
5598  for (lr = 2; lr <= 12; lr += 2) {
5599  lrp1 = lr + 1;
5600 /* ----------------------------------------------------------------------- */
5601 /* COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE TERMS IN */
5602 /* NEXT SUMA AND SUMB */
5603 /* ----------------------------------------------------------------------- */
5604  i__1 = lrp1;
5605  for (k = lr; k <= i__1; ++k) {
5606  ++ks;
5607  ++kp1;
5608  ++l;
5609  zar = c__[l - 1];
5610  zai = zeroi;
5611  i__2 = kp1;
5612  for (j = 2; j <= i__2; ++j) {
5613  ++l;
5614  str = zar * t2r - t2i * zai + c__[l - 1];
5615  zai = zar * t2i + zai * t2r;
5616  zar = str;
5617 /* L150: */
5618  }
5619  str = ptfnr * tfnr - ptfni * tfni;
5620  ptfni = ptfnr * tfni + ptfni * tfnr;
5621  ptfnr = str;
5622  upr[kp1 - 1] = ptfnr * zar - ptfni * zai;
5623  upi[kp1 - 1] = ptfni * zar + ptfnr * zai;
5624  crr[ks - 1] = przthr * br[ks];
5625  cri[ks - 1] = przthi * br[ks];
5626  str = przthr * rzthr - przthi * rzthi;
5627  przthi = przthr * rzthi + przthi * rzthr;
5628  przthr = str;
5629  drr[ks - 1] = przthr * ar[ks + 1];
5630  dri[ks - 1] = przthi * ar[ks + 1];
5631 /* L160: */
5632  }
5633  pp *= rfnu2;
5634  if (ias == 1) {
5635  goto L180;
5636  }
5637  sumar = upr[lrp1 - 1];
5638  sumai = upi[lrp1 - 1];
5639  ju = lrp1;
5640  i__1 = lr;
5641  for (jr = 1; jr <= i__1; ++jr) {
5642  --ju;
5643  sumar = sumar + crr[jr - 1] * upr[ju - 1] - cri[jr - 1] * upi[ju
5644  - 1];
5645  sumai = sumai + crr[jr - 1] * upi[ju - 1] + cri[jr - 1] * upr[ju
5646  - 1];
5647 /* L170: */
5648  }
5649  *asumr += sumar;
5650  *asumi += sumai;
5651  test = abs(sumar) + abs(sumai);
5652  if (pp < *tol && test < *tol) {
5653  ias = 1;
5654  }
5655 L180:
5656  if (ibs == 1) {
5657  goto L200;
5658  }
5659  sumbr = upr[lr + 1] + upr[lrp1 - 1] * zcr - upi[lrp1 - 1] * zci;
5660  sumbi = upi[lr + 1] + upr[lrp1 - 1] * zci + upi[lrp1 - 1] * zcr;
5661  ju = lrp1;
5662  i__1 = lr;
5663  for (jr = 1; jr <= i__1; ++jr) {
5664  --ju;
5665  sumbr = sumbr + drr[jr - 1] * upr[ju - 1] - dri[jr - 1] * upi[ju
5666  - 1];
5667  sumbi = sumbi + drr[jr - 1] * upi[ju - 1] + dri[jr - 1] * upr[ju
5668  - 1];
5669 /* L190: */
5670  }
5671  *bsumr += sumbr;
5672  *bsumi += sumbi;
5673  test = abs(sumbr) + abs(sumbi);
5674  if (pp < btol && test < btol) {
5675  ibs = 1;
5676  }
5677 L200:
5678  if (ias == 1 && ibs == 1) {
5679  goto L220;
5680  }
5681 /* L210: */
5682  }
5683 L220:
5684  *asumr += coner;
5685  str = -(*bsumr) * rfn13;
5686  sti = -(*bsumi) * rfn13;
5687  zdiv_(&str, &sti, &rtztr, &rtzti, bsumr, bsumi);
5688  goto L120;
5689 } /* zunhj_ */
5690 
5691 /* Subroutine */ int zuni1_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *nz, integer *nlast, doublereal *fnul, doublereal *tol, doublereal *elim, doublereal *alim)
5692 {
5693  /* Initialized data */
5694 
5695  static doublereal zeror = 0.;
5696  static doublereal zeroi = 0.;
5697  static doublereal coner = 1.;
5698 
5699  /* System generated locals */
5700  integer i__1;
5701 
5702  /* Builtin functions */
5703 
5704  /* Local variables */
5705  static doublereal aphi, cscl, phii, crsc, phir;
5706  static integer init;
5707  static doublereal csrr[3], cssr[3], rast, sumi, sumr;
5708  static integer i__, k, m, iflag;
5709  static doublereal ascle, cwrki[16];
5710  static doublereal cwrkr[16];
5711  static doublereal zeta1i, zeta2i, zeta1r, zeta2r;
5712  static integer nd;
5713  static doublereal fn;
5714  static integer nn, nw;
5715  static doublereal c2i, c2m;
5716  static doublereal c1r, c2r, s1i, s2i, rs1, s1r, s2r, cyi[2];
5717  static integer nuf;
5718  static doublereal bry[3], cyr[2], sti, rzi, str, rzr;
5719 
5720 /* ***BEGIN PROLOGUE ZUNI1 */
5721 /* ***REFER TO ZBESI,ZBESK */
5722 
5723 /* ZUNI1 COMPUTES I(FNU,Z) BY MEANS OF THE UNIFORM ASYMPTOTIC */
5724 /* EXPANSION FOR I(FNU,Z) IN -PI/3.LE.ARG Z.LE.PI/3. */
5725 
5726 /* FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC */
5727 /* EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. */
5728 /* NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER */
5729 /* FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. */
5730 /* Y(I)=CZERO FOR I=NLAST+1,N */
5731 
5732 /* ***ROUTINES CALLED ZUCHK,ZUNIK,ZUOIK,D1MACH,myzabs */
5733 /* ***END PROLOGUE ZUNI1 */
5734 /* COMPLEX CFN,CONE,CRSC,CSCL,CSR,CSS,CWRK,CZERO,C1,C2,PHI,RZ,SUM,S1, */
5735 /* *S2,Y,Z,ZETA1,ZETA2 */
5736  /* Parameter adjustments */
5737  --yi;
5738  --yr;
5739 
5740  /* Function Body */
5741 
5742  *nz = 0;
5743  nd = *n;
5744  *nlast = 0;
5745 /* ----------------------------------------------------------------------- */
5746 /* COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- */
5747 /* NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, */
5748 /* EXP(ALIM)=EXP(ELIM)*TOL */
5749 /* ----------------------------------------------------------------------- */
5750  cscl = 1. / *tol;
5751  crsc = *tol;
5752  cssr[0] = cscl;
5753  cssr[1] = coner;
5754  cssr[2] = crsc;
5755  csrr[0] = crsc;
5756  csrr[1] = coner;
5757  csrr[2] = cscl;
5758  bry[0] = d1mach_(&c__1) * 1e3 / *tol;
5759 /* ----------------------------------------------------------------------- */
5760 /* CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER */
5761 /* ----------------------------------------------------------------------- */
5762  fn = max(*fnu,1.);
5763  init = 0;
5764  zunik_(zr, zi, &fn, &c__1, &c__1, tol, &init, &phir, &phii, &zeta1r, &
5765  zeta1i, &zeta2r, &zeta2i, &sumr, &sumi, cwrkr, cwrki);
5766  if (*kode == 1) {
5767  goto L10;
5768  }
5769  str = *zr + zeta2r;
5770  sti = *zi + zeta2i;
5771  rast = fn / myzabs_(&str, &sti);
5772  str = str * rast * rast;
5773  sti = -sti * rast * rast;
5774  s1r = -zeta1r + str;
5775  s1i = -zeta1i + sti;
5776  goto L20;
5777 L10:
5778  s1r = -zeta1r + zeta2r;
5779  s1i = -zeta1i + zeta2i;
5780 L20:
5781  rs1 = s1r;
5782  if (abs(rs1) > *elim) {
5783  goto L130;
5784  }
5785 L30:
5786  nn = min(2,nd);
5787  i__1 = nn;
5788  for (i__ = 1; i__ <= i__1; ++i__) {
5789  fn = *fnu + (doublereal) ((real) (nd - i__));
5790  init = 0;
5791  zunik_(zr, zi, &fn, &c__1, &c__0, tol, &init, &phir, &phii, &zeta1r, &
5792  zeta1i, &zeta2r, &zeta2i, &sumr, &sumi, cwrkr, cwrki);
5793  if (*kode == 1) {
5794  goto L40;
5795  }
5796  str = *zr + zeta2r;
5797  sti = *zi + zeta2i;
5798  rast = fn / myzabs_(&str, &sti);
5799  str = str * rast * rast;
5800  sti = -sti * rast * rast;
5801  s1r = -zeta1r + str;
5802  s1i = -zeta1i + sti + *zi;
5803  goto L50;
5804 L40:
5805  s1r = -zeta1r + zeta2r;
5806  s1i = -zeta1i + zeta2i;
5807 L50:
5808 /* ----------------------------------------------------------------------- */
5809 /* TEST FOR UNDERFLOW AND OVERFLOW */
5810 /* ----------------------------------------------------------------------- */
5811  rs1 = s1r;
5812  if (abs(rs1) > *elim) {
5813  goto L110;
5814  }
5815  if (i__ == 1) {
5816  iflag = 2;
5817  }
5818  if (abs(rs1) < *alim) {
5819  goto L60;
5820  }
5821 /* ----------------------------------------------------------------------- */
5822 /* REFINE TEST AND SCALE */
5823 /* ----------------------------------------------------------------------- */
5824  aphi = myzabs_(&phir, &phii);
5825  rs1 += log(aphi);
5826  if (abs(rs1) > *elim) {
5827  goto L110;
5828  }
5829  if (i__ == 1) {
5830  iflag = 1;
5831  }
5832  if (rs1 < 0.) {
5833  goto L60;
5834  }
5835  if (i__ == 1) {
5836  iflag = 3;
5837  }
5838 L60:
5839 /* ----------------------------------------------------------------------- */
5840 /* SCALE S1 IF CABS(S1).LT.ASCLE */
5841 /* ----------------------------------------------------------------------- */
5842  s2r = phir * sumr - phii * sumi;
5843  s2i = phir * sumi + phii * sumr;
5844  str = exp(s1r) * cssr[iflag - 1];
5845  s1r = str * cos(s1i);
5846  s1i = str * sin(s1i);
5847  str = s2r * s1r - s2i * s1i;
5848  s2i = s2r * s1i + s2i * s1r;
5849  s2r = str;
5850  if (iflag != 1) {
5851  goto L70;
5852  }
5853  zuchk_(&s2r, &s2i, &nw, bry, tol);
5854  if (nw != 0) {
5855  goto L110;
5856  }
5857 L70:
5858  cyr[i__ - 1] = s2r;
5859  cyi[i__ - 1] = s2i;
5860  m = nd - i__ + 1;
5861  yr[m] = s2r * csrr[iflag - 1];
5862  yi[m] = s2i * csrr[iflag - 1];
5863 /* L80: */
5864  }
5865  if (nd <= 2) {
5866  goto L100;
5867  }
5868  rast = 1. / myzabs_(zr, zi);
5869  str = *zr * rast;
5870  sti = -(*zi) * rast;
5871  rzr = (str + str) * rast;
5872  rzi = (sti + sti) * rast;
5873  bry[1] = 1. / bry[0];
5874  bry[2] = d1mach_(&c__2);
5875  s1r = cyr[0];
5876  s1i = cyi[0];
5877  s2r = cyr[1];
5878  s2i = cyi[1];
5879  c1r = csrr[iflag - 1];
5880  ascle = bry[iflag - 1];
5881  k = nd - 2;
5882  fn = (doublereal) ((real) k);
5883  i__1 = nd;
5884  for (i__ = 3; i__ <= i__1; ++i__) {
5885  c2r = s2r;
5886  c2i = s2i;
5887  s2r = s1r + (*fnu + fn) * (rzr * c2r - rzi * c2i);
5888  s2i = s1i + (*fnu + fn) * (rzr * c2i + rzi * c2r);
5889  s1r = c2r;
5890  s1i = c2i;
5891  c2r = s2r * c1r;
5892  c2i = s2i * c1r;
5893  yr[k] = c2r;
5894  yi[k] = c2i;
5895  --k;
5896  fn += -1.;
5897  if (iflag >= 3) {
5898  goto L90;
5899  }
5900  str = abs(c2r);
5901  sti = abs(c2i);
5902  c2m = max(str,sti);
5903  if (c2m <= ascle) {
5904  goto L90;
5905  }
5906  ++iflag;
5907  ascle = bry[iflag - 1];
5908  s1r *= c1r;
5909  s1i *= c1r;
5910  s2r = c2r;
5911  s2i = c2i;
5912  s1r *= cssr[iflag - 1];
5913  s1i *= cssr[iflag - 1];
5914  s2r *= cssr[iflag - 1];
5915  s2i *= cssr[iflag - 1];
5916  c1r = csrr[iflag - 1];
5917 L90:
5918  ;
5919  }
5920 L100:
5921  return 0;
5922 /* ----------------------------------------------------------------------- */
5923 /* SET UNDERFLOW AND UPDATE PARAMETERS */
5924 /* ----------------------------------------------------------------------- */
5925 L110:
5926  if (rs1 > 0.) {
5927  goto L120;
5928  }
5929  yr[nd] = zeror;
5930  yi[nd] = zeroi;
5931  ++(*nz);
5932  --nd;
5933  if (nd == 0) {
5934  goto L100;
5935  }
5936  zuoik_(zr, zi, fnu, kode, &c__1, &nd, &yr[1], &yi[1], &nuf, tol, elim,
5937  alim);
5938  if (nuf < 0) {
5939  goto L120;
5940  }
5941  nd -= nuf;
5942  *nz += nuf;
5943  if (nd == 0) {
5944  goto L100;
5945  }
5946  fn = *fnu + (doublereal) ((real) (nd - 1));
5947  if (fn >= *fnul) {
5948  goto L30;
5949  }
5950  *nlast = nd;
5951  return 0;
5952 L120:
5953  *nz = -1;
5954  return 0;
5955 L130:
5956  if (rs1 > 0.) {
5957  goto L120;
5958  }
5959  *nz = *n;
5960  i__1 = *n;
5961  for (i__ = 1; i__ <= i__1; ++i__) {
5962  yr[i__] = zeror;
5963  yi[i__] = zeroi;
5964 /* L140: */
5965  }
5966  return 0;
5967 } /* zuni1_ */
5968 
5969 /* Subroutine */ int zuni2_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *nz, integer *nlast, doublereal *fnul, doublereal *tol, doublereal *elim, doublereal *alim)
5970 {
5971  /* Initialized data */
5972 
5973  static doublereal zeror = 0.;
5974  static doublereal zeroi = 0.;
5975  static doublereal coner = 1.;
5976  static doublereal cipr[4] = { 1.,0.,-1.,0. };
5977  static doublereal cipi[4] = { 0.,1.,0.,-1. };
5978  static doublereal hpi = 1.57079632679489662;
5979  static doublereal aic = 1.265512123484645396;
5980 
5981  /* System generated locals */
5982  integer i__1;
5983 
5984  /* Builtin functions */
5985 
5986  /* Local variables */
5987  static doublereal daii, cidi, aarg;
5988  static integer ndai;
5989  static doublereal dair, aphi, argi, cscl, phii, crsc, argr;
5990  static integer idum;
5991  static doublereal phir, csrr[3], cssr[3], rast;
5992  static integer i__, j, k, iflag;
5993  static doublereal ascle, asumi, bsumi;
5994  static doublereal asumr, bsumr;
5995  static doublereal zeta1i, zeta2i, zeta1r, zeta2r;
5996  static integer nd;
5997  static doublereal fn;
5998  static integer in, nn, nw;
5999  static doublereal c2i, c2m;
6000  static doublereal c1r, c2r, s1i, s2i, rs1, s1r, s2r, aii, ang, car;
6001  static integer nai;
6002  static doublereal air, zbi, cyi[2], sar;
6003  static integer nuf, inu;
6004  static doublereal bry[3], raz, sti, zbr, zni, cyr[2], rzi, str, znr, rzr;
6005 
6006 /* ***BEGIN PROLOGUE ZUNI2 */
6007 /* ***REFER TO ZBESI,ZBESK */
6008 
6009 /* ZUNI2 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF */
6010 /* UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I */
6011 /* OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO. */
6012 
6013 /* FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC */
6014 /* EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. */
6015 /* NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER */
6016 /* FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. */
6017 /* Y(I)=CZERO FOR I=NLAST+1,N */
6018 
6019 /* ***ROUTINES CALLED ZAIRY,ZUCHK,ZUNHJ,ZUOIK,D1MACH,myzabs */
6020 /* ***END PROLOGUE ZUNI2 */
6021 /* COMPLEX AI,ARG,ASUM,BSUM,CFN,CI,CID,CIP,CONE,CRSC,CSCL,CSR,CSS, */
6022 /* *CZERO,C1,C2,DAI,PHI,RZ,S1,S2,Y,Z,ZB,ZETA1,ZETA2,ZN */
6023  /* Parameter adjustments */
6024  --yi;
6025  --yr;
6026 
6027  /* Function Body */
6028 
6029  *nz = 0;
6030  nd = *n;
6031  *nlast = 0;
6032 /* ----------------------------------------------------------------------- */
6033 /* COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- */
6034 /* NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, */
6035 /* EXP(ALIM)=EXP(ELIM)*TOL */
6036 /* ----------------------------------------------------------------------- */
6037  cscl = 1. / *tol;
6038  crsc = *tol;
6039  cssr[0] = cscl;
6040  cssr[1] = coner;
6041  cssr[2] = crsc;
6042  csrr[0] = crsc;
6043  csrr[1] = coner;
6044  csrr[2] = cscl;
6045  bry[0] = d1mach_(&c__1) * 1e3 / *tol;
6046 /* ----------------------------------------------------------------------- */
6047 /* ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI */
6048 /* ----------------------------------------------------------------------- */
6049  znr = *zi;
6050  zni = -(*zr);
6051  zbr = *zr;
6052  zbi = *zi;
6053  cidi = -coner;
6054  inu = (integer) ((real) (*fnu));
6055  ang = hpi * (*fnu - (doublereal) ((real) inu));
6056  c2r = cos(ang);
6057  c2i = sin(ang);
6058  car = c2r;
6059  sar = c2i;
6060  in = inu + *n - 1;
6061  in = in % 4 + 1;
6062  str = c2r * cipr[in - 1] - c2i * cipi[in - 1];
6063  c2i = c2r * cipi[in - 1] + c2i * cipr[in - 1];
6064  c2r = str;
6065  if (*zi > 0.) {
6066  goto L10;
6067  }
6068  znr = -znr;
6069  zbi = -zbi;
6070  cidi = -cidi;
6071  c2i = -c2i;
6072 L10:
6073 /* ----------------------------------------------------------------------- */
6074 /* CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER */
6075 /* ----------------------------------------------------------------------- */
6076  fn = max(*fnu,1.);
6077  zunhj_(&znr, &zni, &fn, &c__1, tol, &phir, &phii, &argr, &argi, &zeta1r, &
6078  zeta1i, &zeta2r, &zeta2i, &asumr, &asumi, &bsumr, &bsumi);
6079  if (*kode == 1) {
6080  goto L20;
6081  }
6082  str = zbr + zeta2r;
6083  sti = zbi + zeta2i;
6084  rast = fn / myzabs_(&str, &sti);
6085  str = str * rast * rast;
6086  sti = -sti * rast * rast;
6087  s1r = -zeta1r + str;
6088  s1i = -zeta1i + sti;
6089  goto L30;
6090 L20:
6091  s1r = -zeta1r + zeta2r;
6092  s1i = -zeta1i + zeta2i;
6093 L30:
6094  rs1 = s1r;
6095  if (abs(rs1) > *elim) {
6096  goto L150;
6097  }
6098 L40:
6099  nn = min(2,nd);
6100  i__1 = nn;
6101  for (i__ = 1; i__ <= i__1; ++i__) {
6102  fn = *fnu + (doublereal) ((real) (nd - i__));
6103  zunhj_(&znr, &zni, &fn, &c__0, tol, &phir, &phii, &argr, &argi, &
6104  zeta1r, &zeta1i, &zeta2r, &zeta2i, &asumr, &asumi, &bsumr, &
6105  bsumi);
6106  if (*kode == 1) {
6107  goto L50;
6108  }
6109  str = zbr + zeta2r;
6110  sti = zbi + zeta2i;
6111  rast = fn / myzabs_(&str, &sti);
6112  str = str * rast * rast;
6113  sti = -sti * rast * rast;
6114  s1r = -zeta1r + str;
6115  s1i = -zeta1i + sti + abs(*zi);
6116  goto L60;
6117 L50:
6118  s1r = -zeta1r + zeta2r;
6119  s1i = -zeta1i + zeta2i;
6120 L60:
6121 /* ----------------------------------------------------------------------- */
6122 /* TEST FOR UNDERFLOW AND OVERFLOW */
6123 /* ----------------------------------------------------------------------- */
6124  rs1 = s1r;
6125  if (abs(rs1) > *elim) {
6126  goto L120;
6127  }
6128  if (i__ == 1) {
6129  iflag = 2;
6130  }
6131  if (abs(rs1) < *alim) {
6132  goto L70;
6133  }
6134 /* ----------------------------------------------------------------------- */
6135 /* REFINE TEST AND SCALE */
6136 /* ----------------------------------------------------------------------- */
6137 /* ----------------------------------------------------------------------- */
6138  aphi = myzabs_(&phir, &phii);
6139  aarg = myzabs_(&argr, &argi);
6140  rs1 = rs1 + log(aphi) - log(aarg) * .25 - aic;
6141  if (abs(rs1) > *elim) {
6142  goto L120;
6143  }
6144  if (i__ == 1) {
6145  iflag = 1;
6146  }
6147  if (rs1 < 0.) {
6148  goto L70;
6149  }
6150  if (i__ == 1) {
6151  iflag = 3;
6152  }
6153 L70:
6154 /* ----------------------------------------------------------------------- */
6155 /* SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR */
6156 /* EXPONENT EXTREMES */
6157 /* ----------------------------------------------------------------------- */
6158  zairy_(&argr, &argi, &c__0, &c__2, &air, &aii, &nai, &idum);
6159  zairy_(&argr, &argi, &c__1, &c__2, &dair, &daii, &ndai, &idum);
6160  str = dair * bsumr - daii * bsumi;
6161  sti = dair * bsumi + daii * bsumr;
6162  str += air * asumr - aii * asumi;
6163  sti += air * asumi + aii * asumr;
6164  s2r = phir * str - phii * sti;
6165  s2i = phir * sti + phii * str;
6166  str = exp(s1r) * cssr[iflag - 1];
6167  s1r = str * cos(s1i);
6168  s1i = str * sin(s1i);
6169  str = s2r * s1r - s2i * s1i;
6170  s2i = s2r * s1i + s2i * s1r;
6171  s2r = str;
6172  if (iflag != 1) {
6173  goto L80;
6174  }
6175  zuchk_(&s2r, &s2i, &nw, bry, tol);
6176  if (nw != 0) {
6177  goto L120;
6178  }
6179 L80:
6180  if (*zi <= 0.) {
6181  s2i = -s2i;
6182  }
6183  str = s2r * c2r - s2i * c2i;
6184  s2i = s2r * c2i + s2i * c2r;
6185  s2r = str;
6186  cyr[i__ - 1] = s2r;
6187  cyi[i__ - 1] = s2i;
6188  j = nd - i__ + 1;
6189  yr[j] = s2r * csrr[iflag - 1];
6190  yi[j] = s2i * csrr[iflag - 1];
6191  str = -c2i * cidi;
6192  c2i = c2r * cidi;
6193  c2r = str;
6194 /* L90: */
6195  }
6196  if (nd <= 2) {
6197  goto L110;
6198  }
6199  raz = 1. / myzabs_(zr, zi);
6200  str = *zr * raz;
6201  sti = -(*zi) * raz;
6202  rzr = (str + str) * raz;
6203  rzi = (sti + sti) * raz;
6204  bry[1] = 1. / bry[0];
6205  bry[2] = d1mach_(&c__2);
6206  s1r = cyr[0];
6207  s1i = cyi[0];
6208  s2r = cyr[1];
6209  s2i = cyi[1];
6210  c1r = csrr[iflag - 1];
6211  ascle = bry[iflag - 1];
6212  k = nd - 2;
6213  fn = (doublereal) ((real) k);
6214  i__1 = nd;
6215  for (i__ = 3; i__ <= i__1; ++i__) {
6216  c2r = s2r;
6217  c2i = s2i;
6218  s2r = s1r + (*fnu + fn) * (rzr * c2r - rzi * c2i);
6219  s2i = s1i + (*fnu + fn) * (rzr * c2i + rzi * c2r);
6220  s1r = c2r;
6221  s1i = c2i;
6222  c2r = s2r * c1r;
6223  c2i = s2i * c1r;
6224  yr[k] = c2r;
6225  yi[k] = c2i;
6226  --k;
6227  fn += -1.;
6228  if (iflag >= 3) {
6229  goto L100;
6230  }
6231  str = abs(c2r);
6232  sti = abs(c2i);
6233  c2m = max(str,sti);
6234  if (c2m <= ascle) {
6235  goto L100;
6236  }
6237  ++iflag;
6238  ascle = bry[iflag - 1];
6239  s1r *= c1r;
6240  s1i *= c1r;
6241  s2r = c2r;
6242  s2i = c2i;
6243  s1r *= cssr[iflag - 1];
6244  s1i *= cssr[iflag - 1];
6245  s2r *= cssr[iflag - 1];
6246  s2i *= cssr[iflag - 1];
6247  c1r = csrr[iflag - 1];
6248 L100:
6249  ;
6250  }
6251 L110:
6252  return 0;
6253 L120:
6254  if (rs1 > 0.) {
6255  goto L140;
6256  }
6257 /* ----------------------------------------------------------------------- */
6258 /* SET UNDERFLOW AND UPDATE PARAMETERS */
6259 /* ----------------------------------------------------------------------- */
6260  yr[nd] = zeror;
6261  yi[nd] = zeroi;
6262  ++(*nz);
6263  --nd;
6264  if (nd == 0) {
6265  goto L110;
6266  }
6267  zuoik_(zr, zi, fnu, kode, &c__1, &nd, &yr[1], &yi[1], &nuf, tol, elim,
6268  alim);
6269  if (nuf < 0) {
6270  goto L140;
6271  }
6272  nd -= nuf;
6273  *nz += nuf;
6274  if (nd == 0) {
6275  goto L110;
6276  }
6277  fn = *fnu + (doublereal) ((real) (nd - 1));
6278  if (fn < *fnul) {
6279  goto L130;
6280  }
6281 /* FN = CIDI */
6282 /* J = NUF + 1 */
6283 /* K = MOD(J,4) + 1 */
6284 /* S1R = CIPR(K) */
6285 /* S1I = CIPI(K) */
6286 /* IF (FN.LT.0.0D0) S1I = -S1I */
6287 /* STR = C2R*S1R - C2I*S1I */
6288 /* C2I = C2R*S1I + C2I*S1R */
6289 /* C2R = STR */
6290  in = inu + nd - 1;
6291  in = in % 4 + 1;
6292  c2r = car * cipr[in - 1] - sar * cipi[in - 1];
6293  c2i = car * cipi[in - 1] + sar * cipr[in - 1];
6294  if (*zi <= 0.) {
6295  c2i = -c2i;
6296  }
6297  goto L40;
6298 L130:
6299  *nlast = nd;
6300  return 0;
6301 L140:
6302  *nz = -1;
6303  return 0;
6304 L150:
6305  if (rs1 > 0.) {
6306  goto L140;
6307  }
6308  *nz = *n;
6309  i__1 = *n;
6310  for (i__ = 1; i__ <= i__1; ++i__) {
6311  yr[i__] = zeror;
6312  yi[i__] = zeroi;
6313 /* L160: */
6314  }
6315  return 0;
6316 } /* zuni2_ */
6317 
6318 /* Subroutine */ int zunik_(doublereal *zrr, doublereal *zri, doublereal *fnu, integer *ikflg, integer *ipmtr, doublereal *tol, integer *init, doublereal *phir, doublereal *phii, doublereal *zeta1r, doublereal *zeta1i, doublereal *zeta2r, doublereal *zeta2i, doublereal *sumr, doublereal *sumi, doublereal *cwrkr, doublereal *cwrki)
6319 {
6320  /* Initialized data */
6321 
6322  static doublereal zeror = 0.;
6323  static doublereal zeroi = 0.;
6324  static doublereal coner = 1.;
6325  static doublereal conei = 0.;
6326  static doublereal con[2] = { .398942280401432678,1.25331413731550025 };
6327  static doublereal c__[120] = { 1.,-.208333333333333333,.125,
6328  .334201388888888889,-.401041666666666667,.0703125,
6329  -1.02581259645061728,1.84646267361111111,-.8912109375,.0732421875,
6330  4.66958442342624743,-11.2070026162229938,8.78912353515625,
6331  -2.3640869140625,.112152099609375,-28.2120725582002449,
6332  84.6362176746007346,-91.8182415432400174,42.5349987453884549,
6333  -7.3687943594796317,.227108001708984375,212.570130039217123,
6334  -765.252468141181642,1059.99045252799988,-699.579627376132541,
6335  218.19051174421159,-26.4914304869515555,.572501420974731445,
6336  -1919.457662318407,8061.72218173730938,-13586.5500064341374,
6337  11655.3933368645332,-5305.64697861340311,1200.90291321635246,
6338  -108.090919788394656,1.7277275025844574,20204.2913309661486,
6339  -96980.5983886375135,192547.001232531532,-203400.177280415534,
6340  122200.46498301746,-41192.6549688975513,7109.51430248936372,
6341  -493.915304773088012,6.07404200127348304,-242919.187900551333,
6342  1311763.6146629772,-2998015.91853810675,3763271.297656404,
6343  -2813563.22658653411,1268365.27332162478,-331645.172484563578,
6344  45218.7689813627263,-2499.83048181120962,24.3805296995560639,
6345  3284469.85307203782,-19706819.1184322269,50952602.4926646422,
6346  -74105148.2115326577,66344512.2747290267,-37567176.6607633513,
6347  13288767.1664218183,-2785618.12808645469,308186.404612662398,
6348  -13886.0897537170405,110.017140269246738,-49329253.664509962,
6349  325573074.185765749,-939462359.681578403,1553596899.57058006,
6350  -1621080552.10833708,1106842816.82301447,-495889784.275030309,
6351  142062907.797533095,-24474062.7257387285,2243768.17792244943,
6352  -84005.4336030240853,551.335896122020586,814789096.118312115,
6353  -5866481492.05184723,18688207509.2958249,-34632043388.1587779,
6354  41280185579.753974,-33026599749.8007231,17954213731.1556001,
6355  -6563293792.61928433,1559279864.87925751,-225105661.889415278,
6356  17395107.5539781645,-549842.327572288687,3038.09051092238427,
6357  -14679261247.6956167,114498237732.02581,-399096175224.466498,
6358  819218669548.577329,-1098375156081.22331,1008158106865.38209,
6359  -645364869245.376503,287900649906.150589,-87867072178.0232657,
6360  17634730606.8349694,-2167164983.22379509,143157876.718888981,
6361  -3871833.44257261262,18257.7554742931747,286464035717.679043,
6362  -2406297900028.50396,9109341185239.89896,-20516899410934.4374,
6363  30565125519935.3206,-31667088584785.1584,23348364044581.8409,
6364  -12320491305598.2872,4612725780849.13197,-1196552880196.1816,
6365  205914503232.410016,-21822927757.5292237,1247009293.51271032,
6366  -29188388.1222208134,118838.426256783253 };
6367 
6368  /* System generated locals */
6369  integer i__1;
6370  doublereal d__1, d__2;
6371 
6372  /* Builtin functions */
6373 
6374  /* Local variables */
6375  static integer idum;
6376  static doublereal test;
6377  static integer i__, j, k, l;
6378  static doublereal crfni, crfnr;
6379  static doublereal ac, si, ti, sr, tr, t2i, t2r, rfn, sri, sti, zni, srr,
6380  str, znr;
6381 
6382 /* ***BEGIN PROLOGUE ZUNIK */
6383 /* ***REFER TO ZBESI,ZBESK */
6384 
6385 /* ZUNIK COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC */
6386 /* EXPANSIONS OF THE I AND K FUNCTIONS ON IKFLG= 1 OR 2 */
6387 /* RESPECTIVELY BY */
6388 
6389 /* W(FNU,ZR) = PHI*EXP(ZETA)*SUM */
6390 
6391 /* WHERE ZETA=-ZETA1 + ZETA2 OR */
6392 /* ZETA1 - ZETA2 */
6393 
6394 /* THE FIRST CALL MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE */
6395 /* SAME ZR AND FNU WILL RETURN THE I OR K FUNCTION ON IKFLG= */
6396 /* 1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK */
6397 /* ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI, */
6398 /* ZETA1,ZETA2. */
6399 
6400 /* ***ROUTINES CALLED ZDIV,ZLOG,ZSQRT,D1MACH */
6401 /* ***END PROLOGUE ZUNIK */
6402 /* COMPLEX CFN,CON,CONE,CRFN,CWRK,CZERO,PHI,S,SR,SUM,T,T2,ZETA1, */
6403 /* *ZETA2,ZN,ZR */
6404  /* Parameter adjustments */
6405  --cwrki;
6406  --cwrkr;
6407 
6408  /* Function Body */
6409 
6410  if (*init != 0) {
6411  goto L40;
6412  }
6413 /* ----------------------------------------------------------------------- */
6414 /* INITIALIZE ALL VARIABLES */
6415 /* ----------------------------------------------------------------------- */
6416  rfn = 1. / *fnu;
6417 /* ----------------------------------------------------------------------- */
6418 /* OVERFLOW TEST (ZR/FNU TOO SMALL) */
6419 /* ----------------------------------------------------------------------- */
6420  test = d1mach_(&c__1) * 1e3;
6421  ac = *fnu * test;
6422  if (abs(*zrr) > ac || abs(*zri) > ac) {
6423  goto L15;
6424  }
6425  *zeta1r = (d__1 = log(test), abs(d__1)) * 2. + *fnu;
6426  *zeta1i = 0.;
6427  *zeta2r = *fnu;
6428  *zeta2i = 0.;
6429  *phir = 1.;
6430  *phii = 0.;
6431  return 0;
6432 L15:
6433  tr = *zrr * rfn;
6434  ti = *zri * rfn;
6435  sr = coner + (tr * tr - ti * ti);
6436  si = conei + (tr * ti + ti * tr);
6437  zsqrt_(&sr, &si, &srr, &sri);
6438  str = coner + srr;
6439  sti = conei + sri;
6440  zdiv_(&str, &sti, &tr, &ti, &znr, &zni);
6441  zlog_(&znr, &zni, &str, &sti, &idum);
6442  *zeta1r = *fnu * str;
6443  *zeta1i = *fnu * sti;
6444  *zeta2r = *fnu * srr;
6445  *zeta2i = *fnu * sri;
6446  zdiv_(&coner, &conei, &srr, &sri, &tr, &ti);
6447  srr = tr * rfn;
6448  sri = ti * rfn;
6449  zsqrt_(&srr, &sri, &cwrkr[16], &cwrki[16]);
6450  *phir = cwrkr[16] * con[*ikflg - 1];
6451  *phii = cwrki[16] * con[*ikflg - 1];
6452  if (*ipmtr != 0) {
6453  return 0;
6454  }
6455  zdiv_(&coner, &conei, &sr, &si, &t2r, &t2i);
6456  cwrkr[1] = coner;
6457  cwrki[1] = conei;
6458  crfnr = coner;
6459  crfni = conei;
6460  ac = 1.;
6461  l = 1;
6462  for (k = 2; k <= 15; ++k) {
6463  sr = zeror;
6464  si = zeroi;
6465  i__1 = k;
6466  for (j = 1; j <= i__1; ++j) {
6467  ++l;
6468  str = sr * t2r - si * t2i + c__[l - 1];
6469  si = sr * t2i + si * t2r;
6470  sr = str;
6471 /* L10: */
6472  }
6473  str = crfnr * srr - crfni * sri;
6474  crfni = crfnr * sri + crfni * srr;
6475  crfnr = str;
6476  cwrkr[k] = crfnr * sr - crfni * si;
6477  cwrki[k] = crfnr * si + crfni * sr;
6478  ac *= rfn;
6479  test = (d__1 = cwrkr[k], abs(d__1)) + (d__2 = cwrki[k], abs(d__2));
6480  if (ac < *tol && test < *tol) {
6481  goto L30;
6482  }
6483 /* L20: */
6484  }
6485  k = 15;
6486 L30:
6487  *init = k;
6488 L40:
6489  if (*ikflg == 2) {
6490  goto L60;
6491  }
6492 /* ----------------------------------------------------------------------- */
6493 /* COMPUTE SUM FOR THE I FUNCTION */
6494 /* ----------------------------------------------------------------------- */
6495  sr = zeror;
6496  si = zeroi;
6497  i__1 = *init;
6498  for (i__ = 1; i__ <= i__1; ++i__) {
6499  sr += cwrkr[i__];
6500  si += cwrki[i__];
6501 /* L50: */
6502  }
6503  *sumr = sr;
6504  *sumi = si;
6505  *phir = cwrkr[16] * con[0];
6506  *phii = cwrki[16] * con[0];
6507  return 0;
6508 L60:
6509 /* ----------------------------------------------------------------------- */
6510 /* COMPUTE SUM FOR THE K FUNCTION */
6511 /* ----------------------------------------------------------------------- */
6512  sr = zeror;
6513  si = zeroi;
6514  tr = coner;
6515  i__1 = *init;
6516  for (i__ = 1; i__ <= i__1; ++i__) {
6517  sr += tr * cwrkr[i__];
6518  si += tr * cwrki[i__];
6519  tr = -tr;
6520 /* L70: */
6521  }
6522  *sumr = sr;
6523  *sumi = si;
6524  *phir = cwrkr[16] * con[1];
6525  *phii = cwrki[16] * con[1];
6526  return 0;
6527 } /* zunik_ */
6528 
6529 /* Subroutine */ int zunk1_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *tol, doublereal *elim, doublereal *alim)
6530 {
6531  /* Initialized data */
6532 
6533  static doublereal zeror = 0.;
6534  static doublereal zeroi = 0.;
6535  static doublereal coner = 1.;
6536  static doublereal pi = 3.14159265358979324;
6537 
6538  /* System generated locals */
6539  integer i__1;
6540 
6541  /* Builtin functions */
6542 
6543  /* Local variables */
6544  static doublereal aphi, cscl, phii[2], crsc, phir[2];
6545  static integer init[2];
6546  static doublereal csrr[3], cssr[3], rast, sumi[2], razr;
6547  static doublereal sumr[2];
6548  static integer i__, j, k, m, iflag, kflag;
6549  static doublereal ascle;
6550  static integer kdflg;
6551  static doublereal phidi;
6552  static integer ipard;
6553  static doublereal csgni, phidr;
6554  static integer initd;
6555  static doublereal cspni, cwrki[48] /* was [16][3] */, sumdi;
6556  static doublereal cspnr, cwrkr[48] /* was [16][3] */, sumdr;
6557  static doublereal zeta1i[2], zeta2i[2], zet1di, zet2di, zeta1r[2], zeta2r[
6558  2], zet1dr, zet2dr;
6559  static integer ib, ic;
6560  static doublereal fn;
6561  static integer il, kk, nw;
6562  static doublereal c1i, c2i, c2m;
6563  static doublereal c1r, c2r, s1i, s2i, rs1, s1r, s2r, ang, asc, cki, fnf;
6564  static integer ifn;
6565  static doublereal ckr;
6566  static integer iuf;
6567  static doublereal cyi[2], fmr, csr, sgn;
6568  static integer inu;
6569  static doublereal bry[3], cyr[2], sti, rzi, zri, str, rzr, zrr;
6570 
6571 /* ***BEGIN PROLOGUE ZUNK1 */
6572 /* ***REFER TO ZBESK */
6573 
6574 /* ZUNK1 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE */
6575 /* RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE */
6576 /* UNIFORM ASYMPTOTIC EXPANSION. */
6577 /* MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. */
6578 /* NZ=-1 MEANS AN OVERFLOW WILL OCCUR */
6579 
6580 /* ***ROUTINES CALLED ZKSCL,ZS1S2,ZUCHK,ZUNIK,D1MACH,myzabs */
6581 /* ***END PROLOGUE ZUNK1 */
6582 /* COMPLEX CFN,CK,CONE,CRSC,CS,CSCL,CSGN,CSPN,CSR,CSS,CWRK,CY,CZERO, */
6583 /* *C1,C2,PHI,PHID,RZ,SUM,SUMD,S1,S2,Y,Z,ZETA1,ZETA1D,ZETA2,ZETA2D,ZR */
6584  /* Parameter adjustments */
6585  --yi;
6586  --yr;
6587 
6588  /* Function Body */
6589 
6590  kdflg = 1;
6591  *nz = 0;
6592 /* ----------------------------------------------------------------------- */
6593 /* EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN */
6594 /* THE UNDERFLOW LIMIT */
6595 /* ----------------------------------------------------------------------- */
6596  cscl = 1. / *tol;
6597  crsc = *tol;
6598  cssr[0] = cscl;
6599  cssr[1] = coner;
6600  cssr[2] = crsc;
6601  csrr[0] = crsc;
6602  csrr[1] = coner;
6603  csrr[2] = cscl;
6604  bry[0] = d1mach_(&c__1) * 1e3 / *tol;
6605  bry[1] = 1. / bry[0];
6606  bry[2] = d1mach_(&c__2);
6607  zrr = *zr;
6608  zri = *zi;
6609  if (*zr >= 0.) {
6610  goto L10;
6611  }
6612  zrr = -(*zr);
6613  zri = -(*zi);
6614 L10:
6615  j = 2;
6616  i__1 = *n;
6617  for (i__ = 1; i__ <= i__1; ++i__) {
6618 /* ----------------------------------------------------------------------- */
6619 /* J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J */
6620 /* ----------------------------------------------------------------------- */
6621  j = 3 - j;
6622  fn = *fnu + (doublereal) ((real) (i__ - 1));
6623  init[j - 1] = 0;
6624  zunik_(&zrr, &zri, &fn, &c__2, &c__0, tol, &init[j - 1], &phir[j - 1],
6625  &phii[j - 1], &zeta1r[j - 1], &zeta1i[j - 1], &zeta2r[j - 1],
6626  &zeta2i[j - 1], &sumr[j - 1], &sumi[j - 1], &cwrkr[(j << 4)
6627  - 16], &cwrki[(j << 4) - 16]);
6628  if (*kode == 1) {
6629  goto L20;
6630  }
6631  str = zrr + zeta2r[j - 1];
6632  sti = zri + zeta2i[j - 1];
6633  rast = fn / myzabs_(&str, &sti);
6634  str = str * rast * rast;
6635  sti = -sti * rast * rast;
6636  s1r = zeta1r[j - 1] - str;
6637  s1i = zeta1i[j - 1] - sti;
6638  goto L30;
6639 L20:
6640  s1r = zeta1r[j - 1] - zeta2r[j - 1];
6641  s1i = zeta1i[j - 1] - zeta2i[j - 1];
6642 L30:
6643  rs1 = s1r;
6644 /* ----------------------------------------------------------------------- */
6645 /* TEST FOR UNDERFLOW AND OVERFLOW */
6646 /* ----------------------------------------------------------------------- */
6647  if (abs(rs1) > *elim) {
6648  goto L60;
6649  }
6650  if (kdflg == 1) {
6651  kflag = 2;
6652  }
6653  if (abs(rs1) < *alim) {
6654  goto L40;
6655  }
6656 /* ----------------------------------------------------------------------- */
6657 /* REFINE TEST AND SCALE */
6658 /* ----------------------------------------------------------------------- */
6659  aphi = myzabs_(&phir[j - 1], &phii[j - 1]);
6660  rs1 += log(aphi);
6661  if (abs(rs1) > *elim) {
6662  goto L60;
6663  }
6664  if (kdflg == 1) {
6665  kflag = 1;
6666  }
6667  if (rs1 < 0.) {
6668  goto L40;
6669  }
6670  if (kdflg == 1) {
6671  kflag = 3;
6672  }
6673 L40:
6674 /* ----------------------------------------------------------------------- */
6675 /* SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR */
6676 /* EXPONENT EXTREMES */
6677 /* ----------------------------------------------------------------------- */
6678  s2r = phir[j - 1] * sumr[j - 1] - phii[j - 1] * sumi[j - 1];
6679  s2i = phir[j - 1] * sumi[j - 1] + phii[j - 1] * sumr[j - 1];
6680  str = exp(s1r) * cssr[kflag - 1];
6681  s1r = str * cos(s1i);
6682  s1i = str * sin(s1i);
6683  str = s2r * s1r - s2i * s1i;
6684  s2i = s1r * s2i + s2r * s1i;
6685  s2r = str;
6686  if (kflag != 1) {
6687  goto L50;
6688  }
6689  zuchk_(&s2r, &s2i, &nw, bry, tol);
6690  if (nw != 0) {
6691  goto L60;
6692  }
6693 L50:
6694  cyr[kdflg - 1] = s2r;
6695  cyi[kdflg - 1] = s2i;
6696  yr[i__] = s2r * csrr[kflag - 1];
6697  yi[i__] = s2i * csrr[kflag - 1];
6698  if (kdflg == 2) {
6699  goto L75;
6700  }
6701  kdflg = 2;
6702  goto L70;
6703 L60:
6704  if (rs1 > 0.) {
6705  goto L300;
6706  }
6707 /* ----------------------------------------------------------------------- */
6708 /* FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW */
6709 /* ----------------------------------------------------------------------- */
6710  if (*zr < 0.) {
6711  goto L300;
6712  }
6713  kdflg = 1;
6714  yr[i__] = zeror;
6715  yi[i__] = zeroi;
6716  ++(*nz);
6717  if (i__ == 1) {
6718  goto L70;
6719  }
6720  if (yr[i__ - 1] == zeror && yi[i__ - 1] == zeroi) {
6721  goto L70;
6722  }
6723  yr[i__ - 1] = zeror;
6724  yi[i__ - 1] = zeroi;
6725  ++(*nz);
6726 L70:
6727  ;
6728  }
6729  i__ = *n;
6730 L75:
6731  razr = 1. / myzabs_(&zrr, &zri);
6732  str = zrr * razr;
6733  sti = -zri * razr;
6734  rzr = (str + str) * razr;
6735  rzi = (sti + sti) * razr;
6736  ckr = fn * rzr;
6737  cki = fn * rzi;
6738  ib = i__ + 1;
6739  if (*n < ib) {
6740  goto L160;
6741  }
6742 /* ----------------------------------------------------------------------- */
6743 /* TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO */
6744 /* ON UNDERFLOW. */
6745 /* ----------------------------------------------------------------------- */
6746  fn = *fnu + (doublereal) ((real) (*n - 1));
6747  ipard = 1;
6748  if (*mr != 0) {
6749  ipard = 0;
6750  }
6751  initd = 0;
6752  zunik_(&zrr, &zri, &fn, &c__2, &ipard, tol, &initd, &phidr, &phidi, &
6753  zet1dr, &zet1di, &zet2dr, &zet2di, &sumdr, &sumdi, &cwrkr[32], &
6754  cwrki[32]);
6755  if (*kode == 1) {
6756  goto L80;
6757  }
6758  str = zrr + zet2dr;
6759  sti = zri + zet2di;
6760  rast = fn / myzabs_(&str, &sti);
6761  str = str * rast * rast;
6762  sti = -sti * rast * rast;
6763  s1r = zet1dr - str;
6764  s1i = zet1di - sti;
6765  goto L90;
6766 L80:
6767  s1r = zet1dr - zet2dr;
6768  s1i = zet1di - zet2di;
6769 L90:
6770  rs1 = s1r;
6771  if (abs(rs1) > *elim) {
6772  goto L95;
6773  }
6774  if (abs(rs1) < *alim) {
6775  goto L100;
6776  }
6777 /* ---------------------------------------------------------------------------- */
6778 /* REFINE ESTIMATE AND TEST */
6779 /* ------------------------------------------------------------------------- */
6780  aphi = myzabs_(&phidr, &phidi);
6781  rs1 += log(aphi);
6782  if (abs(rs1) < *elim) {
6783  goto L100;
6784  }
6785 L95:
6786  if (abs(rs1) > 0.) {
6787  goto L300;
6788  }
6789 /* ----------------------------------------------------------------------- */
6790 /* FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW */
6791 /* ----------------------------------------------------------------------- */
6792  if (*zr < 0.) {
6793  goto L300;
6794  }
6795  *nz = *n;
6796  i__1 = *n;
6797  for (i__ = 1; i__ <= i__1; ++i__) {
6798  yr[i__] = zeror;
6799  yi[i__] = zeroi;
6800 /* L96: */
6801  }
6802  return 0;
6803 /* --------------------------------------------------------------------------- */
6804 /* FORWARD RECUR FOR REMAINDER OF THE SEQUENCE */
6805 /* ---------------------------------------------------------------------------- */
6806 L100:
6807  s1r = cyr[0];
6808  s1i = cyi[0];
6809  s2r = cyr[1];
6810  s2i = cyi[1];
6811  c1r = csrr[kflag - 1];
6812  ascle = bry[kflag - 1];
6813  i__1 = *n;
6814  for (i__ = ib; i__ <= i__1; ++i__) {
6815  c2r = s2r;
6816  c2i = s2i;
6817  s2r = ckr * c2r - cki * c2i + s1r;
6818  s2i = ckr * c2i + cki * c2r + s1i;
6819  s1r = c2r;
6820  s1i = c2i;
6821  ckr += rzr;
6822  cki += rzi;
6823  c2r = s2r * c1r;
6824  c2i = s2i * c1r;
6825  yr[i__] = c2r;
6826  yi[i__] = c2i;
6827  if (kflag >= 3) {
6828  goto L120;
6829  }
6830  str = abs(c2r);
6831  sti = abs(c2i);
6832  c2m = max(str,sti);
6833  if (c2m <= ascle) {
6834  goto L120;
6835  }
6836  ++kflag;
6837  ascle = bry[kflag - 1];
6838  s1r *= c1r;
6839  s1i *= c1r;
6840  s2r = c2r;
6841  s2i = c2i;
6842  s1r *= cssr[kflag - 1];
6843  s1i *= cssr[kflag - 1];
6844  s2r *= cssr[kflag - 1];
6845  s2i *= cssr[kflag - 1];
6846  c1r = csrr[kflag - 1];
6847 L120:
6848  ;
6849  }
6850 L160:
6851  if (*mr == 0) {
6852  return 0;
6853  }
6854 /* ----------------------------------------------------------------------- */
6855 /* ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0 */
6856 /* ----------------------------------------------------------------------- */
6857  *nz = 0;
6858  fmr = (doublereal) ((real) (*mr));
6859  sgn = -d_sign(&pi, &fmr);
6860 /* ----------------------------------------------------------------------- */
6861 /* CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP. */
6862 /* ----------------------------------------------------------------------- */
6863  csgni = sgn;
6864  inu = (integer) ((real) (*fnu));
6865  fnf = *fnu - (doublereal) ((real) inu);
6866  ifn = inu + *n - 1;
6867  ang = fnf * sgn;
6868  cspnr = cos(ang);
6869  cspni = sin(ang);
6870  if (ifn % 2 == 0) {
6871  goto L170;
6872  }
6873  cspnr = -cspnr;
6874  cspni = -cspni;
6875 L170:
6876  asc = bry[0];
6877  iuf = 0;
6878  kk = *n;
6879  kdflg = 1;
6880  --ib;
6881  ic = ib - 1;
6882  i__1 = *n;
6883  for (k = 1; k <= i__1; ++k) {
6884  fn = *fnu + (doublereal) ((real) (kk - 1));
6885 /* ----------------------------------------------------------------------- */
6886 /* LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K */
6887 /* FUNCTION ABOVE */
6888 /* ----------------------------------------------------------------------- */
6889  m = 3;
6890  if (*n > 2) {
6891  goto L175;
6892  }
6893 L172:
6894  initd = init[j - 1];
6895  phidr = phir[j - 1];
6896  phidi = phii[j - 1];
6897  zet1dr = zeta1r[j - 1];
6898  zet1di = zeta1i[j - 1];
6899  zet2dr = zeta2r[j - 1];
6900  zet2di = zeta2i[j - 1];
6901  sumdr = sumr[j - 1];
6902  sumdi = sumi[j - 1];
6903  m = j;
6904  j = 3 - j;
6905  goto L180;
6906 L175:
6907  if (kk == *n && ib < *n) {
6908  goto L180;
6909  }
6910  if (kk == ib || kk == ic) {
6911  goto L172;
6912  }
6913  initd = 0;
6914 L180:
6915  zunik_(&zrr, &zri, &fn, &c__1, &c__0, tol, &initd, &phidr, &phidi, &
6916  zet1dr, &zet1di, &zet2dr, &zet2di, &sumdr, &sumdi, &cwrkr[(m
6917  << 4) - 16], &cwrki[(m << 4) - 16]);
6918  if (*kode == 1) {
6919  goto L200;
6920  }
6921  str = zrr + zet2dr;
6922  sti = zri + zet2di;
6923  rast = fn / myzabs_(&str, &sti);
6924  str = str * rast * rast;
6925  sti = -sti * rast * rast;
6926  s1r = -zet1dr + str;
6927  s1i = -zet1di + sti;
6928  goto L210;
6929 L200:
6930  s1r = -zet1dr + zet2dr;
6931  s1i = -zet1di + zet2di;
6932 L210:
6933 /* ----------------------------------------------------------------------- */
6934 /* TEST FOR UNDERFLOW AND OVERFLOW */
6935 /* ----------------------------------------------------------------------- */
6936  rs1 = s1r;
6937  if (abs(rs1) > *elim) {
6938  goto L260;
6939  }
6940  if (kdflg == 1) {
6941  iflag = 2;
6942  }
6943  if (abs(rs1) < *alim) {
6944  goto L220;
6945  }
6946 /* ----------------------------------------------------------------------- */
6947 /* REFINE TEST AND SCALE */
6948 /* ----------------------------------------------------------------------- */
6949  aphi = myzabs_(&phidr, &phidi);
6950  rs1 += log(aphi);
6951  if (abs(rs1) > *elim) {
6952  goto L260;
6953  }
6954  if (kdflg == 1) {
6955  iflag = 1;
6956  }
6957  if (rs1 < 0.) {
6958  goto L220;
6959  }
6960  if (kdflg == 1) {
6961  iflag = 3;
6962  }
6963 L220:
6964  str = phidr * sumdr - phidi * sumdi;
6965  sti = phidr * sumdi + phidi * sumdr;
6966  s2r = -csgni * sti;
6967  s2i = csgni * str;
6968  str = exp(s1r) * cssr[iflag - 1];
6969  s1r = str * cos(s1i);
6970  s1i = str * sin(s1i);
6971  str = s2r * s1r - s2i * s1i;
6972  s2i = s2r * s1i + s2i * s1r;
6973  s2r = str;
6974  if (iflag != 1) {
6975  goto L230;
6976  }
6977  zuchk_(&s2r, &s2i, &nw, bry, tol);
6978  if (nw == 0) {
6979  goto L230;
6980  }
6981  s2r = zeror;
6982  s2i = zeroi;
6983 L230:
6984  cyr[kdflg - 1] = s2r;
6985  cyi[kdflg - 1] = s2i;
6986  c2r = s2r;
6987  c2i = s2i;
6988  s2r *= csrr[iflag - 1];
6989  s2i *= csrr[iflag - 1];
6990 /* ----------------------------------------------------------------------- */
6991 /* ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N */
6992 /* ----------------------------------------------------------------------- */
6993  s1r = yr[kk];
6994  s1i = yi[kk];
6995  if (*kode == 1) {
6996  goto L250;
6997  }
6998  zs1s2_(&zrr, &zri, &s1r, &s1i, &s2r, &s2i, &nw, &asc, alim, &iuf);
6999  *nz += nw;
7000 L250:
7001  yr[kk] = s1r * cspnr - s1i * cspni + s2r;
7002  yi[kk] = cspnr * s1i + cspni * s1r + s2i;
7003  --kk;
7004  cspnr = -cspnr;
7005  cspni = -cspni;
7006  if (c2r != 0. || c2i != 0.) {
7007  goto L255;
7008  }
7009  kdflg = 1;
7010  goto L270;
7011 L255:
7012  if (kdflg == 2) {
7013  goto L275;
7014  }
7015  kdflg = 2;
7016  goto L270;
7017 L260:
7018  if (rs1 > 0.) {
7019  goto L300;
7020  }
7021  s2r = zeror;
7022  s2i = zeroi;
7023  goto L230;
7024 L270:
7025  ;
7026  }
7027  k = *n;
7028 L275:
7029  il = *n - k;
7030  if (il == 0) {
7031  return 0;
7032  }
7033 /* ----------------------------------------------------------------------- */
7034 /* RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE */
7035 /* K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP */
7036 /* INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. */
7037 /* ----------------------------------------------------------------------- */
7038  s1r = cyr[0];
7039  s1i = cyi[0];
7040  s2r = cyr[1];
7041  s2i = cyi[1];
7042  csr = csrr[iflag - 1];
7043  ascle = bry[iflag - 1];
7044  fn = (doublereal) ((real) (inu + il));
7045  i__1 = il;
7046  for (i__ = 1; i__ <= i__1; ++i__) {
7047  c2r = s2r;
7048  c2i = s2i;
7049  s2r = s1r + (fn + fnf) * (rzr * c2r - rzi * c2i);
7050  s2i = s1i + (fn + fnf) * (rzr * c2i + rzi * c2r);
7051  s1r = c2r;
7052  s1i = c2i;
7053  fn += -1.;
7054  c2r = s2r * csr;
7055  c2i = s2i * csr;
7056  ckr = c2r;
7057  cki = c2i;
7058  c1r = yr[kk];
7059  c1i = yi[kk];
7060  if (*kode == 1) {
7061  goto L280;
7062  }
7063  zs1s2_(&zrr, &zri, &c1r, &c1i, &c2r, &c2i, &nw, &asc, alim, &iuf);
7064  *nz += nw;
7065 L280:
7066  yr[kk] = c1r * cspnr - c1i * cspni + c2r;
7067  yi[kk] = c1r * cspni + c1i * cspnr + c2i;
7068  --kk;
7069  cspnr = -cspnr;
7070  cspni = -cspni;
7071  if (iflag >= 3) {
7072  goto L290;
7073  }
7074  c2r = abs(ckr);
7075  c2i = abs(cki);
7076  c2m = max(c2r,c2i);
7077  if (c2m <= ascle) {
7078  goto L290;
7079  }
7080  ++iflag;
7081  ascle = bry[iflag - 1];
7082  s1r *= csr;
7083  s1i *= csr;
7084  s2r = ckr;
7085  s2i = cki;
7086  s1r *= cssr[iflag - 1];
7087  s1i *= cssr[iflag - 1];
7088  s2r *= cssr[iflag - 1];
7089  s2i *= cssr[iflag - 1];
7090  csr = csrr[iflag - 1];
7091 L290:
7092  ;
7093  }
7094  return 0;
7095 L300:
7096  *nz = -1;
7097  return 0;
7098 } /* zunk1_ */
7099 
7100 /* Subroutine */ int zunk2_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *tol, doublereal *elim, doublereal *alim)
7101 {
7102  /* Initialized data */
7103 
7104  static doublereal zeror = 0.;
7105  static doublereal zeroi = 0.;
7106  static doublereal coner = 1.;
7107  static doublereal cr1r = 1.;
7108  static doublereal cr1i = 1.73205080756887729;
7109  static doublereal cr2r = -.5;
7110  static doublereal cr2i = -.866025403784438647;
7111  static doublereal hpi = 1.57079632679489662;
7112  static doublereal pi = 3.14159265358979324;
7113  static doublereal aic = 1.26551212348464539;
7114  static doublereal cipr[4] = { 1.,0.,-1.,0. };
7115  static doublereal cipi[4] = { 0.,-1.,0.,1. };
7116 
7117  /* System generated locals */
7118  integer i__1;
7119 
7120  /* Builtin functions */
7121 
7122  /* Local variables */
7123  static doublereal daii, aarg;
7124  static integer ndai;
7125  static doublereal dair, aphi, argi[2], cscl, phii[2], crsc, argr[2];
7126  static integer idum;
7127  static doublereal phir[2], csrr[3], cssr[3], rast, razr;
7128  static integer i__, k, j, iflag, kflag;
7129  static doublereal argdi, ascle;
7130  static integer kdflg;
7131  static doublereal phidi, argdr;
7132  static integer ipard;
7133  static doublereal csgni, phidr, cspni, asumi[2], bsumi[2];
7134  static doublereal cspnr, asumr[2], bsumr[2];
7135  static doublereal zeta1i[2], zeta2i[2], zet1di, zet2di, zeta1r[2], zeta2r[
7136  2], zet1dr, zet2dr;
7137  static integer ib, ic;
7138  static doublereal fn;
7139  static integer il, kk, in, nw;
7140  static doublereal asumdi, bsumdi, yy, asumdr, bsumdr, c1i, c2i, c2m;
7141  static doublereal c1r, c2r, s1i, s2i, rs1, s1r, s2r, aii, ang, asc, car,
7142  cki, fnf;
7143  static integer nai;
7144  static doublereal air;
7145  static integer ifn;
7146  static doublereal csi, ckr;
7147  static integer iuf;
7148  static doublereal cyi[2], fmr, sar, csr, sgn, zbi;
7149  static integer inu;
7150  static doublereal bry[3], cyr[2], pti, sti, zbr, zni, rzi, ptr, zri, str,
7151  znr, rzr, zrr;
7152 
7153 /* ***BEGIN PROLOGUE ZUNK2 */
7154 /* ***REFER TO ZBESK */
7155 
7156 /* ZUNK2 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE */
7157 /* RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE */
7158 /* UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN) */
7159 /* WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR */
7160 /* -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z IF Z IS IN THE RIGHT */
7161 /* HALF PLANE OR ZR=-Z IF Z IS IN THE LEFT HALF PLANE. MR INDIC- */
7162 /* ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. */
7163 /* NZ=-1 MEANS AN OVERFLOW WILL OCCUR */
7164 
7165 /* ***ROUTINES CALLED ZAIRY,ZKSCL,ZS1S2,ZUCHK,ZUNHJ,D1MACH,myzabs */
7166 /* ***END PROLOGUE ZUNK2 */
7167 /* COMPLEX AI,ARG,ARGD,ASUM,ASUMD,BSUM,BSUMD,CFN,CI,CIP,CK,CONE,CRSC, */
7168 /* *CR1,CR2,CS,CSCL,CSGN,CSPN,CSR,CSS,CY,CZERO,C1,C2,DAI,PHI,PHID,RZ, */
7169 /* *S1,S2,Y,Z,ZB,ZETA1,ZETA1D,ZETA2,ZETA2D,ZN,ZR */
7170  /* Parameter adjustments */
7171  --yi;
7172  --yr;
7173 
7174  /* Function Body */
7175 
7176  kdflg = 1;
7177  *nz = 0;
7178 /* ----------------------------------------------------------------------- */
7179 /* EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN */
7180 /* THE UNDERFLOW LIMIT */
7181 /* ----------------------------------------------------------------------- */
7182  cscl = 1. / *tol;
7183  crsc = *tol;
7184  cssr[0] = cscl;
7185  cssr[1] = coner;
7186  cssr[2] = crsc;
7187  csrr[0] = crsc;
7188  csrr[1] = coner;
7189  csrr[2] = cscl;
7190  bry[0] = d1mach_(&c__1) * 1e3 / *tol;
7191  bry[1] = 1. / bry[0];
7192  bry[2] = d1mach_(&c__2);
7193  zrr = *zr;
7194  zri = *zi;
7195  if (*zr >= 0.) {
7196  goto L10;
7197  }
7198  zrr = -(*zr);
7199  zri = -(*zi);
7200 L10:
7201  yy = zri;
7202  znr = zri;
7203  zni = -zrr;
7204  zbr = zrr;
7205  zbi = zri;
7206  inu = (integer) ((real) (*fnu));
7207  fnf = *fnu - (doublereal) ((real) inu);
7208  ang = -hpi * fnf;
7209  car = cos(ang);
7210  sar = sin(ang);
7211  c2r = hpi * sar;
7212  c2i = -hpi * car;
7213  kk = inu % 4 + 1;
7214  str = c2r * cipr[kk - 1] - c2i * cipi[kk - 1];
7215  sti = c2r * cipi[kk - 1] + c2i * cipr[kk - 1];
7216  csr = cr1r * str - cr1i * sti;
7217  csi = cr1r * sti + cr1i * str;
7218  if (yy > 0.) {
7219  goto L20;
7220  }
7221  znr = -znr;
7222  zbi = -zbi;
7223 L20:
7224 /* ----------------------------------------------------------------------- */
7225 /* K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST */
7226 /* QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY */
7227 /* CONJUGATION SINCE THE K FUNCTION IS REAL ON THE POSITIVE REAL AXIS */
7228 /* ----------------------------------------------------------------------- */
7229  j = 2;
7230  i__1 = *n;
7231  for (i__ = 1; i__ <= i__1; ++i__) {
7232 /* ----------------------------------------------------------------------- */
7233 /* J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J */
7234 /* ----------------------------------------------------------------------- */
7235  j = 3 - j;
7236  fn = *fnu + (doublereal) ((real) (i__ - 1));
7237  zunhj_(&znr, &zni, &fn, &c__0, tol, &phir[j - 1], &phii[j - 1], &argr[
7238  j - 1], &argi[j - 1], &zeta1r[j - 1], &zeta1i[j - 1], &zeta2r[
7239  j - 1], &zeta2i[j - 1], &asumr[j - 1], &asumi[j - 1], &bsumr[
7240  j - 1], &bsumi[j - 1]);
7241  if (*kode == 1) {
7242  goto L30;
7243  }
7244  str = zbr + zeta2r[j - 1];
7245  sti = zbi + zeta2i[j - 1];
7246  rast = fn / myzabs_(&str, &sti);
7247  str = str * rast * rast;
7248  sti = -sti * rast * rast;
7249  s1r = zeta1r[j - 1] - str;
7250  s1i = zeta1i[j - 1] - sti;
7251  goto L40;
7252 L30:
7253  s1r = zeta1r[j - 1] - zeta2r[j - 1];
7254  s1i = zeta1i[j - 1] - zeta2i[j - 1];
7255 L40:
7256 /* ----------------------------------------------------------------------- */
7257 /* TEST FOR UNDERFLOW AND OVERFLOW */
7258 /* ----------------------------------------------------------------------- */
7259  rs1 = s1r;
7260  if (abs(rs1) > *elim) {
7261  goto L70;
7262  }
7263  if (kdflg == 1) {
7264  kflag = 2;
7265  }
7266  if (abs(rs1) < *alim) {
7267  goto L50;
7268  }
7269 /* ----------------------------------------------------------------------- */
7270 /* REFINE TEST AND SCALE */
7271 /* ----------------------------------------------------------------------- */
7272  aphi = myzabs_(&phir[j - 1], &phii[j - 1]);
7273  aarg = myzabs_(&argr[j - 1], &argi[j - 1]);
7274  rs1 = rs1 + log(aphi) - log(aarg) * .25 - aic;
7275  if (abs(rs1) > *elim) {
7276  goto L70;
7277  }
7278  if (kdflg == 1) {
7279  kflag = 1;
7280  }
7281  if (rs1 < 0.) {
7282  goto L50;
7283  }
7284  if (kdflg == 1) {
7285  kflag = 3;
7286  }
7287 L50:
7288 /* ----------------------------------------------------------------------- */
7289 /* SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR */
7290 /* EXPONENT EXTREMES */
7291 /* ----------------------------------------------------------------------- */
7292  c2r = argr[j - 1] * cr2r - argi[j - 1] * cr2i;
7293  c2i = argr[j - 1] * cr2i + argi[j - 1] * cr2r;
7294  zairy_(&c2r, &c2i, &c__0, &c__2, &air, &aii, &nai, &idum);
7295  zairy_(&c2r, &c2i, &c__1, &c__2, &dair, &daii, &ndai, &idum);
7296  str = dair * bsumr[j - 1] - daii * bsumi[j - 1];
7297  sti = dair * bsumi[j - 1] + daii * bsumr[j - 1];
7298  ptr = str * cr2r - sti * cr2i;
7299  pti = str * cr2i + sti * cr2r;
7300  str = ptr + (air * asumr[j - 1] - aii * asumi[j - 1]);
7301  sti = pti + (air * asumi[j - 1] + aii * asumr[j - 1]);
7302  ptr = str * phir[j - 1] - sti * phii[j - 1];
7303  pti = str * phii[j - 1] + sti * phir[j - 1];
7304  s2r = ptr * csr - pti * csi;
7305  s2i = ptr * csi + pti * csr;
7306  str = exp(s1r) * cssr[kflag - 1];
7307  s1r = str * cos(s1i);
7308  s1i = str * sin(s1i);
7309  str = s2r * s1r - s2i * s1i;
7310  s2i = s1r * s2i + s2r * s1i;
7311  s2r = str;
7312  if (kflag != 1) {
7313  goto L60;
7314  }
7315  zuchk_(&s2r, &s2i, &nw, bry, tol);
7316  if (nw != 0) {
7317  goto L70;
7318  }
7319 L60:
7320  if (yy <= 0.) {
7321  s2i = -s2i;
7322  }
7323  cyr[kdflg - 1] = s2r;
7324  cyi[kdflg - 1] = s2i;
7325  yr[i__] = s2r * csrr[kflag - 1];
7326  yi[i__] = s2i * csrr[kflag - 1];
7327  str = csi;
7328  csi = -csr;
7329  csr = str;
7330  if (kdflg == 2) {
7331  goto L85;
7332  }
7333  kdflg = 2;
7334  goto L80;
7335 L70:
7336  if (rs1 > 0.) {
7337  goto L320;
7338  }
7339 /* ----------------------------------------------------------------------- */
7340 /* FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW */
7341 /* ----------------------------------------------------------------------- */
7342  if (*zr < 0.) {
7343  goto L320;
7344  }
7345  kdflg = 1;
7346  yr[i__] = zeror;
7347  yi[i__] = zeroi;
7348  ++(*nz);
7349  str = csi;
7350  csi = -csr;
7351  csr = str;
7352  if (i__ == 1) {
7353  goto L80;
7354  }
7355  if (yr[i__ - 1] == zeror && yi[i__ - 1] == zeroi) {
7356  goto L80;
7357  }
7358  yr[i__ - 1] = zeror;
7359  yi[i__ - 1] = zeroi;
7360  ++(*nz);
7361 L80:
7362  ;
7363  }
7364  i__ = *n;
7365 L85:
7366  razr = 1. / myzabs_(&zrr, &zri);
7367  str = zrr * razr;
7368  sti = -zri * razr;
7369  rzr = (str + str) * razr;
7370  rzi = (sti + sti) * razr;
7371  ckr = fn * rzr;
7372  cki = fn * rzi;
7373  ib = i__ + 1;
7374  if (*n < ib) {
7375  goto L180;
7376  }
7377 /* ----------------------------------------------------------------------- */
7378 /* TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO */
7379 /* ON UNDERFLOW. */
7380 /* ----------------------------------------------------------------------- */
7381  fn = *fnu + (doublereal) ((real) (*n - 1));
7382  ipard = 1;
7383  if (*mr != 0) {
7384  ipard = 0;
7385  }
7386  zunhj_(&znr, &zni, &fn, &ipard, tol, &phidr, &phidi, &argdr, &argdi, &
7387  zet1dr, &zet1di, &zet2dr, &zet2di, &asumdr, &asumdi, &bsumdr, &
7388  bsumdi);
7389  if (*kode == 1) {
7390  goto L90;
7391  }
7392  str = zbr + zet2dr;
7393  sti = zbi + zet2di;
7394  rast = fn / myzabs_(&str, &sti);
7395  str = str * rast * rast;
7396  sti = -sti * rast * rast;
7397  s1r = zet1dr - str;
7398  s1i = zet1di - sti;
7399  goto L100;
7400 L90:
7401  s1r = zet1dr - zet2dr;
7402  s1i = zet1di - zet2di;
7403 L100:
7404  rs1 = s1r;
7405  if (abs(rs1) > *elim) {
7406  goto L105;
7407  }
7408  if (abs(rs1) < *alim) {
7409  goto L120;
7410  }
7411 /* ---------------------------------------------------------------------------- */
7412 /* REFINE ESTIMATE AND TEST */
7413 /* ------------------------------------------------------------------------- */
7414  aphi = myzabs_(&phidr, &phidi);
7415  rs1 += log(aphi);
7416  if (abs(rs1) < *elim) {
7417  goto L120;
7418  }
7419 L105:
7420  if (rs1 > 0.) {
7421  goto L320;
7422  }
7423 /* ----------------------------------------------------------------------- */
7424 /* FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW */
7425 /* ----------------------------------------------------------------------- */
7426  if (*zr < 0.) {
7427  goto L320;
7428  }
7429  *nz = *n;
7430  i__1 = *n;
7431  for (i__ = 1; i__ <= i__1; ++i__) {
7432  yr[i__] = zeror;
7433  yi[i__] = zeroi;
7434 /* L106: */
7435  }
7436  return 0;
7437 L120:
7438  s1r = cyr[0];
7439  s1i = cyi[0];
7440  s2r = cyr[1];
7441  s2i = cyi[1];
7442  c1r = csrr[kflag - 1];
7443  ascle = bry[kflag - 1];
7444  i__1 = *n;
7445  for (i__ = ib; i__ <= i__1; ++i__) {
7446  c2r = s2r;
7447  c2i = s2i;
7448  s2r = ckr * c2r - cki * c2i + s1r;
7449  s2i = ckr * c2i + cki * c2r + s1i;
7450  s1r = c2r;
7451  s1i = c2i;
7452  ckr += rzr;
7453  cki += rzi;
7454  c2r = s2r * c1r;
7455  c2i = s2i * c1r;
7456  yr[i__] = c2r;
7457  yi[i__] = c2i;
7458  if (kflag >= 3) {
7459  goto L130;
7460  }
7461  str = abs(c2r);
7462  sti = abs(c2i);
7463  c2m = max(str,sti);
7464  if (c2m <= ascle) {
7465  goto L130;
7466  }
7467  ++kflag;
7468  ascle = bry[kflag - 1];
7469  s1r *= c1r;
7470  s1i *= c1r;
7471  s2r = c2r;
7472  s2i = c2i;
7473  s1r *= cssr[kflag - 1];
7474  s1i *= cssr[kflag - 1];
7475  s2r *= cssr[kflag - 1];
7476  s2i *= cssr[kflag - 1];
7477  c1r = csrr[kflag - 1];
7478 L130:
7479  ;
7480  }
7481 L180:
7482  if (*mr == 0) {
7483  return 0;
7484  }
7485 /* ----------------------------------------------------------------------- */
7486 /* ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0 */
7487 /* ----------------------------------------------------------------------- */
7488  *nz = 0;
7489  fmr = (doublereal) ((real) (*mr));
7490  sgn = -d_sign(&pi, &fmr);
7491 /* ----------------------------------------------------------------------- */
7492 /* CSPN AND CSGN ARE COEFF OF K AND I FUNCIONS RESP. */
7493 /* ----------------------------------------------------------------------- */
7494  csgni = sgn;
7495  if (yy <= 0.) {
7496  csgni = -csgni;
7497  }
7498  ifn = inu + *n - 1;
7499  ang = fnf * sgn;
7500  cspnr = cos(ang);
7501  cspni = sin(ang);
7502  if (ifn % 2 == 0) {
7503  goto L190;
7504  }
7505  cspnr = -cspnr;
7506  cspni = -cspni;
7507 L190:
7508 /* ----------------------------------------------------------------------- */
7509 /* CS=COEFF OF THE J FUNCTION TO GET THE I FUNCTION. I(FNU,Z) IS */
7510 /* COMPUTED FROM EXP(I*FNU*HPI)*J(FNU,-I*Z) WHERE Z IS IN THE FIRST */
7511 /* QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY */
7512 /* CONJUGATION SINCE THE I FUNCTION IS REAL ON THE POSITIVE REAL AXIS */
7513 /* ----------------------------------------------------------------------- */
7514  csr = sar * csgni;
7515  csi = car * csgni;
7516  in = ifn % 4 + 1;
7517  c2r = cipr[in - 1];
7518  c2i = cipi[in - 1];
7519  str = csr * c2r + csi * c2i;
7520  csi = -csr * c2i + csi * c2r;
7521  csr = str;
7522  asc = bry[0];
7523  iuf = 0;
7524  kk = *n;
7525  kdflg = 1;
7526  --ib;
7527  ic = ib - 1;
7528  i__1 = *n;
7529  for (k = 1; k <= i__1; ++k) {
7530  fn = *fnu + (doublereal) ((real) (kk - 1));
7531 /* ----------------------------------------------------------------------- */
7532 /* LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K */
7533 /* FUNCTION ABOVE */
7534 /* ----------------------------------------------------------------------- */
7535  if (*n > 2) {
7536  goto L175;
7537  }
7538 L172:
7539  phidr = phir[j - 1];
7540  phidi = phii[j - 1];
7541  argdr = argr[j - 1];
7542  argdi = argi[j - 1];
7543  zet1dr = zeta1r[j - 1];
7544  zet1di = zeta1i[j - 1];
7545  zet2dr = zeta2r[j - 1];
7546  zet2di = zeta2i[j - 1];
7547  asumdr = asumr[j - 1];
7548  asumdi = asumi[j - 1];
7549  bsumdr = bsumr[j - 1];
7550  bsumdi = bsumi[j - 1];
7551  j = 3 - j;
7552  goto L210;
7553 L175:
7554  if (kk == *n && ib < *n) {
7555  goto L210;
7556  }
7557  if (kk == ib || kk == ic) {
7558  goto L172;
7559  }
7560  zunhj_(&znr, &zni, &fn, &c__0, tol, &phidr, &phidi, &argdr, &argdi, &
7561  zet1dr, &zet1di, &zet2dr, &zet2di, &asumdr, &asumdi, &bsumdr,
7562  &bsumdi);
7563 L210:
7564  if (*kode == 1) {
7565  goto L220;
7566  }
7567  str = zbr + zet2dr;
7568  sti = zbi + zet2di;
7569  rast = fn / myzabs_(&str, &sti);
7570  str = str * rast * rast;
7571  sti = -sti * rast * rast;
7572  s1r = -zet1dr + str;
7573  s1i = -zet1di + sti;
7574  goto L230;
7575 L220:
7576  s1r = -zet1dr + zet2dr;
7577  s1i = -zet1di + zet2di;
7578 L230:
7579 /* ----------------------------------------------------------------------- */
7580 /* TEST FOR UNDERFLOW AND OVERFLOW */
7581 /* ----------------------------------------------------------------------- */
7582  rs1 = s1r;
7583  if (abs(rs1) > *elim) {
7584  goto L280;
7585  }
7586  if (kdflg == 1) {
7587  iflag = 2;
7588  }
7589  if (abs(rs1) < *alim) {
7590  goto L240;
7591  }
7592 /* ----------------------------------------------------------------------- */
7593 /* REFINE TEST AND SCALE */
7594 /* ----------------------------------------------------------------------- */
7595  aphi = myzabs_(&phidr, &phidi);
7596  aarg = myzabs_(&argdr, &argdi);
7597  rs1 = rs1 + log(aphi) - log(aarg) * .25 - aic;
7598  if (abs(rs1) > *elim) {
7599  goto L280;
7600  }
7601  if (kdflg == 1) {
7602  iflag = 1;
7603  }
7604  if (rs1 < 0.) {
7605  goto L240;
7606  }
7607  if (kdflg == 1) {
7608  iflag = 3;
7609  }
7610 L240:
7611  zairy_(&argdr, &argdi, &c__0, &c__2, &air, &aii, &nai, &idum);
7612  zairy_(&argdr, &argdi, &c__1, &c__2, &dair, &daii, &ndai, &idum);
7613  str = dair * bsumdr - daii * bsumdi;
7614  sti = dair * bsumdi + daii * bsumdr;
7615  str += air * asumdr - aii * asumdi;
7616  sti += air * asumdi + aii * asumdr;
7617  ptr = str * phidr - sti * phidi;
7618  pti = str * phidi + sti * phidr;
7619  s2r = ptr * csr - pti * csi;
7620  s2i = ptr * csi + pti * csr;
7621  str = exp(s1r) * cssr[iflag - 1];
7622  s1r = str * cos(s1i);
7623  s1i = str * sin(s1i);
7624  str = s2r * s1r - s2i * s1i;
7625  s2i = s2r * s1i + s2i * s1r;
7626  s2r = str;
7627  if (iflag != 1) {
7628  goto L250;
7629  }
7630  zuchk_(&s2r, &s2i, &nw, bry, tol);
7631  if (nw == 0) {
7632  goto L250;
7633  }
7634  s2r = zeror;
7635  s2i = zeroi;
7636 L250:
7637  if (yy <= 0.) {
7638  s2i = -s2i;
7639  }
7640  cyr[kdflg - 1] = s2r;
7641  cyi[kdflg - 1] = s2i;
7642  c2r = s2r;
7643  c2i = s2i;
7644  s2r *= csrr[iflag - 1];
7645  s2i *= csrr[iflag - 1];
7646 /* ----------------------------------------------------------------------- */
7647 /* ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N */
7648 /* ----------------------------------------------------------------------- */
7649  s1r = yr[kk];
7650  s1i = yi[kk];
7651  if (*kode == 1) {
7652  goto L270;
7653  }
7654  zs1s2_(&zrr, &zri, &s1r, &s1i, &s2r, &s2i, &nw, &asc, alim, &iuf);
7655  *nz += nw;
7656 L270:
7657  yr[kk] = s1r * cspnr - s1i * cspni + s2r;
7658  yi[kk] = s1r * cspni + s1i * cspnr + s2i;
7659  --kk;
7660  cspnr = -cspnr;
7661  cspni = -cspni;
7662  str = csi;
7663  csi = -csr;
7664  csr = str;
7665  if (c2r != 0. || c2i != 0.) {
7666  goto L255;
7667  }
7668  kdflg = 1;
7669  goto L290;
7670 L255:
7671  if (kdflg == 2) {
7672  goto L295;
7673  }
7674  kdflg = 2;
7675  goto L290;
7676 L280:
7677  if (rs1 > 0.) {
7678  goto L320;
7679  }
7680  s2r = zeror;
7681  s2i = zeroi;
7682  goto L250;
7683 L290:
7684  ;
7685  }
7686  k = *n;
7687 L295:
7688  il = *n - k;
7689  if (il == 0) {
7690  return 0;
7691  }
7692 /* ----------------------------------------------------------------------- */
7693 /* RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE */
7694 /* K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP */
7695 /* INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES. */
7696 /* ----------------------------------------------------------------------- */
7697  s1r = cyr[0];
7698  s1i = cyi[0];
7699  s2r = cyr[1];
7700  s2i = cyi[1];
7701  csr = csrr[iflag - 1];
7702  ascle = bry[iflag - 1];
7703  fn = (doublereal) ((real) (inu + il));
7704  i__1 = il;
7705  for (i__ = 1; i__ <= i__1; ++i__) {
7706  c2r = s2r;
7707  c2i = s2i;
7708  s2r = s1r + (fn + fnf) * (rzr * c2r - rzi * c2i);
7709  s2i = s1i + (fn + fnf) * (rzr * c2i + rzi * c2r);
7710  s1r = c2r;
7711  s1i = c2i;
7712  fn += -1.;
7713  c2r = s2r * csr;
7714  c2i = s2i * csr;
7715  ckr = c2r;
7716  cki = c2i;
7717  c1r = yr[kk];
7718  c1i = yi[kk];
7719  if (*kode == 1) {
7720  goto L300;
7721  }
7722  zs1s2_(&zrr, &zri, &c1r, &c1i, &c2r, &c2i, &nw, &asc, alim, &iuf);
7723  *nz += nw;
7724 L300:
7725  yr[kk] = c1r * cspnr - c1i * cspni + c2r;
7726  yi[kk] = c1r * cspni + c1i * cspnr + c2i;
7727  --kk;
7728  cspnr = -cspnr;
7729  cspni = -cspni;
7730  if (iflag >= 3) {
7731  goto L310;
7732  }
7733  c2r = abs(ckr);
7734  c2i = abs(cki);
7735  c2m = max(c2r,c2i);
7736  if (c2m <= ascle) {
7737  goto L310;
7738  }
7739  ++iflag;
7740  ascle = bry[iflag - 1];
7741  s1r *= csr;
7742  s1i *= csr;
7743  s2r = ckr;
7744  s2i = cki;
7745  s1r *= cssr[iflag - 1];
7746  s1i *= cssr[iflag - 1];
7747  s2r *= cssr[iflag - 1];
7748  s2i *= cssr[iflag - 1];
7749  csr = csrr[iflag - 1];
7750 L310:
7751  ;
7752  }
7753  return 0;
7754 L320:
7755  *nz = -1;
7756  return 0;
7757 } /* zunk2_ */
7758 
7759 /* Subroutine */ int zuoik_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *ikflg, integer *n, doublereal *yr, doublereal *yi, integer *nuf, doublereal *tol, doublereal *elim, doublereal *alim)
7760 {
7761  /* Initialized data */
7762 
7763  static doublereal zeror = 0.;
7764  static doublereal zeroi = 0.;
7765  static doublereal aic = 1.265512123484645396;
7766 
7767  /* System generated locals */
7768  integer i__1;
7769 
7770  /* Builtin functions */
7771 
7772  /* Local variables */
7773  static doublereal aarg, aphi, argi, phii, argr;
7774  static integer idum;
7775  static doublereal phir;
7776  static integer init;
7777  static doublereal sumi, sumr;
7778  static integer i__;
7779  static doublereal ascle;
7780  static integer iform;
7781  static doublereal asumi, bsumi, cwrki[16];
7782  static doublereal asumr, bsumr, cwrkr[16];
7783  static doublereal zeta1i, zeta2i, zeta1r, zeta2r, ax, ay;
7784  static integer nn, nw;
7785  static doublereal fnn, gnn, zbi, czi, gnu, zbr, czr, rcz, sti, zni, zri,
7786  str, znr, zrr;
7787 
7788 /* ***BEGIN PROLOGUE ZUOIK */
7789 /* ***REFER TO ZBESI,ZBESK,ZBESH */
7790 
7791 /* ZUOIK COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC */
7792 /* EXPANSIONS FOR THE I AND K FUNCTIONS AND COMPARES THEM */
7793 /* (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW */
7794 /* WHERE ALIM.LT.ELIM. IF THE MAGNITUDE, BASED ON THE LEADING */
7795 /* EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN */
7796 /* THE RESULT IS ON SCALE. IF NOT, THEN A REFINED TEST USING OTHER */
7797 /* MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE */
7798 /* EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)= */
7799 /* EXP(-ELIM)/TOL */
7800 
7801 /* IKFLG=1 MEANS THE I SEQUENCE IS TESTED */
7802 /* =2 MEANS THE K SEQUENCE IS TESTED */
7803 /* NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE */
7804 /* =-1 MEANS AN OVERFLOW WOULD OCCUR */
7805 /* IKFLG=1 AND NUF.GT.0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO */
7806 /* THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE */
7807 /* IKFLG=2 AND NUF.EQ.N MEANS ALL Y VALUES WERE SET TO ZERO */
7808 /* IKFLG=2 AND 0.LT.NUF.LT.N NOT CONSIDERED. Y MUST BE SET BY */
7809 /* ANOTHER ROUTINE */
7810 
7811 /* ***ROUTINES CALLED ZUCHK,ZUNHJ,ZUNIK,D1MACH,myzabs,ZLOG */
7812 /* ***END PROLOGUE ZUOIK */
7813 /* COMPLEX ARG,ASUM,BSUM,CWRK,CZ,CZERO,PHI,SUM,Y,Z,ZB,ZETA1,ZETA2,ZN, */
7814 /* *ZR */
7815  /* Parameter adjustments */
7816  --yi;
7817  --yr;
7818 
7819  /* Function Body */
7820  *nuf = 0;
7821  nn = *n;
7822  zrr = *zr;
7823  zri = *zi;
7824  if (*zr >= 0.) {
7825  goto L10;
7826  }
7827  zrr = -(*zr);
7828  zri = -(*zi);
7829 L10:
7830  zbr = zrr;
7831  zbi = zri;
7832  ax = abs(*zr) * 1.7321;
7833  ay = abs(*zi);
7834  iform = 1;
7835  if (ay > ax) {
7836  iform = 2;
7837  }
7838  gnu = max(*fnu,1.);
7839  if (*ikflg == 1) {
7840  goto L20;
7841  }
7842  fnn = (doublereal) ((real) nn);
7843  gnn = *fnu + fnn - 1.;
7844  gnu = max(gnn,fnn);
7845 L20:
7846 /* ----------------------------------------------------------------------- */
7847 /* ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE */
7848 /* REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET */
7849 /* THE SIGN OF THE IMAGINARY PART CORRECT. */
7850 /* ----------------------------------------------------------------------- */
7851  if (iform == 2) {
7852  goto L30;
7853  }
7854  init = 0;
7855  zunik_(&zrr, &zri, &gnu, ikflg, &c__1, tol, &init, &phir, &phii, &zeta1r,
7856  &zeta1i, &zeta2r, &zeta2i, &sumr, &sumi, cwrkr, cwrki);
7857  czr = -zeta1r + zeta2r;
7858  czi = -zeta1i + zeta2i;
7859  goto L50;
7860 L30:
7861  znr = zri;
7862  zni = -zrr;
7863  if (*zi > 0.) {
7864  goto L40;
7865  }
7866  znr = -znr;
7867 L40:
7868  zunhj_(&znr, &zni, &gnu, &c__1, tol, &phir, &phii, &argr, &argi, &zeta1r,
7869  &zeta1i, &zeta2r, &zeta2i, &asumr, &asumi, &bsumr, &bsumi);
7870  czr = -zeta1r + zeta2r;
7871  czi = -zeta1i + zeta2i;
7872  aarg = myzabs_(&argr, &argi);
7873 L50:
7874  if (*kode == 1) {
7875  goto L60;
7876  }
7877  czr -= zbr;
7878  czi -= zbi;
7879 L60:
7880  if (*ikflg == 1) {
7881  goto L70;
7882  }
7883  czr = -czr;
7884  czi = -czi;
7885 L70:
7886  aphi = myzabs_(&phir, &phii);
7887  rcz = czr;
7888 /* ----------------------------------------------------------------------- */
7889 /* OVERFLOW TEST */
7890 /* ----------------------------------------------------------------------- */
7891  if (rcz > *elim) {
7892  goto L210;
7893  }
7894  if (rcz < *alim) {
7895  goto L80;
7896  }
7897  rcz += log(aphi);
7898  if (iform == 2) {
7899  rcz = rcz - log(aarg) * .25 - aic;
7900  }
7901  if (rcz > *elim) {
7902  goto L210;
7903  }
7904  goto L130;
7905 L80:
7906 /* ----------------------------------------------------------------------- */
7907 /* UNDERFLOW TEST */
7908 /* ----------------------------------------------------------------------- */
7909  if (rcz < -(*elim)) {
7910  goto L90;
7911  }
7912  if (rcz > -(*alim)) {
7913  goto L130;
7914  }
7915  rcz += log(aphi);
7916  if (iform == 2) {
7917  rcz = rcz - log(aarg) * .25 - aic;
7918  }
7919  if (rcz > -(*elim)) {
7920  goto L110;
7921  }
7922 L90:
7923  i__1 = nn;
7924  for (i__ = 1; i__ <= i__1; ++i__) {
7925  yr[i__] = zeror;
7926  yi[i__] = zeroi;
7927 /* L100: */
7928  }
7929  *nuf = nn;
7930  return 0;
7931 L110:
7932  ascle = d1mach_(&c__1) * 1e3 / *tol;
7933  zlog_(&phir, &phii, &str, &sti, &idum);
7934  czr += str;
7935  czi += sti;
7936  if (iform == 1) {
7937  goto L120;
7938  }
7939  zlog_(&argr, &argi, &str, &sti, &idum);
7940  czr = czr - str * .25 - aic;
7941  czi -= sti * .25;
7942 L120:
7943  ax = exp(rcz) / *tol;
7944  ay = czi;
7945  czr = ax * cos(ay);
7946  czi = ax * sin(ay);
7947  zuchk_(&czr, &czi, &nw, &ascle, tol);
7948  if (nw != 0) {
7949  goto L90;
7950  }
7951 L130:
7952  if (*ikflg == 2) {
7953  return 0;
7954  }
7955  if (*n == 1) {
7956  return 0;
7957  }
7958 /* ----------------------------------------------------------------------- */
7959 /* SET UNDERFLOWS ON I SEQUENCE */
7960 /* ----------------------------------------------------------------------- */
7961 L140:
7962  gnu = *fnu + (doublereal) ((real) (nn - 1));
7963  if (iform == 2) {
7964  goto L150;
7965  }
7966  init = 0;
7967  zunik_(&zrr, &zri, &gnu, ikflg, &c__1, tol, &init, &phir, &phii, &zeta1r,
7968  &zeta1i, &zeta2r, &zeta2i, &sumr, &sumi, cwrkr, cwrki);
7969  czr = -zeta1r + zeta2r;
7970  czi = -zeta1i + zeta2i;
7971  goto L160;
7972 L150:
7973  zunhj_(&znr, &zni, &gnu, &c__1, tol, &phir, &phii, &argr, &argi, &zeta1r,
7974  &zeta1i, &zeta2r, &zeta2i, &asumr, &asumi, &bsumr, &bsumi);
7975  czr = -zeta1r + zeta2r;
7976  czi = -zeta1i + zeta2i;
7977  aarg = myzabs_(&argr, &argi);
7978 L160:
7979  if (*kode == 1) {
7980  goto L170;
7981  }
7982  czr -= zbr;
7983  czi -= zbi;
7984 L170:
7985  aphi = myzabs_(&phir, &phii);
7986  rcz = czr;
7987  if (rcz < -(*elim)) {
7988  goto L180;
7989  }
7990  if (rcz > -(*alim)) {
7991  return 0;
7992  }
7993  rcz += log(aphi);
7994  if (iform == 2) {
7995  rcz = rcz - log(aarg) * .25 - aic;
7996  }
7997  if (rcz > -(*elim)) {
7998  goto L190;
7999  }
8000 L180:
8001  yr[nn] = zeror;
8002  yi[nn] = zeroi;
8003  --nn;
8004  ++(*nuf);
8005  if (nn == 0) {
8006  return 0;
8007  }
8008  goto L140;
8009 L190:
8010  ascle = d1mach_(&c__1) * 1e3 / *tol;
8011  zlog_(&phir, &phii, &str, &sti, &idum);
8012  czr += str;
8013  czi += sti;
8014  if (iform == 1) {
8015  goto L200;
8016  }
8017  zlog_(&argr, &argi, &str, &sti, &idum);
8018  czr = czr - str * .25 - aic;
8019  czi -= sti * .25;
8020 L200:
8021  ax = exp(rcz) / *tol;
8022  ay = czi;
8023  czr = ax * cos(ay);
8024  czi = ax * sin(ay);
8025  zuchk_(&czr, &czi, &nw, &ascle, tol);
8026  if (nw != 0) {
8027  goto L180;
8028  }
8029  return 0;
8030 L210:
8031  *nuf = -1;
8032  return 0;
8033 } /* zuoik_ */
8034 
8035 /* Subroutine */ int zwrsk_(doublereal *zrr, doublereal *zri, doublereal *fnu, integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *cwr, doublereal *cwi, doublereal *tol, doublereal *elim, doublereal *alim)
8036 {
8037  /* System generated locals */
8038  integer i__1;
8039 
8040  /* Builtin functions */
8041 
8042  /* Local variables */
8043  static doublereal ract;
8044  static integer i__;
8045  static doublereal ascle, csclr, cinui, cinur;
8046  static integer nw;
8047  static doublereal c1i, c2i;
8048  static doublereal c1r, c2r, act, acw, cti, ctr, pti, sti, ptr, str;
8049 
8050 /* ***BEGIN PROLOGUE ZWRSK */
8051 /* ***REFER TO ZBESI,ZBESK */
8052 
8053 /* ZWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY */
8054 /* NORMALIZING THE I FUNCTION RATIOS FROM ZRATI BY THE WRONSKIAN */
8055 
8056 /* ***ROUTINES CALLED D1MACH,ZBKNU,ZRATI,myzabs */
8057 /* ***END PROLOGUE ZWRSK */
8058 /* COMPLEX CINU,CSCL,CT,CW,C1,C2,RCT,ST,Y,ZR */
8059 /* ----------------------------------------------------------------------- */
8060 /* I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS */
8061 /* Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM CRATI NORMALIZED BY THE */
8062 /* WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM CBKNU. */
8063 /* ----------------------------------------------------------------------- */
8064  /* Parameter adjustments */
8065  --yi;
8066  --yr;
8067  --cwr;
8068  --cwi;
8069 
8070  /* Function Body */
8071  *nz = 0;
8072  zbknu_(zrr, zri, fnu, kode, &c__2, &cwr[1], &cwi[1], &nw, tol, elim, alim)
8073  ;
8074  if (nw != 0) {
8075  goto L50;
8076  }
8077  zrati_(zrr, zri, fnu, n, &yr[1], &yi[1], tol);
8078 /* ----------------------------------------------------------------------- */
8079 /* RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z), */
8080 /* R(FNU+J-1,Z)=Y(J), J=1,...,N */
8081 /* ----------------------------------------------------------------------- */
8082  cinur = 1.;
8083  cinui = 0.;
8084  if (*kode == 1) {
8085  goto L10;
8086  }
8087  cinur = cos(*zri);
8088  cinui = sin(*zri);
8089 L10:
8090 /* ----------------------------------------------------------------------- */
8091 /* ON LOW EXPONENT MACHINES THE K FUNCTIONS CAN BE CLOSE TO BOTH */
8092 /* THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE */
8093 /* SCALED TO PREVENT OVER OR UNDERFLOW. CUOIK HAS DETERMINED THAT */
8094 /* THE RESULT IS ON SCALE. */
8095 /* ----------------------------------------------------------------------- */
8096  acw = myzabs_(&cwr[2], &cwi[2]);
8097  ascle = d1mach_(&c__1) * 1e3 / *tol;
8098  csclr = 1.;
8099  if (acw > ascle) {
8100  goto L20;
8101  }
8102  csclr = 1. / *tol;
8103  goto L30;
8104 L20:
8105  ascle = 1. / ascle;
8106  if (acw < ascle) {
8107  goto L30;
8108  }
8109  csclr = *tol;
8110 L30:
8111  c1r = cwr[1] * csclr;
8112  c1i = cwi[1] * csclr;
8113  c2r = cwr[2] * csclr;
8114  c2i = cwi[2] * csclr;
8115  str = yr[1];
8116  sti = yi[1];
8117 /* ----------------------------------------------------------------------- */
8118 /* CINU=CINU*(CONJG(CT)/CABS(CT))*(1.0D0/CABS(CT) PREVENTS */
8119 /* UNDER- OR OVERFLOW PREMATURELY BY SQUARING CABS(CT) */
8120 /* ----------------------------------------------------------------------- */
8121  ptr = str * c1r - sti * c1i;
8122  pti = str * c1i + sti * c1r;
8123  ptr += c2r;
8124  pti += c2i;
8125  ctr = *zrr * ptr - *zri * pti;
8126  cti = *zrr * pti + *zri * ptr;
8127  act = myzabs_(&ctr, &cti);
8128  ract = 1. / act;
8129  ctr *= ract;
8130  cti = -cti * ract;
8131  ptr = cinur * ract;
8132  pti = cinui * ract;
8133  cinur = ptr * ctr - pti * cti;
8134  cinui = ptr * cti + pti * ctr;
8135  yr[1] = cinur * csclr;
8136  yi[1] = cinui * csclr;
8137  if (*n == 1) {
8138  return 0;
8139  }
8140  i__1 = *n;
8141  for (i__ = 2; i__ <= i__1; ++i__) {
8142  ptr = str * cinur - sti * cinui;
8143  cinui = str * cinui + sti * cinur;
8144  cinur = ptr;
8145  str = yr[i__];
8146  sti = yi[i__];
8147  yr[i__] = cinur * csclr;
8148  yi[i__] = cinui * csclr;
8149 /* L40: */
8150  }
8151  return 0;
8152 L50:
8153  *nz = -1;
8154  if (nw == -2) {
8155  *nz = -2;
8156  }
8157  return 0;
8158 } /* zwrsk_ */
8159 
s_wsfe
integer s_wsfe(cilist *)
d_sign
double d_sign(const doublereal *, const doublereal *)
zdiv_
int zdiv_(doublereal *ar, doublereal *ai, doublereal *br, doublereal *bi, doublereal *cr, doublereal *ci)
Definition: zbesh.c:3778
c__15
static integer c__15
Definition: zbesh.c:17
zmlt_
int zmlt_(doublereal *ar, doublereal *ai, doublereal *br, doublereal *bi, doublereal *cr, doublereal *ci)
Definition: zbesh.c:4328
zlog_
int zlog_(doublereal *ar, doublereal *ai, doublereal *br, doublereal *bi, integer *ierr)
Definition: zbesh.c:3993
c_b147
static doublereal c_b147
Definition: zbesh.c:25
do_lio
integer do_lio(integer *, integer *, char *, ftnlen)
c__4
static integer c__4
Definition: zbesh.c:16
zrati_
int zrati_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *n, doublereal *cyr, doublereal *cyi, doublereal *tol)
Definition: zbesh.c:4346
log
TBCI__ cplx< T > log(const TBCI__ cplx< T > &z)
Definition: cplx.h:771
zasyi_
int zasyi_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *rl, doublereal *tol, doublereal *elim, doublereal *alim)
Definition: zbesh.c:2391
e_wsfe
integer e_wsfe()
cos
TBCI__ cplx< T > cos(const TBCI__ cplx< T > &z)
Definition: cplx.h:786
ac
const unsigned ac
Definition: matrix_kernels.h:30
zacai_
int zacai_(double *, double *, double *, const integer *, integer *, integer *, double *, double *, integer *, double *, double *, double *, double *)
zbknu_
int zbknu_(double *, double *, double *, const integer *, integer *, double *, double *, integer *, double *, double *, double *)
c__14
static integer c__14
Definition: zbesh.c:20
zbesh_
int zbesh_(double *zr, double *zi, double *fnu, int *kode, int *m, int *n, double *cyr, double *cyi, int *nz, int *ierr)
Definition: zbesh.c:132
s_wsle
integer s_wsle(cilist *)
c_b148
static doublereal c_b148
Definition: zbesh.c:26
zsqrt_
int zsqrt_(const double *, const double *, double *, double *)
Definition: zbesh.c:4891
zs1s2_
int zs1s2_(doublereal *zrr, doublereal *zri, doublereal *s1r, doublereal *s1i, doublereal *s2r, doublereal *s2i, integer *nz, doublereal *ascle, doublereal *alim, integer *iuf)
Definition: zbesh.c:4524
atan
TBCI__ cplx< T > atan(const TBCI__ cplx< T > &z)
Definition: cplx.h:826
zairy_
int zairy_(const doublereal *zr, const doublereal *zi, const integer *id, const integer *kode, doublereal *air, doublereal *aii, integer *nz, integer *ierr)
Definition: zairy.c:43
zunhj_
int zunhj_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *ipmtr, doublereal *tol, doublereal *phir, doublereal *phii, doublereal *argr, doublereal *argi, doublereal *zeta1r, doublereal *zeta1i, doublereal *zeta2r, doublereal *zeta2i, doublereal *asumr, doublereal *asumi, doublereal *bsumr, doublereal *bsumi)
Definition: zbesh.c:4999
zunk1_
int zunk1_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *tol, doublereal *elim, doublereal *alim)
Definition: zbesh.c:6529
zwrsk_
int zwrsk_(doublereal *zrr, doublereal *zri, doublereal *fnu, integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *cwr, doublereal *cwi, doublereal *tol, doublereal *elim, doublereal *alim)
Definition: zbesh.c:8035
max
T max(const FS_Vector< dims, T > &fv)
Definition: fs_vector.h:594
zunik_
int zunik_(doublereal *zrr, doublereal *zri, doublereal *fnu, integer *ikflg, integer *ipmtr, doublereal *tol, integer *init, doublereal *phir, doublereal *phii, doublereal *zeta1r, doublereal *zeta1i, doublereal *zeta2r, doublereal *zeta2i, doublereal *sumr, doublereal *sumi, doublereal *cwrkr, doublereal *cwrki)
Definition: zbesh.c:6318
c__0
static integer c__0
Definition: zbesh.c:27
csgnr
static doublereal csgnr
Definition: zbesh.c:51
arg
T arg(const TBCI__ cplx< T > &c)
Definition: cplx.h:690
myzabs_
doublereal myzabs_(const double *, const double *)
Definition: zbesh.c:1945
pi
const double pi
Definition: constants.h:38
std::sqrt
double sqrt(const int a)
Definition: basics.h:1216
zmlri_
int zmlri_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *tol)
Definition: zbesh.c:4064
imach
#define imach
ascle
static doublereal ascle
Definition: zbesh.c:51
cilist
Definition: f2c.h:72
c__16
static integer c__16
Definition: zbesh.c:18
sin
TBCI__ cplx< T > sin(const TBCI__ cplx< T > &z)
Definition: cplx.h:776
c__1
static integer c__1
Definition: zbesh.c:22
doublereal
double doublereal
Definition: f2c.h:32
e_wsle
integer e_wsle()
zacon_
int zacon_(double *, double *, double *, integer *, integer *, integer *, double *, double *, integer *, double *, double *, double *, double *, double *)
Definition: zbesh.c:2131
s_stop
int s_stop(const char *, ftnlen)
zseri_
int zseri_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *tol, doublereal *elim, doublereal *alim)
Definition: zbesh.c:4591
exp
TBCI__ cplx< T > exp(const TBCI__ cplx< T > &z)
Definition: cplx.h:756
cspnr
static doublereal cspnr
Definition: zbesh.c:51
integer
int integer
barf [ba:rf] 2.
Definition: f2c.h:27
c__5
static integer c__5
Definition: zbesh.c:19
zexp_
int zexp_(const double *, const double *, double *, double *)
Definition: zbesh.c:3799
zuoik_
int zuoik_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *ikflg, integer *n, doublereal *yr, doublereal *yi, integer *nuf, doublereal *tol, doublereal *elim, doublereal *alim)
Definition: zbesh.c:7759
output
#define output
zuni2_
int zuni2_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *nz, integer *nlast, doublereal *fnul, doublereal *tol, doublereal *elim, doublereal *alim)
Definition: zbesh.c:5969
zbinu_
int zbinu_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *n, doublereal *cyr, doublereal *cyi, integer *nz, doublereal *rl, doublereal *fnul, doublereal *tol, doublereal *elim, doublereal *alim)
Definition: zbesh.c:2621
c__9
static integer c__9
Definition: zbesh.c:21
dmach
#define dmach
c__25
static integer c__25
Definition: zbesh.c:24
zuni1_
int zuni1_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *nz, integer *nlast, doublereal *fnul, doublereal *tol, doublereal *elim, doublereal *alim)
Definition: zbesh.c:5691
real
#define real
Definition: own_lapack_routines.cpp:20
pow_dd
double pow_dd(const doublereal *, const doublereal *)
zkscl_
int zkscl_(doublereal *zrr, doublereal *zri, doublereal *fnu, integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *rzr, doublereal *rzi, doublereal *ascle, doublereal *tol, doublereal *elim)
Definition: zbesh.c:3821
dgamln_
doublereal dgamln_(doublereal *z__, integer *ierr)
Definition: zbesh.c:1019
csgni
static doublereal csgni
Definition: zbesh.c:51
abs
#define abs(x)
Definition: f2c.h:178
zuchk_
int zuchk_(doublereal *yr, doublereal *yi, integer *nz, doublereal *ascle, doublereal *tol)
Definition: zbesh.c:4965
cspni
static doublereal cspni
Definition: zbesh.c:51
zunk2_
int zunk2_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *tol, doublereal *elim, doublereal *alim)
Definition: zbesh.c:7100
real
float real
Definition: f2c.h:31
xerror_
int xerror_(char *mess, integer *nmess, integer *l1, integer *l2, ftnlen mess_len)
Definition: zbesh.c:1895
d1mach_
doublereal d1mach_(const integer *)
Definition: zbesh.c:576
zshch_
int zshch_(doublereal *zr, doublereal *zi, doublereal *cshr, doublereal *cshi, doublereal *cchr, doublereal *cchi)
Definition: zbesh.c:4864
cilist::ciunit
ftnint ciunit
Definition: f2c.h:74
zbunk_
int zbunk_(double *, double *, double *, integer *, integer *, integer *, double *, double *, integer *, double *, double *, double *)
Definition: zbesh.c:3736
sinh
TBCI__ cplx< T > sinh(const TBCI__ cplx< T > &z)
Definition: cplx.h:781
c__2
static integer c__2
Definition: zbesh.c:23
zbuni_
int zbuni_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *n, doublereal *yr, doublereal *yi, integer *nz, integer *nui, integer *nlast, doublereal *fnul, doublereal *tol, doublereal *elim, doublereal *alim)
Definition: zbesh.c:3512
v
const Vector< T > Vector< T > Vector< T > Vector< T > Vector< T > Vector< T > Vector< T > Vector< T > long int int char v
&lt; find minimun of func on grid with resolution res
Definition: LM_fit.h:205
min
#define min(a, b)
Definition: f2c.h:180
cosh
TBCI__ cplx< T > cosh(const TBCI__ cplx< T > &z)
Definition: cplx.h:791
ftnlen
long int ftnlen
Definition: f2c.h:67
i1mach_
integer i1mach_(const integer *)
Definition: zbesh.c:1206
Generated by   doxygen 1.8.5