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
16static integer c__4 = 4;
17static integer c__15 = 15;
18static integer c__16 = 16;
19static integer c__5 = 5;
20static integer c__14 = 14;
21static integer c__9 = 9;
22static integer c__1 = 1;
23static integer c__2 = 2;
24static integer c__25 = 25;
25static doublereal c_b147 = .5;
26static doublereal c_b148 = 0.;
27static integer c__0 = 0;
28
29int zuchk_(doublereal *yr, doublereal *yi, integer *nz, doublereal *ascle, doublereal *tol);
30int 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);
31int 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
33int zacon_(double*, double*, double*, integer*,
34 integer*, integer*, double*, double*,
35 integer*, double*, double*, double*,
36 double*, double*);
37int zbknu_(double*, double*, double*, integer*,
38 integer*, double*, double*,
39 integer*, double*, double*, double*);
40int zbunk_(double*, double*, double*, integer*,
41 integer*, integer*, double*, double*,
42 integer*, double*, double*, double*);
43int zuoik_(double*, double*, double*, integer*,
44 integer*, integer*, double*, double*,
45 integer*, double*, double*, double*);
46
47doublereal d1mach_(const integer*);
48integer i1mach_(const integer*);
49doublereal 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/*
127int zbesh_(zr, zi, fnu, kode, m, n, cyr, cyi, nz, ierr)
128doublereal *zr, *zi, *fnu;
129integer *kode, *m, *n;
130doublereal *cyr, *cyi;
131integer *nz, *ierr; */
132int 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;
432L60:
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 }
447L70:
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/* ----------------------------------------------------------------------- */
461L80:
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;
470L90:
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;
484L100:
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;
491L110:
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;
519L120:
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;
542L135:
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;
553L140:
554 if (znr < 0.) {
555 goto L230;
556 }
557 return 0;
558L230:
559 *nz = 0;
560 *ierr = 2;
561 return 0;
562L240:
563 if (nw == -1) {
564 goto L230;
565 }
566 *nz = 0;
567 *ierr = 5;
568 return 0;
569L260:
570 *nz = 0;
571 *ierr = 4;
572 return 0;
573} /* zbesh_ */
574
575/* DECK D1MACH */
576doublereal 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
1019doublereal 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;
1144L10:
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;
1162L20:
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 }
1180L40:
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;
1187L50:
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
1200L70:
1201 *ierr = 1;
1202 return ret_val;
1203} /* dgamln_ */
1204
1205/* DECK I1MACH */
1206integer 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\
1218S\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
1878L10:
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 */
1895int 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
1945doublereal 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;
1980L10:
1981 q = v / u;
1982 ret_val = u * sqrt(q * q + 1.);
1983 return ret_val;
1984L20:
1985 ret_val = 0.;
1986 return ret_val;
1987} /* myzabs_ */
1988
1989/* Subroutine */
1990int 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 }
2048L10:
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;
2054L20:
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;
2067L30:
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 }
2075L40:
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);
2093L50:
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;
2107L60:
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;
2119L70:
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;
2123L80:
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);
2208L10:
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;
2224L20:
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;
2238L30:
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;
2261L40:
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;
2301L50:
2302 if (as2 < bry[1]) {
2303 goto L60;
2304 }
2305 kflag = 3;
2306L60:
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;
2349L70:
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];
2378L80:
2379 ;
2380 }
2381 return 0;
2382L90:
2383 *nz = -1;
2384 if (nw == -2) {
2385 *nz = -2;
2386 }
2387 return 0;
2388} /* zacon_ */
2389
2390/* Subroutine */
2391int 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;
2468L10:
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);
2480L20:
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;
2519L30:
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;
2558L50:
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;
2573L60:
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;
2613L100:
2614 *nz = -1;
2615 return 0;
2616L110:
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 }
2662L10:
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));
2677L20:
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/* ----------------------------------------------------------------------- */
2690L30:
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;
2697L40:
2698 if (dfnu <= 1.) {
2699 goto L70;
2700 }
2701L50:
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 }
2722L60:
2723 if (az > *rl) {
2724 goto L80;
2725 }
2726L70:
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;
2735L80:
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;
2754L100:
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;
2764L110:
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;
2781L120:
2782 return 0;
2783L130:
2784 *nz = -1;
2785 if (nw == -2) {
2786 *nz = -2;
2787 }
2788 return 0;
2789} /* zbinu_ */
2790
2791/* Subroutine */
2792int 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;
2916L10:
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 }
2940L30:
2941 g1 = -s;
2942 goto L50;
2943L40:
2944 g1 = (t1 - t2) / (dnu + dnu);
2945L50:
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;
2977L60:
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 }
2998L70:
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/* ----------------------------------------------------------------------- */
3010L80:
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;
3018L90:
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 }
3043L100:
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/* ----------------------------------------------------------------------- */
3069L110:
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);
3084L120:
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;
3116L130:
3117 t1 = atan(*zi / *zr);
3118 t1 = abs(t1);
3119L140:
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;
3153L160:
3154 fk += spi * t1 * sqrt(t2 / caz);
3155 fhs = (d__1 = .25 - dnu2, abs(d__1));
3156 goto L180;
3157L170:
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;
3167L180:
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;
3220L200:
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/* ----------------------------------------------------------------------- */
3240L210:
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;
3255L215:
3256 zdr = *zr;
3257 zdi = *zi;
3258 if (iflag == 1) {
3259 goto L270;
3260 }
3261 goto L240;
3262L220:
3263 inub = 1;
3264 if (iflag == 1) {
3265 goto L261;
3266 }
3267L225:
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];
3303L230:
3304 ;
3305 }
3306 if (*n != 1) {
3307 goto L240;
3308 }
3309 s1r = s2r;
3310 s1i = s2i;
3311L240:
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;
3324L250:
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];
3366L260:
3367 ;
3368 }
3369 return 0;
3370/* ----------------------------------------------------------------------- */
3371/* IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW */
3372/* ----------------------------------------------------------------------- */
3373L261:
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;
3416L263:
3417 if (alas < helim) {
3418 goto L262;
3419 }
3420 zdr -= *elim;
3421 s1r *= celmr;
3422 s1i *= celmr;
3423 s2r *= celmr;
3424 s2i *= celmr;
3425L262:
3426 ;
3427 }
3428 if (*n != 1) {
3429 goto L270;
3430 }
3431 s1r = s2r;
3432 s1i = s2i;
3433 goto L270;
3434L264:
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;
3451L270:
3452 yr[1] = s1r;
3453 yi[1] = s1i;
3454 if (*n == 1) {
3455 goto L280;
3456 }
3457 yr[2] = s2r;
3458 yi[2] = s2i;
3459L280:
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;
3488L290:
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/* ----------------------------------------------------------------------- */
3499L300:
3500 s1r = coefr;
3501 s1i = coefi;
3502 s2r = coefr;
3503 s2i = coefi;
3504 goto L210;
3505
3506
3507L310:
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;
3568L10:
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);
3576L20:
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;
3600L21:
3601 if (str < bry[1]) {
3602 goto L25;
3603 }
3604 iflag = 3;
3605 ascle = bry[2];
3606 csclr = *tol;
3607L25:
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;
3650L30:
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;
3696L40:
3697 ;
3698 }
3699 return 0;
3700L50:
3701 *nz = -1;
3702 if (nw == -2) {
3703 *nz = -2;
3704 }
3705 return 0;
3706L60:
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;
3717L70:
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);
3725L80:
3726 if (nw < 0) {
3727 goto L50;
3728 }
3729 *nz = nw;
3730 return 0;
3731L90:
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;
3767L10:
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);
3774L20:
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);
3891L10:
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;
3903L20:
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;
3964L25:
3965 if (alas < helim) {
3966 goto L30;
3967 }
3968 zdr -= *elim;
3969 s1r *= celmr;
3970 s1i *= celmr;
3971 s2r *= celmr;
3972 s2i *= celmr;
3973L30:
3974 ;
3975 }
3976 *nz = *n;
3977 if (ic == *n) {
3978 *nz = *n - 1;
3979 }
3980 goto L45;
3981L40:
3982 *nz = kk - 2;
3983L45:
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;
4028L10:
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;
4038L20:
4039 if (*ar > 0.) {
4040 goto L30;
4041 }
4042 *br = log((abs(*ar)));
4043 *bi = dpi;
4044 return 0;
4045L30:
4046 *br = log(*ar);
4047 *bi = 0.;
4048 return 0;
4049L40:
4050 if (*ar < 0.) {
4051 dtheta += dpi;
4052 }
4053L50:
4054 zm = myzabs_(ar, ai);
4055 *br = log(zm);
4056 *bi = dtheta;
4057 return 0;
4058L60:
4059 *ierr = 1;
4060 return 0;
4061} /* zlog_ */
4062
4063/* Subroutine */
4064int 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;
4154L20:
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;
4197L30:
4198 ;
4199 }
4200 goto L110;
4201L40:
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 }
4268L70:
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 }
4288L90:
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;
4323L110:
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;
4436L10:
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;
4462L20:
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;
4491L40:
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;
4513L50:
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);
4576L10:
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 */
4591int 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);
4667L10:
4668 acz = myzabs_(&czr, &czi);
4669 nn = *n;
4670 zlog_(&hzr, &hzi, &ckr, &cki, &idum);
4671L20:
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 }
4687L30:
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;
4699L40:
4700 if (ak1r > -(*alim)) {
4701 goto L50;
4702 }
4703 iflag = 1;
4704 ss = 1. / *tol;
4705 crscr = *tol;
4706 ascle = arm * ss;
4707L50:
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.;
4730L60:
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 }
4744L70:
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 }
4756L80:
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;
4766L90:
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;
4783L100:
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/* ----------------------------------------------------------------------- */
4796L120:
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;
4825L140:
4826 ib = l + 1;
4827 if (ib > nn) {
4828 return 0;
4829 }
4830 goto L100;
4831L150:
4832 *nz = *n;
4833 if (*fnu == 0.) {
4834 --(*nz);
4835 }
4836L160:
4837 yr[1] = zeror;
4838 yi[1] = zeroi;
4839 if (*fnu != 0.) {
4840 goto L170;
4841 }
4842 yr[1] = coner;
4843 yi[1] = conei;
4844L170:
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/* ----------------------------------------------------------------------- */
4859L190:
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;
4925L10:
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;
4935L20:
4936 if (*ar > 0.) {
4937 goto L30;
4938 }
4939 *br = 0.;
4940 *bi = sqrt((abs(*ar)));
4941 return 0;
4942L30:
4943 *br = sqrt(*ar);
4944 *bi = 0.;
4945 return 0;
4946L40:
4947 if (*ar < 0.) {
4948 dtheta += dpi;
4949 }
4950L50:
4951 dtheta *= .5;
4952 *br = zm * cos(dtheta);
4953 *bi = zm * sin(dtheta);
4954 return 0;
4955L60:
4956 *br = zm * drt;
4957 *bi = zm * drt;
4958 return 0;
4959L70:
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;
5346L15:
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;
5386L20:
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 }
5451L50:
5452 *asumr += sumar * pp;
5453 *asumi += sumai * pp;
5454 if (pp < *tol) {
5455 ias = 1;
5456 }
5457L60:
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 }
5473L80:
5474 *bsumr += sumbr * pp;
5475 *bsumi += sumbi * pp;
5476 if (pp < btol) {
5477 ibs = 1;
5478 }
5479L90:
5480 if (ias == 1 && ibs == 1) {
5481 goto L110;
5482 }
5483 l1 += 30;
5484 l2 += 30;
5485/* L100: */
5486 }
5487L110:
5488 *asumr += coner;
5489 pp = rfnu * rfn13;
5490 *bsumr *= pp;
5491 *bsumi *= pp;
5492L120:
5493 return 0;
5494/* ----------------------------------------------------------------------- */
5495/* CABS(W2).GT.0.25D0 */
5496/* ----------------------------------------------------------------------- */
5497L130:
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 }
5537L140:
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 }
5655L180:
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 }
5677L200:
5678 if (ias == 1 && ibs == 1) {
5679 goto L220;
5680 }
5681/* L210: */
5682 }
5683L220:
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;
5777L10:
5778 s1r = -zeta1r + zeta2r;
5779 s1i = -zeta1i + zeta2i;
5780L20:
5781 rs1 = s1r;
5782 if (abs(rs1) > *elim) {
5783 goto L130;
5784 }
5785L30:
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;
5804L40:
5805 s1r = -zeta1r + zeta2r;
5806 s1i = -zeta1i + zeta2i;
5807L50:
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 }
5838L60:
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 }
5857L70:
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];
5917L90:
5918 ;
5919 }
5920L100:
5921 return 0;
5922/* ----------------------------------------------------------------------- */
5923/* SET UNDERFLOW AND UPDATE PARAMETERS */
5924/* ----------------------------------------------------------------------- */
5925L110:
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;
5952L120:
5953 *nz = -1;
5954 return 0;
5955L130:
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;
6072L10:
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;
6090L20:
6091 s1r = -zeta1r + zeta2r;
6092 s1i = -zeta1i + zeta2i;
6093L30:
6094 rs1 = s1r;
6095 if (abs(rs1) > *elim) {
6096 goto L150;
6097 }
6098L40:
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;
6117L50:
6118 s1r = -zeta1r + zeta2r;
6119 s1i = -zeta1i + zeta2i;
6120L60:
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 }
6153L70:
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 }
6179L80:
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];
6248L100:
6249 ;
6250 }
6251L110:
6252 return 0;
6253L120:
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;
6298L130:
6299 *nlast = nd;
6300 return 0;
6301L140:
6302 *nz = -1;
6303 return 0;
6304L150:
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;
6432L15:
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;
6486L30:
6487 *init = k;
6488L40:
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;
6508L60:
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);
6614L10:
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;
6639L20:
6640 s1r = zeta1r[j - 1] - zeta2r[j - 1];
6641 s1i = zeta1i[j - 1] - zeta2i[j - 1];
6642L30:
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 }
6673L40:
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 }
6693L50:
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;
6703L60:
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);
6726L70:
6727 ;
6728 }
6729 i__ = *n;
6730L75:
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;
6766L80:
6767 s1r = zet1dr - zet2dr;
6768 s1i = zet1di - zet2di;
6769L90:
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 }
6785L95:
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/* ---------------------------------------------------------------------------- */
6806L100:
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];
6847L120:
6848 ;
6849 }
6850L160:
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;
6875L170:
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 }
6893L172:
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;
6906L175:
6907 if (kk == *n && ib < *n) {
6908 goto L180;
6909 }
6910 if (kk == ib || kk == ic) {
6911 goto L172;
6912 }
6913 initd = 0;
6914L180:
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;
6929L200:
6930 s1r = -zet1dr + zet2dr;
6931 s1i = -zet1di + zet2di;
6932L210:
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 }
6963L220:
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;
6983L230:
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;
7000L250:
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;
7011L255:
7012 if (kdflg == 2) {
7013 goto L275;
7014 }
7015 kdflg = 2;
7016 goto L270;
7017L260:
7018 if (rs1 > 0.) {
7019 goto L300;
7020 }
7021 s2r = zeror;
7022 s2i = zeroi;
7023 goto L230;
7024L270:
7025 ;
7026 }
7027 k = *n;
7028L275:
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;
7065L280:
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];
7091L290:
7092 ;
7093 }
7094 return 0;
7095L300:
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);
7200L10:
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;
7223L20:
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;
7252L30:
7253 s1r = zeta1r[j - 1] - zeta2r[j - 1];
7254 s1i = zeta1i[j - 1] - zeta2i[j - 1];
7255L40:
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 }
7287L50:
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 }
7319L60:
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;
7335L70:
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);
7361L80:
7362 ;
7363 }
7364 i__ = *n;
7365L85:
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;
7400L90:
7401 s1r = zet1dr - zet2dr;
7402 s1i = zet1di - zet2di;
7403L100:
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 }
7419L105:
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;
7437L120:
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];
7478L130:
7479 ;
7480 }
7481L180:
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;
7507L190:
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 }
7538L172:
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;
7553L175:
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);
7563L210:
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;
7575L220:
7576 s1r = -zet1dr + zet2dr;
7577 s1i = -zet1di + zet2di;
7578L230:
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 }
7610L240:
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;
7636L250:
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;
7656L270:
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;
7670L255:
7671 if (kdflg == 2) {
7672 goto L295;
7673 }
7674 kdflg = 2;
7675 goto L290;
7676L280:
7677 if (rs1 > 0.) {
7678 goto L320;
7679 }
7680 s2r = zeror;
7681 s2i = zeroi;
7682 goto L250;
7683L290:
7684 ;
7685 }
7686 k = *n;
7687L295:
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;
7724L300:
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];
7750L310:
7751 ;
7752 }
7753 return 0;
7754L320:
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);
7829L10:
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);
7845L20:
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;
7860L30:
7861 znr = zri;
7862 zni = -zrr;
7863 if (*zi > 0.) {
7864 goto L40;
7865 }
7866 znr = -znr;
7867L40:
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);
7873L50:
7874 if (*kode == 1) {
7875 goto L60;
7876 }
7877 czr -= zbr;
7878 czi -= zbi;
7879L60:
7880 if (*ikflg == 1) {
7881 goto L70;
7882 }
7883 czr = -czr;
7884 czi = -czi;
7885L70:
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;
7905L80:
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 }
7922L90:
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;
7931L110:
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;
7942L120:
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 }
7951L130:
7952 if (*ikflg == 2) {
7953 return 0;
7954 }
7955 if (*n == 1) {
7956 return 0;
7957 }
7958/* ----------------------------------------------------------------------- */
7959/* SET UNDERFLOWS ON I SEQUENCE */
7960/* ----------------------------------------------------------------------- */
7961L140:
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;
7972L150:
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);
7978L160:
7979 if (*kode == 1) {
7980 goto L170;
7981 }
7982 czr -= zbr;
7983 czi -= zbi;
7984L170:
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 }
8000L180:
8001 yr[nn] = zeror;
8002 yi[nn] = zeroi;
8003 --nn;
8004 ++(*nuf);
8005 if (nn == 0) {
8006 return 0;
8007 }
8008 goto L140;
8009L190:
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;
8020L200:
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;
8030L210:
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);
8089L10:
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;
8104L20:
8105 ascle = 1. / ascle;
8106 if (acw < ascle) {
8107 goto L30;
8108 }
8109 csclr = *tol;
8110L30:
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;
8152L50:
8153 *nz = -1;
8154 if (nw == -2) {
8155 *nz = -2;
8156 }
8157 return 0;
8158} /* zwrsk_ */
8159
c__2
static integer c__2
Definition TOMS404.C:24
pi
const double pi
Definition constants.h:38
sinh
TBCI__ cplx< T > sinh(const TBCI__ cplx< T > &z)
Definition cplx.h:781
arg
T arg(const TBCI__ cplx< T > &c)
Definition cplx.h:690
atan
TBCI__ cplx< T > atan(const TBCI__ cplx< T > &z)
Definition cplx.h:826
exp
TBCI__ cplx< T > exp(const TBCI__ cplx< T > &z)
Definition cplx.h:756
log
TBCI__ cplx< T > log(const TBCI__ cplx< T > &z)
Definition cplx.h:771
sin
TBCI__ cplx< T > sin(const TBCI__ cplx< T > &z)
Definition cplx.h:776
cosh
TBCI__ cplx< T > cosh(const TBCI__ cplx< T > &z)
Definition cplx.h:791
sqrt
NAMESPACE_END NAMESPACE_CSTD TBCI__ cplx< T > sqrt(const TBCI__ cplx< T > &z)
Definition cplx.h:751
cos
TBCI__ cplx< T > cos(const TBCI__ cplx< T > &z)
Definition cplx.h:786
ftnlen
long int ftnlen
Definition f2c.h:67
abs
#define abs(x)
Definition f2c.h:178
min
#define min(a, b)
Definition f2c.h:180
max
#define max(a, b)
Definition f2c.h:181
ac
const unsigned ac
Definition matrix_kernels.h:30
doublereal
#define doublereal
Definition own_lapack_routines.cpp:18
c__1
static long int c__1
Definition own_lapack_routines.cpp:27
integer
#define integer
Definition own_lapack_routines.cpp:17
real
#define real
Definition own_lapack_routines.cpp:20
c__9
static long int c__9
Definition own_lapack_routines.cpp:26
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
s_stop
int s_stop(const char *, ftnlen)
s_wsfe
integer s_wsfe(cilist *)
d_sign
double d_sign(const doublereal *, const doublereal *)
pow_dd
double pow_dd(const doublereal *, const doublereal *)
e_wsle
integer e_wsle()
do_lio
integer do_lio(integer *, integer *, char *, ftnlen)
e_wsfe
integer e_wsfe()
s_wsle
integer s_wsle(cilist *)
cilist
Definition f2c.h:73
cilist::ciunit
ftnint ciunit
Definition f2c.h:74
c__15
static integer c__15
Definition zairy.c:17
c__14
static integer c__14
Definition zairy.c:20
c__4
static integer c__4
Definition zairy.c:16
c__16
static integer c__16
Definition zairy.c:18
c__5
static integer c__5
Definition zairy.c:19
zbesh_
int zbesh_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *m, integer *n, doublereal *cyr, doublereal *cyi, integer *nz, integer *ierr)
Definition zbesh.c:132
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
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
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
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
csgni
static doublereal csgni
Definition zbesh.c:51
zexp_
int zexp_(const doublereal *ar, const doublereal *ai, doublereal *br, doublereal *bi)
Definition zbesh.c:3799
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
cspnr
static doublereal cspnr
Definition zbesh.c:51
zmlt_
int zmlt_(doublereal *ar, doublereal *ai, doublereal *br, doublereal *bi, doublereal *cr, doublereal *ci)
Definition zbesh.c:4328
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
c_b147
static doublereal c_b147
Definition zbesh.c:25
c_b148
static doublereal c_b148
Definition zbesh.c:26
zsqrt_
int zsqrt_(const doublereal *ar, const doublereal *ai, doublereal *br, doublereal *bi)
Definition zbesh.c:4891
c__25
static integer c__25
Definition zbesh.c:24
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
zdiv_
int zdiv_(doublereal *ar, doublereal *ai, doublereal *br, doublereal *bi, doublereal *cr, doublereal *ci)
Definition zbesh.c:3778
c__0
static integer c__0
Definition zbesh.c:27
zshch_
int zshch_(doublereal *zr, doublereal *zi, doublereal *cshr, doublereal *cshi, doublereal *cchr, doublereal *cchi)
Definition zbesh.c:4864
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
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
csgnr
static doublereal csgnr
Definition zbesh.c:51
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
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
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
zbknu_
int zbknu_(double *, double *, double *, integer *, integer *, double *, double *, integer *, double *, double *, double *)
Definition zbesh.c:2792
myzabs_
doublereal myzabs_(const doublereal *, const doublereal *)
Definition zbesh.c:1945
zacai_
int zacai_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *kode, integer *mr, integer *n, doublereal *yr, doublereal *yi, integer *nz, doublereal *rl, doublereal *tol, doublereal *elim, doublereal *alim)
Definition zbesh.c:1990
zrati_
int zrati_(doublereal *zr, doublereal *zi, doublereal *fnu, integer *n, doublereal *cyr, doublereal *cyi, doublereal *tol)
Definition zbesh.c:4346
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
zbunk_
int zbunk_(double *, double *, double *, integer *, integer *, integer *, double *, double *, integer *, double *, double *, double *)
Definition zbesh.c:3736
dmach
#define dmach
cspni
static doublereal cspni
Definition zbesh.c:51
imach
#define imach
zlog_
int zlog_(doublereal *ar, doublereal *ai, doublereal *br, doublereal *bi, integer *ierr)
Definition zbesh.c:3993
zuchk_
int zuchk_(doublereal *yr, doublereal *yi, integer *nz, doublereal *ascle, doublereal *tol)
Definition zbesh.c:4965
i1mach_
integer i1mach_(const integer *)
Definition zbesh.c:1206
zacon_
int zacon_(double *, double *, double *, integer *, integer *, integer *, double *, double *, integer *, double *, double *, double *, double *, double *)
Definition zbesh.c:2131
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
output
#define output
ascle
static doublereal ascle
Definition zbesh.c:51
xerror_
int xerror_(char *mess, integer *nmess, integer *l1, integer *l2, ftnlen mess_len)
Definition zbesh.c:1895
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
d1mach_
doublereal d1mach_(const integer *)
Definition zbesh.c:576
dgamln_
doublereal dgamln_(doublereal *z__, integer *ierr)
Definition zbesh.c:1019
Generated by doxygen 1.16.1