Line data Source code
1 : !!****m* ABINIT/m_bessel2
2 : !! NAME
3 : !! m_bessel2
4 : !!
5 : !! FUNCTION
6 : !! Computes modified Bessel functions of the first and second kind.
7 : !! These routines were taken from https://www.netlib.org/slatec/.
8 : !!
9 : !! COPYRIGHT
10 : !! Copyright (C) 2024-2026 ABINIT group
11 : !! This file is distributed under the terms of the
12 : !! GNU General Public License, see ~abinit/COPYING
13 : !! or http://www.gnu.org/copyleft/gpl.txt .
14 : !!
15 : !! SOURCE
16 :
17 : #if defined HAVE_CONFIG_H
18 : #include "config.h"
19 : #endif
20 :
21 : #include "abi_common.h"
22 :
23 : MODULE m_bessel2
24 :
25 : use defs_basis
26 : use m_errors
27 :
28 : implicit none
29 :
30 : private
31 :
32 : public :: bessel_iv
33 : public :: bessel_kv
34 :
35 : CONTAINS !========================================================================================
36 : !!***
37 :
38 : !!****f* m_bessel2/bessel_iv
39 : !! NAME
40 : !! bessel_iv
41 : !!
42 : !! FUNCTION
43 : !!
44 : !! Compute modified Bessel function of the first kind for any real order
45 : !!
46 : !! INPUTS
47 : !! k= order
48 : !! xr= real part of the value at which to compute the Bessel function
49 : !! xi= real part of the value at which to compute the Bessel function
50 : !!
51 : !! OUTPUT
52 : !! ivr,ivi= real part and imaginary part of the value of the Bessel function
53 : !!
54 : !! SOURCE
55 :
56 0 : subroutine bessel_iv(k,xr,xi,ivr,ivi)
57 :
58 : !Arguments ------------------------------------
59 : real(dp), intent(in) :: k,xr,xi
60 : real(dp), intent(out) :: ivr,ivi
61 : !Local variables ------------------------------
62 : integer :: ierr,nz
63 : real(dp) :: s
64 : real(dp) :: cyi(1),cyik(1),cyr(1),cyrk(1)
65 : !************************************************************************
66 :
67 0 : call zbesi(xr,xi,abs(k),1,1,cyr,cyi,nz,ierr)
68 0 : if (k >= zero) then
69 0 : ivr = cyr(1)
70 0 : ivi = cyi(1)
71 : else
72 0 : s = sin(abs(k)*pi) * two / pi
73 0 : call zbesk(xr,xi,abs(k),1,1,cyrk,cyik,nz,ierr)
74 0 : ivr = cyr(1) + s*cyrk(1)
75 0 : ivi = cyi(1) + s*cyik(1)
76 : end if
77 :
78 0 : end subroutine bessel_iv
79 : !!***
80 :
81 : !----------------------------------------------------------------------
82 :
83 : !!****f* m_bessel2/bessel_kv
84 : !! NAME
85 : !! bessel_iv
86 : !!
87 : !! FUNCTION
88 : !!
89 : !! Compute modified Bessel function of the second kind for any real order
90 : !!
91 : !! INPUTS
92 : !! k= order
93 : !! xr= real part of the value at which to compute the Bessel function
94 : !! xi= real part of the value at which to compute the Bessel function
95 : !!
96 : !! OUTPUT
97 : !! kvr,kvi= real part and imaginary part of the value of the Bessel function
98 : !!
99 : !! SOURCE
100 :
101 0 : subroutine bessel_kv(k,xr,xi,kvr,kvi)
102 :
103 : !Arguments ------------------------------------
104 : real(dp), intent(in) :: k,xi,xr
105 : real(dp), intent(out) :: kvi,kvr
106 : !Local variables ------------------------------
107 : integer :: ierr,nz
108 : real(dp) :: cyi(1),cyr(1)
109 : !************************************************************************
110 :
111 0 : call zbesk(xr,xi,abs(k),1,1,cyr,cyi,nz,ierr)
112 :
113 0 : if (xi == zero) then
114 0 : kvr = cyr(1)
115 0 : kvi = zero
116 : else
117 0 : kvr = cyr(1)
118 0 : kvi = cyi(1)
119 : end if
120 :
121 0 : end subroutine bessel_kv
122 : !!***
123 :
124 : !----------------------------------------------------------------------
125 :
126 0 : SUBROUTINE ZBESI(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR)
127 : !C***BEGIN PROLOGUE ZBESI
128 : !C***DATE WRITTEN 830501 (YYMMDD)
129 : !C***REVISION DATE 890801 (YYMMDD)
130 : !C***CATEGORY NO. B5K
131 : !C***KEYWORDS I-BESSEL FUNCTION,COMPLEX BESSEL FUNCTION,
132 : !C MODIFIED BESSEL FUNCTION OF THE FIRST KIND
133 : !C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
134 : !C***PURPOSE TO COMPUTE I-BESSEL FUNCTIONS OF COMPLEX ARGUMENT
135 : !C***DESCRIPTION
136 : !C
137 : !C ***A DOUBLE PRECISION ROUTINE***
138 : !C ON KODE=1, ZBESI COMPUTES AN N MEMBER SEQUENCE OF COMPLEX
139 : !C BESSEL FUNCTIONS CY(J)=I(FNU+J-1,Z) FOR REAL, NONNEGATIVE
140 : !C ORDERS FNU+J-1, J=1,...,N AND COMPLEX Z IN THE CUT PLANE
141 : !C -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESI RETURNS THE SCALED
142 : !C FUNCTIONS
143 : !C
144 : !C CY(J)=EXP(-ABS(X))*I(FNU+J-1,Z) J = 1,...,N , X=REAL(Z)
145 : !C
146 : !C WITH THE EXPONENTIAL GROWTH REMOVED IN BOTH THE LEFT AND
147 : !C RIGHT HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION
148 : !C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS
149 : !C (REF. 1).
150 : !C
151 : !C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION
152 : !C ZR,ZI - Z=CMPLX(ZR,ZI), -PI.LT.ARG(Z).LE.PI
153 : !C FNU - ORDER OF INITIAL I FUNCTION, FNU.GE.0.0D0
154 : !C KODE - A PARAMETER TO INDICATE THE SCALING OPTION
155 : !C KODE= 1 RETURNS
156 : !C CY(J)=I(FNU+J-1,Z), J=1,...,N
157 : !C = 2 RETURNS
158 : !C CY(J)=I(FNU+J-1,Z)*EXP(-ABS(X)), J=1,...,N
159 : !C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1
160 : !C
161 : !C OUTPUT CYR,CYI ARE DOUBLE PRECISION
162 : !C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS
163 : !C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE
164 : !C CY(J)=I(FNU+J-1,Z) OR
165 : !C CY(J)=I(FNU+J-1,Z)*EXP(-ABS(X)) J=1,...,N
166 : !C DEPENDING ON KODE, X=REAL(Z)
167 : !C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW,
168 : !C NZ= 0 , NORMAL RETURN
169 : !C NZ.GT.0 , LAST NZ COMPONENTS OF CY SET TO ZERO
170 : !C TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0)
171 : !C J = N-NZ+1,...,N
172 : !C IERR - ERROR FLAG
173 : !C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
174 : !C IERR=1, INPUT ERROR - NO COMPUTATION
175 : !C IERR=2, OVERFLOW - NO COMPUTATION, REAL(Z) TOO
176 : !C LARGE ON KODE=1
177 : !C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
178 : !C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
179 : !C REDUCTION PRODUCE LESS THAN HALF OF MACHINE
180 : !C ACCURACY
181 : !C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
182 : !C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
183 : !C CANCE BY ARGUMENT REDUCTION
184 : !C IERR=5, ERROR - NO COMPUTATION,
185 : !C ALGORITHM TERMINATION CONDITION NOT MET
186 : !C
187 : !C***LONG DESCRIPTION
188 : !C
189 : !C THE COMPUTATION IS CARRIED OUT BY THE POWER SERIES FOR
190 : !C SMALL CABS(Z), THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z),
191 : !C THE MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN AND A
192 : !C NEUMANN SERIES FOR IMTERMEDIATE MAGNITUDES, AND THE
193 : !C UNIFORM ASYMPTOTIC EXPANSIONS FOR I(FNU,Z) AND J(FNU,Z)
194 : !C FOR LARGE ORDERS. BACKWARD RECURRENCE IS USED TO GENERATE
195 : !C SEQUENCES OR REDUCE ORDERS WHEN NECESSARY.
196 : !C
197 : !C THE CALCULATIONS ABOVE ARE DONE IN THE RIGHT HALF PLANE AND
198 : !C CONTINUED INTO THE LEFT HALF PLANE BY THE FORMULA
199 : !C
200 : !C I(FNU,Z*EXP(M*PI)) = EXP(M*PI*FNU)*I(FNU,Z) REAL(Z).GT.0.0
201 : !C M = +I OR -I, I**2=-1
202 : !C
203 : !C FOR NEGATIVE ORDERS,THE FORMULA
204 : !C
205 : !C I(-FNU,Z) = I(FNU,Z) + (2/PI)*SIN(PI*FNU)*K(FNU,Z)
206 : !C
207 : !C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO INTEGERS, THE
208 : !C THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE POSITIVE
209 : !C INTEGER,THE MAGNITUDE OF I(-FNU,Z)=I(FNU,Z) IS A LARGE
210 : !C NEGATIVE POWER OF TEN. BUT WHEN FNU IS NOT AN INTEGER,
211 : !C K(FNU,Z) DOMINATES IN MAGNITUDE WITH A LARGE POSITIVE POWER OF
212 : !C TEN AND THE MOST THAT THE SECOND TERM CAN BE REDUCED IS BY
213 : !C UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, WIDE CHANGES CAN
214 : !C OCCUR WITHIN UNIT ROUNDOFF OF A LARGE INTEGER FOR FNU. HERE,
215 : !C LARGE MEANS FNU.GT.CABS(Z).
216 : !C
217 : !C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
218 : !C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS
219 : !C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.
220 : !C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN
221 : !C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG
222 : !C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
223 : !C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
224 : !C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS
225 : !C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS
226 : !C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE
227 : !C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS
228 : !C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
229 : !C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
230 : !C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
231 : !C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
232 : !C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
233 : !C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
234 : !C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
235 : !C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
236 : !C
237 : !C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
238 : !C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
239 : !C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
240 : !C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
241 : !C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
242 : !C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
243 : !C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
244 : !C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
245 : !C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
246 : !C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
247 : !C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
248 : !C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
249 : !C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
250 : !C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
251 : !C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
252 : !C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
253 : !C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
254 : !C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
255 : !C OR -PI/2+P.
256 : !C
257 : !C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
258 : !C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
259 : !C COMMERCE, 1955.
260 : !C
261 : !C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
262 : !C BY D. E. AMOS, SAND83-0083, MAY, 1983.
263 : !C
264 : !C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
265 : !C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
266 : !C
267 : !C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
268 : !C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
269 : !C 1018, MAY, 1985
270 : !C
271 : !C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
272 : !C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
273 : !C MATH. SOFTWARE, 1986
274 : !C
275 : !C***ROUTINES CALLED ZBINU,I1MACH,D1MACH
276 : !C***END PROLOGUE ZBESI
277 : !C COMPLEX CONE,CSGN,CW,CY,CZERO,Z,ZN
278 : DOUBLE PRECISION AA, ALIM, ARG, CONEI, CONER, CSGNI, CSGNR, CYI, &
279 : & CYR, DIG, ELIM, FNU, FNUL, PI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR, &
280 : & ZR, AZ, BB, FN, ASCLE, RTOL, ATOL, STI
281 : INTEGER I, IERR, INU, K, KODE, K1,K2,N,NZ,NN
282 : DIMENSION CYR(N), CYI(N)
283 : DATA PI /3.14159265358979324D0/
284 : DATA CONER, CONEI /1.0D0,0.0D0/
285 : !C
286 : !C***FIRST EXECUTABLE STATEMENT ZBESI
287 0 : IERR = 0
288 0 : NZ=0
289 0 : IF (FNU.LT.0.0D0) IERR=1
290 0 : IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
291 0 : IF (N.LT.1) IERR=1
292 0 : IF (IERR.NE.0) RETURN
293 : !C-----------------------------------------------------------------------
294 : !C SET PARAMETERS RELATED TO MACHINE CONSTANTS.
295 : !C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
296 : !C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
297 : !C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND
298 : !C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR
299 : !C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
300 : !C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
301 : !C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
302 : !C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU.
303 : !C-----------------------------------------------------------------------
304 0 : TOL = DMAX1(D1MACH(4),1.0D-18)
305 0 : K1 = I1MACH(15)
306 0 : K2 = I1MACH(16)
307 0 : R1M5 = D1MACH(5)
308 0 : K = MIN0(IABS(K1),IABS(K2))
309 0 : ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
310 0 : K1 = I1MACH(14) - 1
311 0 : AA = R1M5*DBLE(FLOAT(K1))
312 0 : DIG = DMIN1(AA,18.0D0)
313 0 : AA = AA*2.303D0
314 0 : ALIM = ELIM + DMAX1(-AA,-41.45D0)
315 0 : RL = 1.2D0*DIG + 3.0D0
316 0 : FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
317 : !C-----------------------------------------------------------------------------
318 : !C TEST FOR PROPER RANGE
319 : !C-----------------------------------------------------------------------
320 0 : AZ = AZABS(ZR,ZI)
321 0 : FN = FNU+DBLE(FLOAT(N-1))
322 0 : AA = 0.5D0/TOL
323 0 : BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
324 0 : AA = DMIN1(AA,BB)
325 0 : IF (AZ.GT.AA) GO TO 260
326 0 : IF (FN.GT.AA) GO TO 260
327 0 : AA = DSQRT(AA)
328 0 : IF (AZ.GT.AA) IERR=3
329 0 : IF (FN.GT.AA) IERR=3
330 0 : ZNR = ZR
331 0 : ZNI = ZI
332 0 : CSGNR = CONER
333 0 : CSGNI = CONEI
334 0 : IF (ZR.GE.0.0D0) GO TO 40
335 0 : ZNR = -ZR
336 0 : ZNI = -ZI
337 : !C-----------------------------------------------------------------------
338 : !C CALCULATE CSGN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
339 : !C WHEN FNU IS LARGE
340 : !C-----------------------------------------------------------------------
341 0 : INU = INT(SNGL(FNU))
342 0 : ARG = (FNU-DBLE(FLOAT(INU)))*PI
343 0 : IF (ZI.LT.0.0D0) ARG = -ARG
344 0 : CSGNR = DCOS(ARG)
345 0 : CSGNI = DSIN(ARG)
346 0 : IF (MOD(INU,2).EQ.0) GO TO 40
347 0 : CSGNR = -CSGNR
348 0 : CSGNI = -CSGNI
349 : 40 CONTINUE
350 : CALL ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL, &
351 0 : & ELIM, ALIM)
352 0 : IF (NZ.LT.0) GO TO 120
353 0 : IF (ZR.GE.0.0D0) RETURN
354 : !C-----------------------------------------------------------------------
355 : !C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE
356 : !C-----------------------------------------------------------------------
357 0 : NN = N - NZ
358 0 : IF (NN.EQ.0) RETURN
359 0 : RTOL = 1.0D0/TOL
360 0 : ASCLE = D1MACH(1)*RTOL*1.0D+3
361 0 : DO 50 I=1,NN
362 : !C STR = CYR(I)*CSGNR - CYI(I)*CSGNI
363 : !C CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR
364 : !C CYR(I) = STR
365 0 : AA = CYR(I)
366 0 : BB = CYI(I)
367 0 : ATOL = 1.0D0
368 0 : IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 55
369 0 : AA = AA*RTOL
370 0 : BB = BB*RTOL
371 0 : ATOL = TOL
372 : 55 CONTINUE
373 0 : STR = AA*CSGNR - BB*CSGNI
374 0 : STI = AA*CSGNI + BB*CSGNR
375 0 : CYR(I) = STR*ATOL
376 0 : CYI(I) = STI*ATOL
377 0 : CSGNR = -CSGNR
378 0 : CSGNI = -CSGNI
379 0 : 50 CONTINUE
380 0 : RETURN
381 : 120 CONTINUE
382 0 : IF(NZ.EQ.(-2)) GO TO 130
383 0 : NZ = 0
384 0 : IERR=2
385 0 : RETURN
386 : 130 CONTINUE
387 0 : NZ=0
388 0 : IERR=5
389 0 : RETURN
390 : 260 CONTINUE
391 0 : NZ=0
392 0 : IERR=4
393 0 : RETURN
394 : END SUBROUTINE ZBESI
395 :
396 :
397 0 : SUBROUTINE ZBESK(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR)
398 : !C***BEGIN PROLOGUE ZBESK
399 : !C***DATE WRITTEN 830501 (YYMMDD)
400 : !C***REVISION DATE 890801 (YYMMDD)
401 : !C***CATEGORY NO. B5K
402 : !C***KEYWORDS K-BESSEL FUNCTION,COMPLEX BESSEL FUNCTION,
403 : !C MODIFIED BESSEL FUNCTION OF THE SECOND KIND,
404 : !C BESSEL FUNCTION OF THE THIRD KIND
405 : !C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
406 : !C***PURPOSE TO COMPUTE K-BESSEL FUNCTIONS OF COMPLEX ARGUMENT
407 : !C***DESCRIPTION
408 : !C
409 : !C ***A DOUBLE PRECISION ROUTINE***
410 : !C
411 : !C ON KODE=1, CBESK COMPUTES AN N MEMBER SEQUENCE OF COMPLEX
412 : !C BESSEL FUNCTIONS CY(J)=K(FNU+J-1,Z) FOR REAL, NONNEGATIVE
413 : !C ORDERS FNU+J-1, J=1,...,N AND COMPLEX Z.NE.CMPLX(0.0,0.0)
414 : !C IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESK
415 : !C RETURNS THE SCALED K FUNCTIONS,
416 : !C
417 : !C CY(J)=EXP(Z)*K(FNU+J-1,Z) , J=1,...,N,
418 : !C
419 : !C WHICH REMOVE THE EXPONENTIAL BEHAVIOR IN BOTH THE LEFT AND
420 : !C RIGHT HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND
421 : !C NOTATION ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL
422 : !C FUNCTIONS (REF. 1).
423 : !C
424 : !C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION
425 : !C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0),
426 : !C -PI.LT.ARG(Z).LE.PI
427 : !C FNU - ORDER OF INITIAL K FUNCTION, FNU.GE.0.0D0
428 : !C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1
429 : !C KODE - A PARAMETER TO INDICATE THE SCALING OPTION
430 : !C KODE= 1 RETURNS
431 : !C CY(I)=K(FNU+I-1,Z), I=1,...,N
432 : !C = 2 RETURNS
433 : !C CY(I)=K(FNU+I-1,Z)*EXP(Z), I=1,...,N
434 : !C
435 : !C OUTPUT CYR,CYI ARE DOUBLE PRECISION
436 : !C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS
437 : !C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE
438 : !C CY(I)=K(FNU+I-1,Z), I=1,...,N OR
439 : !C CY(I)=K(FNU+I-1,Z)*EXP(Z), I=1,...,N
440 : !C DEPENDING ON KODE
441 : !C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW.
442 : !C NZ= 0 , NORMAL RETURN
443 : !C NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO DUE
444 : !C TO UNDERFLOW, CY(I)=CMPLX(0.0D0,0.0D0),
445 : !C I=1,...,N WHEN X.GE.0.0. WHEN X.LT.0.0
446 : !C NZ STATES ONLY THE NUMBER OF UNDERFLOWS
447 : !C IN THE SEQUENCE.
448 : !C
449 : !C IERR - ERROR FLAG
450 : !C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
451 : !C IERR=1, INPUT ERROR - NO COMPUTATION
452 : !C IERR=2, OVERFLOW - NO COMPUTATION, FNU IS
453 : !C TOO LARGE OR CABS(Z) IS TOO SMALL OR BOTH
454 : !C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
455 : !C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
456 : !C REDUCTION PRODUCE LESS THAN HALF OF MACHINE
457 : !C ACCURACY
458 : !C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
459 : !C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
460 : !C CANCE BY ARGUMENT REDUCTION
461 : !C IERR=5, ERROR - NO COMPUTATION,
462 : !C ALGORITHM TERMINATION CONDITION NOT MET
463 : !C
464 : !C***LONG DESCRIPTION
465 : !C
466 : !C EQUATIONS OF THE REFERENCE ARE IMPLEMENTED FOR SMALL ORDERS
467 : !C DNU AND DNU+1.0 IN THE RIGHT HALF PLANE X.GE.0.0. FORWARD
468 : !C RECURRENCE GENERATES HIGHER ORDERS. K IS CONTINUED TO THE LEFT
469 : !C HALF PLANE BY THE RELATION
470 : !C
471 : !C K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z)
472 : !C MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1
473 : !C
474 : !C WHERE I(FNU,Z) IS THE I BESSEL FUNCTION.
475 : !C
476 : !C FOR LARGE ORDERS, FNU.GT.FNUL, THE K FUNCTION IS COMPUTED
477 : !C BY MEANS OF ITS UNIFORM ASYMPTOTIC EXPANSIONS.
478 : !C
479 : !C FOR NEGATIVE ORDERS, THE FORMULA
480 : !C
481 : !C K(-FNU,Z) = K(FNU,Z)
482 : !C
483 : !C CAN BE USED.
484 : !C
485 : !C CBESK ASSUMES THAT A SIGNIFICANT DIGIT SINH(X) FUNCTION IS
486 : !C AVAILABLE.
487 : !C
488 : !C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
489 : !C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS
490 : !C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.
491 : !C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN
492 : !C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG
493 : !C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
494 : !C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
495 : !C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS
496 : !C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS
497 : !C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE
498 : !C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS
499 : !C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
500 : !C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
501 : !C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
502 : !C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
503 : !C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
504 : !C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
505 : !C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
506 : !C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
507 : !C
508 : !C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
509 : !C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
510 : !C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
511 : !C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
512 : !C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
513 : !C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
514 : !C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
515 : !C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
516 : !C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
517 : !C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
518 : !C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
519 : !C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
520 : !C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
521 : !C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
522 : !C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
523 : !C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
524 : !C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
525 : !C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
526 : !C OR -PI/2+P.
527 : !C
528 : !C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
529 : !C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
530 : !C COMMERCE, 1955.
531 : !C
532 : !C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
533 : !C BY D. E. AMOS, SAND83-0083, MAY, 1983.
534 : !C
535 : !C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
536 : !C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983.
537 : !C
538 : !C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
539 : !C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
540 : !C 1018, MAY, 1985
541 : !C
542 : !C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
543 : !C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
544 : !C MATH. SOFTWARE, 1986
545 : !C
546 : !C***ROUTINES CALLED ZACON,ZBKNU,ZBUNK,ZUOIK,AZABS,I1MACH,D1MACH
547 : !C***END PROLOGUE ZBESK
548 : !C
549 : !C COMPLEX CY,Z
550 : DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM, FN, &
551 : & FNU, FNUL, RL, R1M5, TOL, UFL, ZI, ZR, BB !D1MACH, AZABS
552 : INTEGER IERR, K, KODE, K1, K2, MR, N, NN, NUF, NW, NZ!, I1MACH
553 : DIMENSION CYR(N), CYI(N)
554 : !C***FIRST EXECUTABLE STATEMENT ZBESK
555 0 : IERR = 0
556 0 : NZ=0
557 0 : IF (ZI.EQ.0.0E0 .AND. ZR.EQ.0.0E0) IERR=1
558 0 : IF (FNU.LT.0.0D0) IERR=1
559 0 : IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
560 0 : IF (N.LT.1) IERR=1
561 0 : IF (IERR.NE.0) RETURN
562 0 : NN = N
563 : !C-----------------------------------------------------------------------
564 : !C SET PARAMETERS RELATED TO MACHINE CONSTANTS.
565 : !C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
566 : !C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
567 : !C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND
568 : !C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR
569 : !C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
570 : !C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
571 : !C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
572 : !C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU
573 : !C-----------------------------------------------------------------------
574 0 : TOL = DMAX1(D1MACH(4),1.0D-18)
575 0 : K1 = I1MACH(15)
576 0 : K2 = I1MACH(16)
577 0 : R1M5 = D1MACH(5)
578 0 : K = MIN0(IABS(K1),IABS(K2))
579 0 : ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
580 0 : K1 = I1MACH(14) - 1
581 0 : AA = R1M5*DBLE(FLOAT(K1))
582 0 : DIG = DMIN1(AA,18.0D0)
583 0 : AA = AA*2.303D0
584 0 : ALIM = ELIM + DMAX1(-AA,-41.45D0)
585 0 : FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
586 0 : RL = 1.2D0*DIG + 3.0D0
587 : !C-----------------------------------------------------------------------------
588 : !C TEST FOR PROPER RANGE
589 : !C-----------------------------------------------------------------------
590 0 : AZ = AZABS(ZR,ZI)
591 0 : FN = FNU + DBLE(FLOAT(NN-1))
592 0 : AA = 0.5D0/TOL
593 0 : BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
594 0 : AA = DMIN1(AA,BB)
595 0 : IF (AZ.GT.AA) GO TO 260
596 0 : IF (FN.GT.AA) GO TO 260
597 0 : AA = DSQRT(AA)
598 0 : IF (AZ.GT.AA) IERR=3
599 0 : IF (FN.GT.AA) IERR=3
600 : !C-----------------------------------------------------------------------
601 : !C OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE
602 : !C-----------------------------------------------------------------------
603 : !C UFL = DEXP(-ELIM)
604 0 : UFL = D1MACH(1)*1.0D+3
605 0 : IF (AZ.LT.UFL) GO TO 180
606 0 : IF (FNU.GT.FNUL) GO TO 80
607 0 : IF (FN.LE.1.0D0) GO TO 60
608 0 : IF (FN.GT.2.0D0) GO TO 50
609 0 : IF (AZ.GT.TOL) GO TO 60
610 0 : ARG = 0.5D0*AZ
611 0 : ALN = -FN*DLOG(ARG)
612 0 : IF (ALN.GT.ELIM) GO TO 180
613 0 : GO TO 60
614 : 50 CONTINUE
615 : CALL ZUOIK(ZR, ZI, FNU, KODE, 2, NN, CYR, CYI, NUF, TOL, ELIM, &
616 0 : & ALIM)
617 0 : IF (NUF.LT.0) GO TO 180
618 0 : NZ = NZ + NUF
619 0 : NN = NN - NUF
620 : !C-----------------------------------------------------------------------
621 : !C HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK
622 : !C IF NUF=NN, THEN CY(I)=CZERO FOR ALL I
623 : !C-----------------------------------------------------------------------
624 0 : IF (NN.EQ.0) GO TO 100
625 : 60 CONTINUE
626 0 : IF (ZR.LT.0.0D0) GO TO 70
627 : !C-----------------------------------------------------------------------
628 : !C RIGHT HALF PLANE COMPUTATION, REAL(Z).GE.0.
629 : !C-----------------------------------------------------------------------
630 0 : CALL ZBKNU(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM)
631 0 : IF (NW.LT.0) GO TO 200
632 0 : NZ=NW
633 0 : RETURN
634 : !C-----------------------------------------------------------------------
635 : !C LEFT HALF PLANE COMPUTATION
636 : !C PI/2.LT.ARG(Z).LE.PI AND -PI.LT.ARG(Z).LT.-PI/2.
637 : !C-----------------------------------------------------------------------
638 : 70 CONTINUE
639 0 : IF (NZ.NE.0) GO TO 180
640 0 : MR = 1
641 0 : IF (ZI.LT.0.0D0) MR = -1
642 : CALL ZACON(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL, &
643 0 : & TOL, ELIM, ALIM)
644 0 : IF (NW.LT.0) GO TO 200
645 0 : NZ=NW
646 0 : RETURN
647 : !C-----------------------------------------------------------------------
648 : !C UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL
649 : !C-----------------------------------------------------------------------
650 : 80 CONTINUE
651 0 : MR = 0
652 0 : IF (ZR.GE.0.0D0) GO TO 90
653 0 : MR = 1
654 0 : IF (ZI.LT.0.0D0) MR = -1
655 : 90 CONTINUE
656 : CALL ZBUNK(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM, &
657 0 : & ALIM)
658 0 : IF (NW.LT.0) GO TO 200
659 0 : NZ = NZ + NW
660 0 : RETURN
661 : 100 CONTINUE
662 0 : IF (ZR.LT.0.0D0) GO TO 180
663 0 : RETURN
664 : 180 CONTINUE
665 0 : NZ = 0
666 0 : IERR=2
667 0 : RETURN
668 : 200 CONTINUE
669 0 : IF(NW.EQ.(-1)) GO TO 180
670 0 : NZ=0
671 0 : IERR=5
672 0 : RETURN
673 : 260 CONTINUE
674 0 : NZ=0
675 0 : IERR=4
676 0 : RETURN
677 : END SUBROUTINE ZBESK
678 :
679 0 : DOUBLE PRECISION FUNCTION AZABS(ZR, ZI)
680 : !C***BEGIN PROLOGUE AZABS
681 : !C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
682 : !C
683 : !C AZABS COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE
684 : !C PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI)
685 : !C
686 : !C***ROUTINES CALLED (NONE)
687 : !C***END PROLOGUE AZABS
688 : DOUBLE PRECISION ZR, ZI, U, V, Q, S
689 0 : U = DABS(ZR)
690 0 : V = DABS(ZI)
691 0 : S = U + V
692 : !C-----------------------------------------------------------------------
693 : !C S*1.0D0 MAKES AN UNNORMALIZED UNDERFLOW ON CDC MACHINES INTO A
694 : !C TRUE FLOATING ZERO
695 : !C-----------------------------------------------------------------------
696 0 : S = S*1.0D+0
697 0 : IF (S.EQ.0.0D+0) GO TO 20
698 0 : IF (U.GT.V) GO TO 10
699 0 : Q = U/V
700 0 : AZABS = V*DSQRT(1.D+0+Q*Q)
701 0 : RETURN
702 0 : 10 Q = V/U
703 0 : AZABS = U*DSQRT(1.D+0+Q*Q)
704 0 : RETURN
705 0 : 20 AZABS = 0.0D+0
706 : RETURN
707 : END FUNCTION AZABS
708 :
709 :
710 :
711 0 : SUBROUTINE ZACON(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, FNUL, &
712 : & TOL, ELIM, ALIM)
713 : !C***BEGIN PROLOGUE ZACON
714 : !C***REFER TO ZBESK,ZBESH
715 : !C
716 : !C ZACON APPLIES THE ANALYTIC CONTINUATION FORMULA
717 : !C
718 : !C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN)
719 : !C MP=PI*MR*CMPLX(0.0,1.0)
720 : !C
721 : !C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT
722 : !C HALF Z PLANE
723 : !C
724 : !C***ROUTINES CALLED ZBINU,ZBKNU,ZS1S2,D1MACH,AZABS,ZMLT
725 : !C***END PROLOGUE ZACON
726 : !C COMPLEX CK,CONE,CSCL,CSCR,CSGN,CSPN,CY,CZERO,C1,C2,RZ,SC1,SC2,ST,
727 : !C *S1,S2,Y,Z,ZN
728 : DOUBLE PRECISION ALIM, ARG, ASCLE, AS2, AZN, BRY, BSCLE, CKI, &
729 : & CKR, CONER, CPN, CSCL, CSCR, CSGNI, CSGNR, CSPNI, CSPNR, &
730 : & CSR, CSRR, CSSR, CYI, CYR, C1I, C1M, C1R, C2I, C2R, ELIM, FMR, &
731 : & FN, FNU, FNUL, PI, PTI, PTR, RAZN, RL, RZI, RZR, SC1I, SC1R, &
732 : & SC2I, SC2R, SGN, SPN, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, &
733 : & YY, ZEROR, ZI, ZNI, ZNR, ZR!, D1MACH, AZABS
734 : INTEGER I, INU, IUF, KFLAG, KODE, MR, N, NN, NW, NZ
735 : DIMENSION YR(N), YI(N), CYR(2), CYI(2), CSSR(3), CSRR(3), BRY(3)
736 : DATA PI / 3.14159265358979324D0 /
737 : DATA ZEROR,CONER / 0.0D0,1.0D0 /
738 0 : NZ = 0
739 0 : ZNR = -ZR
740 0 : ZNI = -ZI
741 0 : NN = N
742 : CALL ZBINU(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, FNUL, TOL, &
743 0 : & ELIM, ALIM)
744 0 : IF (NW.LT.0) GO TO 90
745 : !C-----------------------------------------------------------------------
746 : !C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION
747 : !C-----------------------------------------------------------------------
748 0 : NN = MIN0(2,N)
749 0 : CALL ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM)
750 0 : IF (NW.NE.0) GO TO 90
751 0 : S1R = CYR(1)
752 0 : S1I = CYI(1)
753 0 : FMR = DBLE(FLOAT(MR))
754 0 : SGN = -DSIGN(PI,FMR)
755 0 : CSGNR = ZEROR
756 0 : CSGNI = SGN
757 0 : IF (KODE.EQ.1) GO TO 10
758 0 : YY = -ZNI
759 0 : CPN = DCOS(YY)
760 0 : SPN = DSIN(YY)
761 0 : CALL ZMLT(CSGNR, CSGNI, CPN, SPN, CSGNR, CSGNI)
762 : 10 CONTINUE
763 : !C-----------------------------------------------------------------------
764 : !C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
765 : !C WHEN FNU IS LARGE
766 : !C-----------------------------------------------------------------------
767 0 : INU = INT(SNGL(FNU))
768 0 : ARG = (FNU-DBLE(FLOAT(INU)))*SGN
769 0 : CPN = DCOS(ARG)
770 0 : SPN = DSIN(ARG)
771 0 : CSPNR = CPN
772 0 : CSPNI = SPN
773 0 : IF (MOD(INU,2).EQ.0) GO TO 20
774 0 : CSPNR = -CSPNR
775 0 : CSPNI = -CSPNI
776 : 20 CONTINUE
777 0 : IUF = 0
778 0 : C1R = S1R
779 0 : C1I = S1I
780 0 : C2R = YR(1)
781 0 : C2I = YI(1)
782 0 : ASCLE = 1.0D+3*D1MACH(1)/TOL
783 0 : IF (KODE.EQ.1) GO TO 30
784 0 : CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF)
785 0 : NZ = NZ + NW
786 0 : SC1R = C1R
787 0 : SC1I = C1I
788 : 30 CONTINUE
789 0 : CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI)
790 0 : CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI)
791 0 : YR(1) = STR + PTR
792 0 : YI(1) = STI + PTI
793 0 : IF (N.EQ.1) RETURN
794 0 : CSPNR = -CSPNR
795 0 : CSPNI = -CSPNI
796 0 : S2R = CYR(2)
797 0 : S2I = CYI(2)
798 0 : C1R = S2R
799 0 : C1I = S2I
800 0 : C2R = YR(2)
801 0 : C2I = YI(2)
802 0 : IF (KODE.EQ.1) GO TO 40
803 0 : CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF)
804 0 : NZ = NZ + NW
805 0 : SC2R = C1R
806 0 : SC2I = C1I
807 : 40 CONTINUE
808 0 : CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI)
809 0 : CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI)
810 0 : YR(2) = STR + PTR
811 0 : YI(2) = STI + PTI
812 0 : IF (N.EQ.2) RETURN
813 0 : CSPNR = -CSPNR
814 0 : CSPNI = -CSPNI
815 0 : AZN = AZABS(ZNR,ZNI)
816 0 : RAZN = 1.0D0/AZN
817 0 : STR = ZNR*RAZN
818 0 : STI = -ZNI*RAZN
819 0 : RZR = (STR+STR)*RAZN
820 0 : RZI = (STI+STI)*RAZN
821 0 : FN = FNU + 1.0D0
822 0 : CKR = FN*RZR
823 0 : CKI = FN*RZI
824 : !C-----------------------------------------------------------------------
825 : !C SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS
826 : !C-----------------------------------------------------------------------
827 0 : CSCL = 1.0D0/TOL
828 0 : CSCR = TOL
829 0 : CSSR(1) = CSCL
830 0 : CSSR(2) = CONER
831 0 : CSSR(3) = CSCR
832 0 : CSRR(1) = CSCR
833 0 : CSRR(2) = CONER
834 0 : CSRR(3) = CSCL
835 0 : BRY(1) = ASCLE
836 0 : BRY(2) = 1.0D0/ASCLE
837 0 : BRY(3) = D1MACH(2)
838 0 : AS2 = AZABS(S2R,S2I)
839 0 : KFLAG = 2
840 0 : IF (AS2.GT.BRY(1)) GO TO 50
841 : KFLAG = 1
842 0 : GO TO 60
843 : 50 CONTINUE
844 0 : IF (AS2.LT.BRY(2)) GO TO 60
845 0 : KFLAG = 3
846 : 60 CONTINUE
847 0 : BSCLE = BRY(KFLAG)
848 0 : S1R = S1R*CSSR(KFLAG)
849 0 : S1I = S1I*CSSR(KFLAG)
850 0 : S2R = S2R*CSSR(KFLAG)
851 0 : S2I = S2I*CSSR(KFLAG)
852 0 : CSR = CSRR(KFLAG)
853 0 : DO 80 I=3,N
854 0 : STR = S2R
855 0 : STI = S2I
856 0 : S2R = CKR*STR - CKI*STI + S1R
857 0 : S2I = CKR*STI + CKI*STR + S1I
858 0 : S1R = STR
859 0 : S1I = STI
860 0 : C1R = S2R*CSR
861 0 : C1I = S2I*CSR
862 0 : STR = C1R
863 0 : STI = C1I
864 0 : C2R = YR(I)
865 0 : C2I = YI(I)
866 0 : IF (KODE.EQ.1) GO TO 70
867 0 : IF (IUF.LT.0) GO TO 70
868 0 : CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF)
869 0 : NZ = NZ + NW
870 0 : SC1R = SC2R
871 0 : SC1I = SC2I
872 0 : SC2R = C1R
873 0 : SC2I = C1I
874 0 : IF (IUF.NE.3) GO TO 70
875 0 : IUF = -4
876 0 : S1R = SC1R*CSSR(KFLAG)
877 0 : S1I = SC1I*CSSR(KFLAG)
878 0 : S2R = SC2R*CSSR(KFLAG)
879 0 : S2I = SC2I*CSSR(KFLAG)
880 0 : STR = SC2R
881 0 : STI = SC2I
882 : 70 CONTINUE
883 0 : PTR = CSPNR*C1R - CSPNI*C1I
884 0 : PTI = CSPNR*C1I + CSPNI*C1R
885 0 : YR(I) = PTR + CSGNR*C2R - CSGNI*C2I
886 0 : YI(I) = PTI + CSGNR*C2I + CSGNI*C2R
887 0 : CKR = CKR + RZR
888 0 : CKI = CKI + RZI
889 0 : CSPNR = -CSPNR
890 0 : CSPNI = -CSPNI
891 0 : IF (KFLAG.GE.3) GO TO 80
892 0 : PTR = DABS(C1R)
893 0 : PTI = DABS(C1I)
894 0 : C1M = DMAX1(PTR,PTI)
895 0 : IF (C1M.LE.BSCLE) GO TO 80
896 0 : KFLAG = KFLAG + 1
897 0 : BSCLE = BRY(KFLAG)
898 0 : S1R = S1R*CSR
899 0 : S1I = S1I*CSR
900 : S2R = STR
901 : S2I = STI
902 0 : S1R = S1R*CSSR(KFLAG)
903 0 : S1I = S1I*CSSR(KFLAG)
904 0 : S2R = S2R*CSSR(KFLAG)
905 0 : S2I = S2I*CSSR(KFLAG)
906 0 : CSR = CSRR(KFLAG)
907 0 : 80 CONTINUE
908 0 : RETURN
909 : 90 CONTINUE
910 0 : NZ = -1
911 0 : IF(NW.EQ.(-2)) NZ=-2
912 : RETURN
913 : END SUBROUTINE ZACON
914 :
915 0 : SUBROUTINE ZBINU(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, &
916 : & TOL, ELIM, ALIM)
917 : !C***BEGIN PROLOGUE ZBINU
918 : !C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZAIRY,ZBIRY
919 : !C
920 : !C ZBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE
921 : !C
922 : !C***ROUTINES CALLED AZABS,ZASYI,ZBUNI,ZMLRI,ZSERI,ZUOIK,ZWRSK
923 : !C***END PROLOGUE ZBINU
924 : DOUBLE PRECISION ALIM, AZ, CWI, CWR, CYI, CYR, DFNU, ELIM, FNU, &
925 : & FNUL, RL, TOL, ZEROI, ZEROR, ZI, ZR!, AZABS
926 : INTEGER I, INW, KODE, N, NLAST, NN, NUI, NW, NZ
927 : DIMENSION CYR(N), CYI(N), CWR(2), CWI(2)
928 : DATA ZEROR,ZEROI / 0.0D0, 0.0D0 /
929 : !C
930 0 : NZ = 0
931 0 : AZ = AZABS(ZR,ZI)
932 0 : NN = N
933 0 : DFNU = FNU + DBLE(FLOAT(N-1))
934 0 : IF (AZ.LE.2.0D0) GO TO 10
935 0 : IF (AZ*AZ*0.25D0.GT.DFNU+1.0D0) GO TO 20
936 : 10 CONTINUE
937 : !C-----------------------------------------------------------------------
938 : !C POWER SERIES
939 : !C-----------------------------------------------------------------------
940 0 : CALL ZSERI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM)
941 0 : INW = IABS(NW)
942 0 : NZ = NZ + INW
943 0 : NN = NN - INW
944 0 : IF (NN.EQ.0) RETURN
945 0 : IF (NW.GE.0) GO TO 120
946 0 : DFNU = FNU + DBLE(FLOAT(NN-1))
947 : 20 CONTINUE
948 0 : IF (AZ.LT.RL) GO TO 40
949 0 : IF (DFNU.LE.1.0D0) GO TO 30
950 0 : IF (AZ+AZ.LT.DFNU*DFNU) GO TO 50
951 : !C-----------------------------------------------------------------------
952 : !C ASYMPTOTIC EXPANSION FOR LARGE Z
953 : !C-----------------------------------------------------------------------
954 : 30 CONTINUE
955 : CALL ZASYI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, RL, TOL, ELIM, &
956 0 : & ALIM)
957 0 : IF (NW.LT.0) GO TO 130
958 0 : GO TO 120
959 : 40 CONTINUE
960 0 : IF (DFNU.LE.1.0D0) GO TO 70
961 : 50 CONTINUE
962 : !C-----------------------------------------------------------------------
963 : !C OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM
964 : !C-----------------------------------------------------------------------
965 : CALL ZUOIK(ZR, ZI, FNU, KODE, 1, NN, CYR, CYI, NW, TOL, ELIM, &
966 0 : & ALIM)
967 0 : IF (NW.LT.0) GO TO 130
968 0 : NZ = NZ + NW
969 0 : NN = NN - NW
970 0 : IF (NN.EQ.0) RETURN
971 0 : DFNU = FNU+DBLE(FLOAT(NN-1))
972 0 : IF (DFNU.GT.FNUL) GO TO 110
973 0 : IF (AZ.GT.FNUL) GO TO 110
974 : 60 CONTINUE
975 0 : IF (AZ.GT.RL) GO TO 80
976 : 70 CONTINUE
977 : !C-----------------------------------------------------------------------
978 : !C MILLER ALGORITHM NORMALIZED BY THE SERIES
979 : !C-----------------------------------------------------------------------
980 0 : CALL ZMLRI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL)
981 0 : IF(NW.LT.0) GO TO 130
982 0 : GO TO 120
983 : 80 CONTINUE
984 : !C-----------------------------------------------------------------------
985 : !C MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN
986 : !C-----------------------------------------------------------------------
987 : !C-----------------------------------------------------------------------
988 : !C OVERFLOW TEST ON K FUNCTIONS USED IN WRONSKIAN
989 : !C-----------------------------------------------------------------------
990 : CALL ZUOIK(ZR, ZI, FNU, KODE, 2, 2, CWR, CWI, NW, TOL, ELIM, &
991 0 : & ALIM)
992 0 : IF (NW.GE.0) GO TO 100
993 0 : NZ = NN
994 0 : DO 90 I=1,NN
995 0 : CYR(I) = ZEROR
996 0 : CYI(I) = ZEROI
997 0 : 90 CONTINUE
998 0 : RETURN
999 : 100 CONTINUE
1000 0 : IF (NW.GT.0) GO TO 130
1001 : CALL ZWRSK(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, CWR, CWI, TOL, &
1002 0 : & ELIM, ALIM)
1003 0 : IF (NW.LT.0) GO TO 130
1004 0 : GO TO 120
1005 : 110 CONTINUE
1006 : !C-----------------------------------------------------------------------
1007 : !C INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD
1008 : !C-----------------------------------------------------------------------
1009 0 : NUI = INT(SNGL(FNUL-DFNU)) + 1
1010 0 : NUI = MAX0(NUI,0)
1011 : CALL ZBUNI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, NUI, NLAST, FNUL, &
1012 0 : & TOL, ELIM, ALIM)
1013 0 : IF (NW.LT.0) GO TO 130
1014 0 : NZ = NZ + NW
1015 0 : IF (NLAST.EQ.0) GO TO 120
1016 0 : NN = NLAST
1017 0 : GO TO 60
1018 : 120 CONTINUE
1019 0 : RETURN
1020 : 130 CONTINUE
1021 0 : NZ = -1
1022 0 : IF(NW.EQ.(-2)) NZ=-2
1023 : RETURN
1024 : END SUBROUTINE ZBINU
1025 :
1026 0 : SUBROUTINE ZSERI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, &
1027 : & ALIM)
1028 : !C***BEGIN PROLOGUE ZSERI
1029 : !C***REFER TO ZBESI,ZBESK
1030 : !C
1031 : !C ZSERI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY
1032 : !C MEANS OF THE POWER SERIES FOR LARGE CABS(Z) IN THE
1033 : !C REGION CABS(Z).LE.2*SQRT(FNU+1). NZ=0 IS A NORMAL RETURN.
1034 : !C NZ.GT.0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO
1035 : !C DUE TO UNDERFLOW. NZ.LT.0 MEANS UNDERFLOW OCCURRED, BUT THE
1036 : !C CONDITION CABS(Z).LE.2*SQRT(FNU+1) WAS VIOLATED AND THE
1037 : !C COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ).
1038 : !C
1039 : !C***ROUTINES CALLED DGAMLN,D1MACH,ZUCHK,AZABS,ZDIV,AZLOG,ZMLT
1040 : !C***END PROLOGUE ZSERI
1041 : !C COMPLEX AK1,CK,COEF,CONE,CRSC,CSCL,CZ,CZERO,HZ,RZ,S1,S2,Y,Z
1042 : DOUBLE PRECISION AA, ACZ, AK, AK1I, AK1R, ALIM, ARM, ASCLE, ATOL, &
1043 : & AZ, CKI, CKR, COEFI, COEFR, CONEI, CONER, CRSCR, CZI, CZR, DFNU, &
1044 : & ELIM, FNU, FNUP, HZI, HZR, RAZ, RS, RTR1, RZI, RZR, S, SS, STI, &
1045 : & STR, S1I, S1R, S2I, S2R, TOL, YI, YR, WI, WR, ZEROI, ZEROR, ZI, &
1046 : & ZR!, DGAMLN, D1MACH, AZABS
1047 : INTEGER I, IB, IDUM, IFLAG, IL, K, KODE, L, M, N, NN, NZ, NW
1048 : DIMENSION YR(N), YI(N), WR(2), WI(2)
1049 : DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
1050 : !C
1051 0 : NZ = 0
1052 0 : AZ = AZABS(ZR,ZI)
1053 0 : IF (AZ.EQ.0.0D0) GO TO 160
1054 0 : ARM = 1.0D+3*D1MACH(1)
1055 0 : RTR1 = DSQRT(ARM)
1056 0 : CRSCR = 1.0D0
1057 0 : IFLAG = 0
1058 0 : IF (AZ.LT.ARM) GO TO 150
1059 0 : HZR = 0.5D0*ZR
1060 0 : HZI = 0.5D0*ZI
1061 0 : CZR = ZEROR
1062 0 : CZI = ZEROI
1063 0 : IF (AZ.LE.RTR1) GO TO 10
1064 0 : CALL ZMLT(HZR, HZI, HZR, HZI, CZR, CZI)
1065 : 10 CONTINUE
1066 0 : ACZ = AZABS(CZR,CZI)
1067 0 : NN = N
1068 0 : CALL AZLOG(HZR, HZI, CKR, CKI, IDUM)
1069 : 20 CONTINUE
1070 0 : DFNU = FNU + DBLE(FLOAT(NN-1))
1071 0 : FNUP = DFNU + 1.0D0
1072 : !C-----------------------------------------------------------------------
1073 : !C UNDERFLOW TEST
1074 : !C-----------------------------------------------------------------------
1075 0 : AK1R = CKR*DFNU
1076 0 : AK1I = CKI*DFNU
1077 0 : AK = DGAMLN(FNUP,IDUM)
1078 0 : AK1R = AK1R - AK
1079 0 : IF (KODE.EQ.2) AK1R = AK1R - ZR
1080 0 : IF (AK1R.GT.(-ELIM)) GO TO 40
1081 : 30 CONTINUE
1082 0 : NZ = NZ + 1
1083 0 : YR(NN) = ZEROR
1084 0 : YI(NN) = ZEROI
1085 0 : IF (ACZ.GT.DFNU) GO TO 190
1086 0 : NN = NN - 1
1087 0 : IF (NN.EQ.0) RETURN
1088 0 : GO TO 20
1089 : 40 CONTINUE
1090 0 : IF (AK1R.GT.(-ALIM)) GO TO 50
1091 0 : IFLAG = 1
1092 0 : SS = 1.0D0/TOL
1093 0 : CRSCR = TOL
1094 0 : ASCLE = ARM*SS
1095 : 50 CONTINUE
1096 0 : AA = DEXP(AK1R)
1097 0 : IF (IFLAG.EQ.1) AA = AA*SS
1098 0 : COEFR = AA*DCOS(AK1I)
1099 0 : COEFI = AA*DSIN(AK1I)
1100 0 : ATOL = TOL*ACZ/FNUP
1101 0 : IL = MIN0(2,NN)
1102 0 : DO 90 I=1,IL
1103 0 : DFNU = FNU + DBLE(FLOAT(NN-I))
1104 0 : FNUP = DFNU + 1.0D0
1105 0 : S1R = CONER
1106 0 : S1I = CONEI
1107 0 : IF (ACZ.LT.TOL*FNUP) GO TO 70
1108 0 : AK1R = CONER
1109 0 : AK1I = CONEI
1110 0 : AK = FNUP + 2.0D0
1111 0 : S = FNUP
1112 0 : AA = 2.0D0
1113 : 60 CONTINUE
1114 0 : RS = 1.0D0/S
1115 0 : STR = AK1R*CZR - AK1I*CZI
1116 0 : STI = AK1R*CZI + AK1I*CZR
1117 0 : AK1R = STR*RS
1118 0 : AK1I = STI*RS
1119 0 : S1R = S1R + AK1R
1120 0 : S1I = S1I + AK1I
1121 0 : S = S + AK
1122 0 : AK = AK + 2.0D0
1123 0 : AA = AA*ACZ*RS
1124 0 : IF (AA.GT.ATOL) GO TO 60
1125 : 70 CONTINUE
1126 0 : S2R = S1R*COEFR - S1I*COEFI
1127 0 : S2I = S1R*COEFI + S1I*COEFR
1128 0 : WR(I) = S2R
1129 0 : WI(I) = S2I
1130 0 : IF (IFLAG.EQ.0) GO TO 80
1131 0 : CALL ZUCHK(S2R, S2I, NW, ASCLE, TOL)
1132 : IF (NW.NE.0) GO TO 30
1133 : 80 CONTINUE
1134 0 : M = NN - I + 1
1135 0 : YR(M) = S2R*CRSCR
1136 0 : YI(M) = S2I*CRSCR
1137 0 : IF (I.EQ.IL) GO TO 90
1138 0 : CALL ZDIV(COEFR, COEFI, HZR, HZI, STR, STI)
1139 0 : COEFR = STR*DFNU
1140 0 : COEFI = STI*DFNU
1141 0 : 90 CONTINUE
1142 0 : IF (NN.LE.2) RETURN
1143 0 : K = NN - 2
1144 0 : AK = DBLE(FLOAT(K))
1145 0 : RAZ = 1.0D0/AZ
1146 0 : STR = ZR*RAZ
1147 0 : STI = -ZI*RAZ
1148 0 : RZR = (STR+STR)*RAZ
1149 0 : RZI = (STI+STI)*RAZ
1150 0 : IF (IFLAG.EQ.1) GO TO 120
1151 : IB = 3
1152 : 100 CONTINUE
1153 0 : DO 110 I=IB,NN
1154 0 : YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2)
1155 0 : YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2)
1156 0 : AK = AK - 1.0D0
1157 0 : K = K - 1
1158 0 : 110 CONTINUE
1159 0 : RETURN
1160 : !C-----------------------------------------------------------------------
1161 : !C RECUR BACKWARD WITH SCALED VALUES
1162 : !C-----------------------------------------------------------------------
1163 : 120 CONTINUE
1164 : !C-----------------------------------------------------------------------
1165 : !C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE
1166 : !C UNDERFLOW LIMIT = ASCLE = D1MACH(1)*SS*1.0D+3
1167 : !C-----------------------------------------------------------------------
1168 0 : S1R = WR(1)
1169 0 : S1I = WI(1)
1170 0 : S2R = WR(2)
1171 0 : S2I = WI(2)
1172 0 : DO 130 L=3,NN
1173 : CKR = S2R
1174 : CKI = S2I
1175 0 : S2R = S1R + (AK+FNU)*(RZR*CKR-RZI*CKI)
1176 0 : S2I = S1I + (AK+FNU)*(RZR*CKI+RZI*CKR)
1177 0 : S1R = CKR
1178 0 : S1I = CKI
1179 0 : CKR = S2R*CRSCR
1180 0 : CKI = S2I*CRSCR
1181 0 : YR(K) = CKR
1182 0 : YI(K) = CKI
1183 0 : AK = AK - 1.0D0
1184 0 : K = K - 1
1185 0 : IF (AZABS(CKR,CKI).GT.ASCLE) GO TO 140
1186 0 : 130 CONTINUE
1187 0 : RETURN
1188 : 140 CONTINUE
1189 0 : IB = L + 1
1190 0 : IF (IB.GT.NN) RETURN
1191 0 : GO TO 100
1192 : 150 CONTINUE
1193 0 : NZ = N
1194 0 : IF (FNU.EQ.0.0D0) NZ = NZ - 1
1195 : 160 CONTINUE
1196 0 : YR(1) = ZEROR
1197 0 : YI(1) = ZEROI
1198 0 : IF (FNU.NE.0.0D0) GO TO 170
1199 0 : YR(1) = CONER
1200 0 : YI(1) = CONEI
1201 : 170 CONTINUE
1202 0 : IF (N.EQ.1) RETURN
1203 0 : DO 180 I=2,N
1204 0 : YR(I) = ZEROR
1205 0 : YI(I) = ZEROI
1206 0 : 180 CONTINUE
1207 0 : RETURN
1208 : !C-----------------------------------------------------------------------
1209 : !C RETURN WITH NZ.LT.0 IF CABS(Z*Z/4).GT.FNU+N-NZ-1 COMPLETE
1210 : !C THE CALCULATION IN CBINU WITH N=N-IABS(NZ)
1211 : !C-----------------------------------------------------------------------
1212 : 190 CONTINUE
1213 0 : NZ = -NZ
1214 0 : RETURN
1215 : END SUBROUTINE ZSERI
1216 :
1217 :
1218 0 : DOUBLE PRECISION FUNCTION D1MACH(I)
1219 : INTEGER I
1220 : !C
1221 : !C DOUBLE-PRECISION MACHINE CONSTANTS
1222 : !C D1MACH( 1) = B**(EMIN-1), THE SMALLEST POSITIVE MAGNITUDE.
1223 : !C D1MACH( 2) = B**EMAX*(1 - B**(-T)), THE LARGEST MAGNITUDE.
1224 : !C D1MACH( 3) = B**(-T), THE SMALLEST RELATIVE SPACING.
1225 : !C D1MACH( 4) = B**(1-T), THE LARGEST RELATIVE SPACING.
1226 : !C D1MACH( 5) = LOG10(B)
1227 : !C
1228 : INTEGER SMALL(2)
1229 : INTEGER LARGE(2)
1230 : INTEGER RIGHT(2)
1231 : INTEGER DIVER(2)
1232 : INTEGER LOG10(2)
1233 : INTEGER SC, CRAY1(38), J
1234 : COMMON /D9MACH/ CRAY1
1235 : SAVE SMALL, LARGE, RIGHT, DIVER, LOG10, SC
1236 : DOUBLE PRECISION DMACH(5)
1237 : EQUIVALENCE (DMACH(1),SMALL(1))
1238 : EQUIVALENCE (DMACH(2),LARGE(1))
1239 : EQUIVALENCE (DMACH(3),RIGHT(1))
1240 : EQUIVALENCE (DMACH(4),DIVER(1))
1241 : EQUIVALENCE (DMACH(5),LOG10(1))
1242 : !C THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES.
1243 : !C R1MACH CAN HANDLE AUTO-DOUBLE COMPILING, BUT THIS VERSION OF
1244 : !C D1MACH DOES NOT, BECAUSE WE DO NOT HAVE QUAD CONSTANTS FOR
1245 : !C MANY MACHINES YET.
1246 : !C TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1
1247 : !C ON THE NEXT LINE
1248 : DATA SC/0/
1249 : !C AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW.
1250 : !C CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY
1251 : !C mail netlib@research.bell-labs.com
1252 : !C send old1mach from blas
1253 : !C PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com.
1254 : !C
1255 : !C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
1256 : !C DATA SMALL(1),SMALL(2) / O402400000000, O000000000000 /
1257 : !C DATA LARGE(1),LARGE(2) / O376777777777, O777777777777 /
1258 : !C DATA RIGHT(1),RIGHT(2) / O604400000000, O000000000000 /
1259 : !C DATA DIVER(1),DIVER(2) / O606400000000, O000000000000 /
1260 : !C DATA LOG10(1),LOG10(2) / O776464202324, O117571775714 /, SC/987/
1261 : !C
1262 : !C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
1263 : !C 32-BIT INTEGERS.
1264 : !C DATA SMALL(1),SMALL(2) / 8388608, 0 /
1265 : !C DATA LARGE(1),LARGE(2) / 2147483647, -1 /
1266 : !C DATA RIGHT(1),RIGHT(2) / 612368384, 0 /
1267 : !C DATA DIVER(1),DIVER(2) / 620756992, 0 /
1268 : !C DATA LOG10(1),LOG10(2) / 1067065498, -2063872008 /, SC/987/
1269 : !C
1270 : !C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
1271 : !C DATA SMALL(1),SMALL(2) / O000040000000, O000000000000 /
1272 : !C DATA LARGE(1),LARGE(2) / O377777777777, O777777777777 /
1273 : !C DATA RIGHT(1),RIGHT(2) / O170540000000, O000000000000 /
1274 : !C DATA DIVER(1),DIVER(2) / O170640000000, O000000000000 /
1275 : !C DATA LOG10(1),LOG10(2) / O177746420232, O411757177572 /, SC/987/
1276 : !C
1277 : !C ON FIRST CALL, IF NO DATA UNCOMMENTED, TEST MACHINE TYPES.
1278 0 : IF (SC .NE. 987) THEN
1279 : DMACH(1) = 1.D13
1280 : IF ( SMALL(1) .EQ. 1117925532 &
1281 : & .AND. SMALL(2) .EQ. -448790528) THEN
1282 : !* *** IEEE BIG ENDIAN ***
1283 : SMALL(1) = 1048576
1284 : SMALL(2) = 0
1285 : LARGE(1) = 2146435071
1286 : LARGE(2) = -1
1287 : RIGHT(1) = 1017118720
1288 : RIGHT(2) = 0
1289 : DIVER(1) = 1018167296
1290 : DIVER(2) = 0
1291 : LOG10(1) = 1070810131
1292 : LOG10(2) = 1352628735
1293 : ELSE IF ( SMALL(2) .EQ. 1117925532 &
1294 : & .AND. SMALL(1) .EQ. -448790528) THEN
1295 : !* *** IEEE LITTLE ENDIAN ***
1296 0 : SMALL(2) = 1048576
1297 0 : SMALL(1) = 0
1298 0 : LARGE(2) = 2146435071
1299 0 : LARGE(1) = -1
1300 0 : RIGHT(2) = 1017118720
1301 0 : RIGHT(1) = 0
1302 0 : DIVER(2) = 1018167296
1303 0 : DIVER(1) = 0
1304 0 : LOG10(2) = 1070810131
1305 0 : LOG10(1) = 1352628735
1306 : ELSE IF ( SMALL(1) .EQ. -2065213935 &
1307 : & .AND. SMALL(2) .EQ. 10752) THEN
1308 : !* *** VAX WITH D_FLOATING ***
1309 : SMALL(1) = 128
1310 : SMALL(2) = 0
1311 : LARGE(1) = -32769
1312 : LARGE(2) = -1
1313 : RIGHT(1) = 9344
1314 : RIGHT(2) = 0
1315 : DIVER(1) = 9472
1316 : DIVER(2) = 0
1317 : LOG10(1) = 546979738
1318 : LOG10(2) = -805796613
1319 : ELSE IF ( SMALL(1) .EQ. 1267827943 &
1320 : & .AND. SMALL(2) .EQ. 704643072) THEN
1321 : !* *** IBM MAINFRAME ***
1322 : SMALL(1) = 1048576
1323 : SMALL(2) = 0
1324 : LARGE(1) = 2147483647
1325 : LARGE(2) = -1
1326 : RIGHT(1) = 856686592
1327 : RIGHT(2) = 0
1328 : DIVER(1) = 873463808
1329 : DIVER(2) = 0
1330 : LOG10(1) = 1091781651
1331 : LOG10(2) = 1352628735
1332 : ELSE IF ( SMALL(1) .EQ. 1120022684 &
1333 : & .AND. SMALL(2) .EQ. -448790528) THEN
1334 : !* *** CONVEX C-1 ***
1335 : SMALL(1) = 1048576
1336 : SMALL(2) = 0
1337 : LARGE(1) = 2147483647
1338 : LARGE(2) = -1
1339 : RIGHT(1) = 1019215872
1340 : RIGHT(2) = 0
1341 : DIVER(1) = 1020264448
1342 : DIVER(2) = 0
1343 : LOG10(1) = 1072907283
1344 : LOG10(2) = 1352628735
1345 : ELSE IF ( SMALL(1) .EQ. 815547074 &
1346 : & .AND. SMALL(2) .EQ. 58688) THEN
1347 : !* *** VAX G-FLOATING ***
1348 : SMALL(1) = 16
1349 : SMALL(2) = 0
1350 : LARGE(1) = -32769
1351 : LARGE(2) = -1
1352 : RIGHT(1) = 15552
1353 : RIGHT(2) = 0
1354 : DIVER(1) = 15568
1355 : DIVER(2) = 0
1356 : LOG10(1) = 1142112243
1357 : LOG10(2) = 2046775455
1358 : ELSE
1359 : DMACH(2) = 1.D27 + 1
1360 : DMACH(3) = 1.D27
1361 : LARGE(2) = LARGE(2) - RIGHT(2)
1362 : IF (LARGE(2) .EQ. 64 .AND. SMALL(2) .EQ. 0) THEN
1363 : CRAY1(1) = 67291416
1364 : DO 10 J = 1, 20
1365 : CRAY1(J+1) = CRAY1(J) + CRAY1(J)
1366 : 10 CONTINUE
1367 : CRAY1(22) = CRAY1(21) + 321322
1368 : DO 20 J = 22, 37
1369 : CRAY1(J+1) = CRAY1(J) + CRAY1(J)
1370 : 20 CONTINUE
1371 : IF (CRAY1(38) .EQ. SMALL(1)) THEN
1372 : !* *** CRAY ***
1373 : CALL I1MCRY(SMALL(1), J, 8285, 8388608, 0)
1374 : SMALL(2) = 0
1375 : CALL I1MCRY(LARGE(1), J, 24574, 16777215, 16777215)
1376 : CALL I1MCRY(LARGE(2), J, 0, 16777215, 16777214)
1377 : CALL I1MCRY(RIGHT(1), J, 16291, 8388608, 0)
1378 : RIGHT(2) = 0
1379 : CALL I1MCRY(DIVER(1), J, 16292, 8388608, 0)
1380 : DIVER(2) = 0
1381 : CALL I1MCRY(LOG10(1), J, 16383, 10100890, 8715215)
1382 : CALL I1MCRY(LOG10(2), J, 0, 16226447, 9001388)
1383 : ELSE
1384 : WRITE(std_out,9000)
1385 : STOP 779
1386 : END IF
1387 : ELSE
1388 : WRITE(std_out,9000)
1389 : STOP 779
1390 : END IF
1391 : END IF
1392 0 : SC = 987
1393 : END IF
1394 : !* SANITY CHECK
1395 0 : IF (DMACH(4) .GE. 1.0D0) STOP 778
1396 0 : IF (I .LT. 1 .OR. I .GT. 5) THEN
1397 0 : WRITE(std_out,*) 'D1MACH(I): I =',I,' is out of bounds.'
1398 0 : STOP
1399 : END IF
1400 0 : D1MACH = DMACH(I)
1401 : RETURN
1402 : 9000 FORMAT(/' Adjust D1MACH by uncommenting data statements'/ &
1403 : &' appropriate for your machine.')
1404 : !* /* Standard C source for D1MACH -- remove the * in column 1 */
1405 : !*#include <stdio.h>
1406 : !*#include <float.h>
1407 : !*#include <math.h>
1408 : !*double d1mach_(long *i)
1409 : !*{
1410 : !* switch(*i){
1411 : !* case 1: return DBL_MIN;
1412 : !* case 2: return DBL_MAX;
1413 : !* case 3: return DBL_EPSILON/FLT_RADIX;
1414 : !* case 4: return DBL_EPSILON;
1415 : !* case 5: return log10(FLT_RADIX);
1416 : !* }
1417 : !* fprintf(stderr, "invalid argument: d1mach(%ld)\n", *i);
1418 : !* exit(1); return 0; /* some compilers demand return values */
1419 : !*}
1420 : END FUNCTION D1MACH
1421 :
1422 :
1423 : SUBROUTINE I1MCRY(A, A1, B, C, D)
1424 : !**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES ****
1425 : INTEGER A, A1, B, C, D
1426 : A1 = 16777216*B + C
1427 : A = 16777216*A1 + D
1428 : END SUBROUTINE I1MCRY
1429 :
1430 0 : SUBROUTINE ZMLT(AR, AI, BR, BI, CR, CI)
1431 : !C***BEGIN PROLOGUE ZMLT
1432 : !C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
1433 : !C
1434 : !C DOUBLE PRECISION COMPLEX MULTIPLY, C=A*B.
1435 : !C
1436 : !C***ROUTINES CALLED (NONE)
1437 : !C***END PROLOGUE ZMLT
1438 : DOUBLE PRECISION AR, AI, BR, BI, CR, CI, CA, CB
1439 0 : CA = AR*BR - AI*BI
1440 0 : CB = AR*BI + AI*BR
1441 0 : CR = CA
1442 0 : CI = CB
1443 0 : RETURN
1444 : END SUBROUTINE ZMLT
1445 :
1446 0 : SUBROUTINE AZLOG(AR, AI, BR, BI, IERR)
1447 : !C***BEGIN PROLOGUE AZLOG
1448 : !C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
1449 : !C
1450 : !C DOUBLE PRECISION COMPLEX LOGARITHM B=CLOG(A)
1451 : !C IERR=0,NORMAL RETURN IERR=1, Z=CMPLX(0.0,0.0)
1452 : !C***ROUTINES CALLED AZABS
1453 : !C***END PROLOGUE AZLOG
1454 : DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DHPI
1455 : !DOUBLE PRECISION AZABS
1456 : INTEGER IERR
1457 : DATA DPI , DHPI / 3.141592653589793238462643383D+0, &
1458 : & 1.570796326794896619231321696D+0/
1459 : !C
1460 0 : IERR=0
1461 0 : IF (AR.EQ.0.0D+0) GO TO 10
1462 0 : IF (AI.EQ.0.0D+0) GO TO 20
1463 0 : DTHETA = DATAN(AI/AR)
1464 0 : IF (DTHETA.LE.0.0D+0) GO TO 40
1465 0 : IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI
1466 0 : GO TO 50
1467 0 : 10 IF (AI.EQ.0.0D+0) GO TO 60
1468 0 : BI = DHPI
1469 0 : BR = DLOG(DABS(AI))
1470 0 : IF (AI.LT.0.0D+0) BI = -BI
1471 0 : RETURN
1472 0 : 20 IF (AR.GT.0.0D+0) GO TO 30
1473 0 : BR = DLOG(DABS(AR))
1474 0 : BI = DPI
1475 0 : RETURN
1476 0 : 30 BR = DLOG(AR)
1477 0 : BI = 0.0D+0
1478 0 : RETURN
1479 0 : 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI
1480 0 : 50 ZM = AZABS(AR,AI)
1481 0 : BR = DLOG(ZM)
1482 0 : BI = DTHETA
1483 0 : RETURN
1484 : 60 CONTINUE
1485 0 : IERR=1
1486 0 : RETURN
1487 : END SUBROUTINE AZLOG
1488 :
1489 :
1490 0 : DOUBLE PRECISION FUNCTION DGAMLN(Z,IERR)
1491 : !C***BEGIN PROLOGUE DGAMLN
1492 : !C***DATE WRITTEN 830501 (YYMMDD)
1493 : !C***REVISION DATE 830501 (YYMMDD)
1494 : !C***CATEGORY NO. B5F
1495 : !C***KEYWORDS GAMMA FUNCTION,LOGARITHM OF GAMMA FUNCTION
1496 : !C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
1497 : !C***PURPOSE TO COMPUTE THE LOGARITHM OF THE GAMMA FUNCTION
1498 : !C***DESCRIPTION
1499 : !C
1500 : !C **** A DOUBLE PRECISION ROUTINE ****
1501 : !C DGAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR
1502 : !C Z.GT.0. THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES
1503 : !C GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION
1504 : !C G(Z+1)=Z*G(Z) FOR Z.LE.ZMIN. THE FUNCTION WAS MADE AS
1505 : !C PORTABLE AS POSSIBLE BY COMPUTIMG ZMIN FROM THE NUMBER OF BASE
1506 : !C 10 DIGITS IN A WORD, RLN=AMAX1(-ALOG10(R1MACH(4)),0.5E-18)
1507 : !C LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY.
1508 : !C
1509 : !C SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100
1510 : !C VALUES IS USED FOR SPEED OF EXECUTION.
1511 : !C
1512 : !C DESCRIPTION OF ARGUMENTS
1513 : !C
1514 : !C INPUT Z IS D0UBLE PRECISION
1515 : !C Z - ARGUMENT, Z.GT.0.0D0
1516 : !C
1517 : !C OUTPUT DGAMLN IS DOUBLE PRECISION
1518 : !C DGAMLN - NATURAL LOG OF THE GAMMA FUNCTION AT Z.NE.0.0D0
1519 : !C IERR - ERROR FLAG
1520 : !C IERR=0, NORMAL RETURN, COMPUTATION COMPLETED
1521 : !C IERR=1, Z.LE.0.0D0, NO COMPUTATION
1522 : !C
1523 : !C
1524 : !C***REFERENCES COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
1525 : !C BY D. E. AMOS, SAND83-0083, MAY, 1983.
1526 : !C***ROUTINES CALLED I1MACH,D1MACH
1527 : !C***END PROLOGUE DGAMLN
1528 : DOUBLE PRECISION CF, CON, FLN, FZ, GLN, RLN, S, TLG, TRM, TST, &
1529 : & T1, WDTOL, Z, ZDMY, ZINC, ZM, ZMIN, ZP, ZSQ!, D1MACH
1530 : INTEGER I, IERR, I1M, K, MZ, NZ!, I1MACH
1531 : DIMENSION CF(22), GLN(100)
1532 : !C LNGAMMA(N), N=1,100
1533 : DATA GLN(1), GLN(2), GLN(3), GLN(4), GLN(5), GLN(6), GLN(7),&
1534 : & GLN(8), GLN(9), GLN(10), GLN(11), GLN(12), GLN(13), GLN(14), &
1535 : & GLN(15), GLN(16), GLN(17), GLN(18), GLN(19), GLN(20), &
1536 : & GLN(21), GLN(22)/ &
1537 : & 0.00000000000000000D+00, 0.00000000000000000D+00, &
1538 : & 6.93147180559945309D-01, 1.79175946922805500D+00, &
1539 : & 3.17805383034794562D+00, 4.78749174278204599D+00, &
1540 : & 6.57925121201010100D+00, 8.52516136106541430D+00, &
1541 : & 1.06046029027452502D+01, 1.28018274800814696D+01, &
1542 : & 1.51044125730755153D+01, 1.75023078458738858D+01, &
1543 : & 1.99872144956618861D+01, 2.25521638531234229D+01, &
1544 : & 2.51912211827386815D+01, 2.78992713838408916D+01, &
1545 : & 3.06718601060806728D+01, 3.35050734501368889D+01, &
1546 : & 3.63954452080330536D+01, 3.93398841871994940D+01, &
1547 : & 4.23356164607534850D+01, 4.53801388984769080D+01/
1548 : DATA GLN(23), GLN(24), GLN(25), GLN(26), GLN(27), GLN(28), &
1549 : & GLN(29), GLN(30), GLN(31), GLN(32), GLN(33), GLN(34), &
1550 : & GLN(35), GLN(36), GLN(37), GLN(38), GLN(39), GLN(40), &
1551 : & GLN(41), GLN(42), GLN(43), GLN(44)/ &
1552 : & 4.84711813518352239D+01, 5.16066755677643736D+01, &
1553 : & 5.47847293981123192D+01, 5.80036052229805199D+01, &
1554 : & 6.12617017610020020D+01, 6.45575386270063311D+01, &
1555 : & 6.78897431371815350D+01, 7.12570389671680090D+01, &
1556 : & 7.46582363488301644D+01, 7.80922235533153106D+01, &
1557 : & 8.15579594561150372D+01, 8.50544670175815174D+01, &
1558 : & 8.85808275421976788D+01, 9.21361756036870925D+01, &
1559 : & 9.57196945421432025D+01, 9.93306124547874269D+01, &
1560 : & 1.02968198614513813D+02, 1.06631760260643459D+02, &
1561 : & 1.10320639714757395D+02, 1.14034211781461703D+02, &
1562 : & 1.17771881399745072D+02, 1.21533081515438634D+02/
1563 : DATA GLN(45), GLN(46), GLN(47), GLN(48), GLN(49), GLN(50), &
1564 : & GLN(51), GLN(52), GLN(53), GLN(54), GLN(55), GLN(56), &
1565 : & GLN(57), GLN(58), GLN(59), GLN(60), GLN(61), GLN(62), &
1566 : & GLN(63), GLN(64), GLN(65), GLN(66)/ &
1567 : & 1.25317271149356895D+02, 1.29123933639127215D+02, &
1568 : & 1.32952575035616310D+02, 1.36802722637326368D+02, &
1569 : & 1.40673923648234259D+02, 1.44565743946344886D+02, &
1570 : & 1.48477766951773032D+02, 1.52409592584497358D+02, &
1571 : & 1.56360836303078785D+02, 1.60331128216630907D+02, &
1572 : & 1.64320112263195181D+02, 1.68327445448427652D+02, &
1573 : & 1.72352797139162802D+02, 1.76395848406997352D+02, &
1574 : & 1.80456291417543771D+02, 1.84533828861449491D+02, &
1575 : & 1.88628173423671591D+02, 1.92739047287844902D+02, &
1576 : & 1.96866181672889994D+02, 2.01009316399281527D+02, &
1577 : & 2.05168199482641199D+02, 2.09342586752536836D+02/
1578 : DATA GLN(67), GLN(68), GLN(69), GLN(70), GLN(71), GLN(72), &
1579 : & GLN(73), GLN(74), GLN(75), GLN(76), GLN(77), GLN(78), &
1580 : & GLN(79), GLN(80), GLN(81), GLN(82), GLN(83), GLN(84), &
1581 : & GLN(85), GLN(86), GLN(87), GLN(88)/ &
1582 : & 2.13532241494563261D+02, 2.17736934113954227D+02, &
1583 : & 2.21956441819130334D+02, 2.26190548323727593D+02, &
1584 : & 2.30439043565776952D+02, 2.34701723442818268D+02, &
1585 : & 2.38978389561834323D+02, 2.43268849002982714D+02, &
1586 : & 2.47572914096186884D+02, 2.51890402209723194D+02, &
1587 : & 2.56221135550009525D+02, 2.60564940971863209D+02, &
1588 : & 2.64921649798552801D+02, 2.69291097651019823D+02, &
1589 : & 2.73673124285693704D+02, 2.78067573440366143D+02, &
1590 : & 2.82474292687630396D+02, 2.86893133295426994D+02, &
1591 : & 2.91323950094270308D+02, 2.95766601350760624D+02, &
1592 : & 3.00220948647014132D+02, 3.04686856765668715D+02/
1593 : DATA GLN(89), GLN(90), GLN(91), GLN(92), GLN(93), GLN(94), &
1594 : & GLN(95), GLN(96), GLN(97), GLN(98), GLN(99), GLN(100)/&
1595 : & 3.09164193580146922D+02, 3.13652829949879062D+02, &
1596 : & 3.18152639620209327D+02, 3.22663499126726177D+02, &
1597 : & 3.27185287703775217D+02, 3.31717887196928473D+02, &
1598 : & 3.36261181979198477D+02, 3.40815058870799018D+02, &
1599 : & 3.45379407062266854D+02, 3.49954118040770237D+02, &
1600 : & 3.54539085519440809D+02, 3.59134205369575399D+02/
1601 : !C COEFFICIENTS OF ASYMPTOTIC EXPANSION
1602 : DATA CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), CF(8), &
1603 : & CF(9), CF(10), CF(11), CF(12), CF(13), CF(14), CF(15), &
1604 : & CF(16), CF(17), CF(18), CF(19), CF(20), CF(21), CF(22)/ &
1605 : & 8.33333333333333333D-02, -2.77777777777777778D-03, &
1606 : & 7.93650793650793651D-04, -5.95238095238095238D-04, &
1607 : & 8.41750841750841751D-04, -1.91752691752691753D-03, &
1608 : & 6.41025641025641026D-03, -2.95506535947712418D-02, &
1609 : & 1.79644372368830573D-01, -1.39243221690590112D+00, &
1610 : & 1.34028640441683920D+01, -1.56848284626002017D+02, &
1611 : & 2.19310333333333333D+03, -3.61087712537249894D+04, &
1612 : & 6.91472268851313067D+05, -1.52382215394074162D+07, &
1613 : & 3.82900751391414141D+08, -1.08822660357843911D+10, &
1614 : & 3.47320283765002252D+11, -1.23696021422692745D+13, &
1615 : & 4.88788064793079335D+14, -2.13203339609193739D+16/
1616 : !C
1617 : !C LN(2*PI)
1618 : DATA CON / 1.83787706640934548D+00/
1619 : !C
1620 : !C***FIRST EXECUTABLE STATEMENT DGAMLN
1621 0 : IERR=0
1622 0 : IF (Z.LE.0.0D0) GO TO 70
1623 0 : IF (Z.GT.101.0D0) GO TO 10
1624 0 : NZ = INT(SNGL(Z))
1625 0 : FZ = Z - FLOAT(NZ)
1626 0 : IF (FZ.GT.0.0D0) GO TO 10
1627 0 : IF (NZ.GT.100) GO TO 10
1628 0 : DGAMLN = GLN(NZ)
1629 0 : RETURN
1630 : 10 CONTINUE
1631 0 : WDTOL = D1MACH(4)
1632 0 : WDTOL = DMAX1(WDTOL,0.5D-18)
1633 0 : I1M = I1MACH(14)
1634 0 : RLN = D1MACH(5)*FLOAT(I1M)
1635 0 : FLN = DMIN1(RLN,20.0D0)
1636 0 : FLN = DMAX1(FLN,3.0D0)
1637 0 : FLN = FLN - 3.0D0
1638 0 : ZM = 1.8000D0 + 0.3875D0*FLN
1639 0 : MZ = INT(SNGL(ZM)) + 1
1640 0 : ZMIN = FLOAT(MZ)
1641 0 : ZDMY = Z
1642 0 : ZINC = 0.0D0
1643 0 : IF (Z.GE.ZMIN) GO TO 20
1644 0 : ZINC = ZMIN - FLOAT(NZ)
1645 0 : ZDMY = Z + ZINC
1646 : 20 CONTINUE
1647 0 : ZP = 1.0D0/ZDMY
1648 0 : T1 = CF(1)*ZP
1649 0 : S = T1
1650 0 : IF (ZP.LT.WDTOL) GO TO 40
1651 0 : ZSQ = ZP*ZP
1652 0 : TST = T1*WDTOL
1653 0 : DO 30 K=2,22
1654 0 : ZP = ZP*ZSQ
1655 0 : TRM = CF(K)*ZP
1656 0 : IF (DABS(TRM).LT.TST) GO TO 40
1657 0 : S = S + TRM
1658 0 : 30 CONTINUE
1659 : 40 CONTINUE
1660 0 : IF (ZINC.NE.0.0D0) GO TO 50
1661 0 : TLG = DLOG(Z)
1662 0 : DGAMLN = Z*(TLG-1.0D0) + 0.5D0*(CON-TLG) + S
1663 0 : RETURN
1664 : 50 CONTINUE
1665 0 : ZP = 1.0D0
1666 0 : NZ = INT(SNGL(ZINC))
1667 0 : DO 60 I=1,NZ
1668 0 : ZP = ZP*(Z+FLOAT(I-1))
1669 0 : 60 CONTINUE
1670 0 : TLG = DLOG(ZDMY)
1671 0 : DGAMLN = ZDMY*(TLG-1.0D0) - DLOG(ZP) + 0.5D0*(CON-TLG) + S
1672 0 : RETURN
1673 : !C
1674 : !C
1675 : 70 CONTINUE
1676 0 : IERR=1
1677 0 : RETURN
1678 : END FUNCTION DGAMLN
1679 :
1680 0 : INTEGER FUNCTION I1MACH(I)
1681 : INTEGER I
1682 : !C
1683 : !C I1MACH( 1) = THE STANDARD INPUT UNIT.
1684 : !C I1MACH( 2) = THE STANDARD OUTPUT UNIT.
1685 : !C I1MACH( 3) = THE STANDARD PUNCH UNIT.
1686 : !C I1MACH( 4) = THE STANDARD ERROR MESSAGE UNIT.
1687 : !C I1MACH( 5) = THE NUMBER OF BITS PER INTEGER STORAGE UNIT.
1688 : !C I1MACH( 6) = THE NUMBER OF CHARACTERS PER CHARACTER STORAGE UNIT.
1689 : !C INTEGERS HAVE FORM SIGN ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
1690 : !C I1MACH( 7) = A, THE BASE.
1691 : !C I1MACH( 8) = S, THE NUMBER OF BASE-A DIGITS.
1692 : !C I1MACH( 9) = A**S - 1, THE LARGEST MAGNITUDE.
1693 : !C FLOATS HAVE FORM SIGN (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
1694 : !C WHERE EMIN .LE. E .LE. EMAX.
1695 : !C I1MACH(10) = B, THE BASE.
1696 : !C SINGLE-PRECISION
1697 : !C I1MACH(11) = T, THE NUMBER OF BASE-B DIGITS.
1698 : !C I1MACH(12) = EMIN, THE SMALLEST EXPONENT E.
1699 : !C I1MACH(13) = EMAX, THE LARGEST EXPONENT E.
1700 : !C DOUBLE-PRECISION
1701 : !C I1MACH(14) = T, THE NUMBER OF BASE-B DIGITS.
1702 : !C I1MACH(15) = EMIN, THE SMALLEST EXPONENT E.
1703 : !C I1MACH(16) = EMAX, THE LARGEST EXPONENT E.
1704 : !C
1705 : INTEGER IMACH(16), OUTPUT, SC, SMALL(2)
1706 : SAVE IMACH, SC
1707 : REAL RMACH
1708 : EQUIVALENCE (IMACH(4),OUTPUT), (RMACH,SMALL(1))
1709 : INTEGER I3, J, K, T3E(3)
1710 : DATA T3E(1) / 9777664 /
1711 : DATA T3E(2) / 5323660 /
1712 : DATA T3E(3) / 46980 /
1713 : !C THIS VERSION ADAPTS AUTOMATICALLY TO MOST CURRENT MACHINES,
1714 : !C INCLUDING AUTO-DOUBLE COMPILERS.
1715 : !C TO COMPILE ON OLDER MACHINES, ADD A C IN COLUMN 1
1716 : !C ON THE NEXT LINE
1717 : DATA SC/0/
1718 : !C AND REMOVE THE C FROM COLUMN 1 IN ONE OF THE SECTIONS BELOW.
1719 : !C CONSTANTS FOR EVEN OLDER MACHINES CAN BE OBTAINED BY
1720 : !C mail netlib@research.bell-labs.com
1721 : !C send old1mach from blas
1722 : !C PLEASE SEND CORRECTIONS TO dmg OR ehg@bell-labs.com.
1723 : !C
1724 : !C MACHINE CONSTANTS FOR THE HONEYWELL DPS 8/70 SERIES.
1725 : !C
1726 : !C DATA IMACH( 1) / 5 /
1727 : !C DATA IMACH( 2) / 6 /
1728 : !C DATA IMACH( 3) / 43 /
1729 : !C DATA IMACH( 4) / 6 /
1730 : !C DATA IMACH( 5) / 36 /
1731 : !C DATA IMACH( 6) / 4 /
1732 : !C DATA IMACH( 7) / 2 /
1733 : !C DATA IMACH( 8) / 35 /
1734 : !C DATA IMACH( 9) / O377777777777 /
1735 : !C DATA IMACH(10) / 2 /
1736 : !C DATA IMACH(11) / 27 /
1737 : !C DATA IMACH(12) / -127 /
1738 : !C DATA IMACH(13) / 127 /
1739 : !C DATA IMACH(14) / 63 /
1740 : !C DATA IMACH(15) / -127 /
1741 : !C DATA IMACH(16) / 127 /, SC/987/
1742 : !C
1743 : !C MACHINE CONSTANTS FOR PDP-11 FORTRANS SUPPORTING
1744 : !C 32-BIT INTEGER ARITHMETIC.
1745 : !C
1746 : !C DATA IMACH( 1) / 5 /
1747 : !C DATA IMACH( 2) / 6 /
1748 : !C DATA IMACH( 3) / 7 /
1749 : !C DATA IMACH( 4) / 6 /
1750 : !C DATA IMACH( 5) / 32 /
1751 : !C DATA IMACH( 6) / 4 /
1752 : !C DATA IMACH( 7) / 2 /
1753 : !C DATA IMACH( 8) / 31 /
1754 : !C DATA IMACH( 9) / 2147483647 /
1755 : !C DATA IMACH(10) / 2 /
1756 : !C DATA IMACH(11) / 24 /
1757 : !C DATA IMACH(12) / -127 /
1758 : !C DATA IMACH(13) / 127 /
1759 : !C DATA IMACH(14) / 56 /
1760 : !C DATA IMACH(15) / -127 /
1761 : !C DATA IMACH(16) / 127 /, SC/987/
1762 : !C
1763 : !C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES.
1764 : !C
1765 : !C NOTE THAT THE PUNCH UNIT, I1MACH(3), HAS BEEN SET TO 7
1766 : !C WHICH IS APPROPRIATE FOR THE UNIVAC-FOR SYSTEM.
1767 : !C IF YOU HAVE THE UNIVAC-FTN SYSTEM, SET IT TO 1.
1768 : !C
1769 : !C DATA IMACH( 1) / 5 /
1770 : !C DATA IMACH( 2) / 6 /
1771 : !C DATA IMACH( 3) / 7 /
1772 : !C DATA IMACH( 4) / 6 /
1773 : !C DATA IMACH( 5) / 36 /
1774 : !C DATA IMACH( 6) / 6 /
1775 : !C DATA IMACH( 7) / 2 /
1776 : !C DATA IMACH( 8) / 35 /
1777 : !C DATA IMACH( 9) / O377777777777 /
1778 : !C DATA IMACH(10) / 2 /
1779 : !C DATA IMACH(11) / 27 /
1780 : !C DATA IMACH(12) / -128 /
1781 : !C DATA IMACH(13) / 127 /
1782 : !C DATA IMACH(14) / 60 /
1783 : !C DATA IMACH(15) /-1024 /
1784 : !C DATA IMACH(16) / 1023 /, SC/987/
1785 : !C
1786 0 : IF (SC .NE. 987) THEN
1787 : !* *** CHECK FOR AUTODOUBLE ***
1788 : SMALL(2) = 0
1789 : RMACH = 1E13
1790 : IF (SMALL(2) .NE. 0) THEN
1791 : !* *** AUTODOUBLED ***
1792 : IF ( (SMALL(1) .EQ. 1117925532 &
1793 : & .AND. SMALL(2) .EQ. -448790528) &
1794 : & .OR. (SMALL(2) .EQ. 1117925532 &
1795 : & .AND. SMALL(1) .EQ. -448790528)) THEN
1796 : !* *** IEEE ***
1797 : IMACH(10) = 2
1798 : IMACH(14) = 53
1799 : IMACH(15) = -1021
1800 : IMACH(16) = 1024
1801 : ELSE IF ( SMALL(1) .EQ. -2065213935 &
1802 : & .AND. SMALL(2) .EQ. 10752) THEN
1803 : !* *** VAX WITH D_FLOATING ***
1804 : IMACH(10) = 2
1805 : IMACH(14) = 56
1806 : IMACH(15) = -127
1807 : IMACH(16) = 127
1808 : ELSE IF ( SMALL(1) .EQ. 1267827943 &
1809 : & .AND. SMALL(2) .EQ. 704643072) THEN
1810 : !* *** IBM MAINFRAME ***
1811 : IMACH(10) = 16
1812 : IMACH(14) = 14
1813 : IMACH(15) = -64
1814 : IMACH(16) = 63
1815 : ELSE
1816 : WRITE(std_out,9010)
1817 : STOP 777
1818 : END IF
1819 : IMACH(11) = IMACH(14)
1820 : IMACH(12) = IMACH(15)
1821 : IMACH(13) = IMACH(16)
1822 : ELSE
1823 : RMACH = 1234567.
1824 : IF (SMALL(1) .EQ. 1234613304) THEN
1825 : !* *** IEEE ***
1826 0 : IMACH(10) = 2
1827 0 : IMACH(11) = 24
1828 0 : IMACH(12) = -125
1829 0 : IMACH(13) = 128
1830 0 : IMACH(14) = 53
1831 0 : IMACH(15) = -1021
1832 0 : IMACH(16) = 1024
1833 0 : SC = 987
1834 : ELSE IF (SMALL(1) .EQ. -1271379306) THEN
1835 : !* *** VAX ***
1836 : IMACH(10) = 2
1837 : IMACH(11) = 24
1838 : IMACH(12) = -127
1839 : IMACH(13) = 127
1840 : IMACH(14) = 56
1841 : IMACH(15) = -127
1842 : IMACH(16) = 127
1843 : SC = 987
1844 : ELSE IF (SMALL(1) .EQ. 1175639687) THEN
1845 : !* *** IBM MAINFRAME ***
1846 : IMACH(10) = 16
1847 : IMACH(11) = 6
1848 : IMACH(12) = -64
1849 : IMACH(13) = 63
1850 : IMACH(14) = 14
1851 : IMACH(15) = -64
1852 : IMACH(16) = 63
1853 : SC = 987
1854 : ELSE IF (SMALL(1) .EQ. 1251390520) THEN
1855 : !* *** CONVEX C-1 ***
1856 : IMACH(10) = 2
1857 : IMACH(11) = 24
1858 : IMACH(12) = -128
1859 : IMACH(13) = 127
1860 : IMACH(14) = 53
1861 : IMACH(15) = -1024
1862 : IMACH(16) = 1023
1863 : ELSE
1864 : DO 10 I3 = 1, 3
1865 : J = SMALL(1) / 10000000
1866 : K = SMALL(1) - 10000000*J
1867 : IF (K .NE. T3E(I3)) GO TO 20
1868 : SMALL(1) = J
1869 : 10 CONTINUE
1870 : !* *** CRAY T3E ***
1871 : IMACH( 1) = 5
1872 : IMACH( 2) = 6
1873 : IMACH( 3) = 0
1874 : IMACH( 4) = 0
1875 : IMACH( 5) = 64
1876 : IMACH( 6) = 8
1877 : IMACH( 7) = 2
1878 : IMACH( 8) = 63
1879 : CALL I1MCR1(IMACH(9), K, 32767, 16777215, 16777215)
1880 : IMACH(10) = 2
1881 : IMACH(11) = 53
1882 : IMACH(12) = -1021
1883 : IMACH(13) = 1024
1884 : IMACH(14) = 53
1885 : IMACH(15) = -1021
1886 : IMACH(16) = 1024
1887 : GO TO 35
1888 : 20 CALL I1MCR1(J, K, 16405, 9876536, 0)
1889 : IF (SMALL(1) .NE. J) THEN
1890 : WRITE(std_out,9020)
1891 : STOP 777
1892 : END IF
1893 : !* *** CRAY 1, XMP, 2, AND 3 ***
1894 : IMACH(1) = 5
1895 : IMACH(2) = 6
1896 : IMACH(3) = 102
1897 : IMACH(4) = 6
1898 : IMACH(5) = 46
1899 : IMACH(6) = 8
1900 : IMACH(7) = 2
1901 : IMACH(8) = 45
1902 : CALL I1MCR1(IMACH(9), K, 0, 4194303, 16777215)
1903 : IMACH(10) = 2
1904 : IMACH(11) = 47
1905 : IMACH(12) = -8188
1906 : IMACH(13) = 8189
1907 : IMACH(14) = 94
1908 : IMACH(15) = -8141
1909 : IMACH(16) = 8189
1910 : GO TO 35
1911 : END IF
1912 : END IF
1913 0 : IMACH( 1) = 5
1914 0 : IMACH( 2) = 6
1915 0 : IMACH( 3) = 7
1916 0 : IMACH( 4) = 6
1917 0 : IMACH( 5) = 32
1918 0 : IMACH( 6) = 4
1919 0 : IMACH( 7) = 2
1920 0 : IMACH( 8) = 31
1921 0 : IMACH( 9) = 2147483647
1922 : 35 SC = 987
1923 : END IF
1924 : 9010 FORMAT(/' Adjust autodoubled I1MACH by uncommenting data'/ &
1925 : & ' statements appropriate for your machine and setting'/ &
1926 : & ' IMACH(I) = IMACH(I+3) for I = 11, 12, and 13.')
1927 : 9020 FORMAT(/' Adjust I1MACH by uncommenting data statements'/ &
1928 : & ' appropriate for your machine.')
1929 0 : IF (I .LT. 1 .OR. I .GT. 16) GO TO 40
1930 0 : I1MACH = IMACH(I)
1931 0 : RETURN
1932 0 : 40 WRITE(std_out,*) 'I1MACH(I): I =',I,' is out of bounds.'
1933 0 : STOP
1934 : !* /* C source for I1MACH -- remove the * in column 1 */
1935 : !* /* Note that some values may need changing. */
1936 : !*#include <stdio.h>
1937 : !*#include <float.h>
1938 : !*#include <limits.h>
1939 : !*#include <math.h>
1940 : !*
1941 : !*long i1mach_(long *i)
1942 : !*{
1943 : !* switch(*i){
1944 : !* case 1: return 5; /* standard input */
1945 : !* case 2: return 6; /* standard output */
1946 : !* case 3: return 7; /* standard punch */
1947 : !* case 4: return 0; /* standard error */
1948 : !* case 5: return 32; /* bits per integer */
1949 : !* case 6: return sizeof(int);
1950 : !* case 7: return 2; /* base for integers */
1951 : !* case 8: return 31; /* digits of integer base */
1952 : !* case 9: return LONG_MAX;
1953 : !* case 10: return FLT_RADIX;
1954 : !* case 11: return FLT_MANT_DIG;
1955 : !* case 12: return FLT_MIN_EXP;
1956 : !* case 13: return FLT_MAX_EXP;
1957 : !* case 14: return DBL_MANT_DIG;
1958 : !* case 15: return DBL_MIN_EXP;
1959 : !* case 16: return DBL_MAX_EXP;
1960 : !* }
1961 : !* fprintf(stderr, "invalid argument: i1mach(%ld)\n", *i);
1962 : !* exit(1);return 0; /* some compilers demand return values */
1963 : !*}
1964 : END FUNCTION I1MACH
1965 :
1966 : SUBROUTINE I1MCR1(A, A1, B, C, D)
1967 : !**** SPECIAL COMPUTATION FOR OLD CRAY MACHINES ****
1968 : INTEGER A, A1, B, C, D
1969 : A1 = 16777216*B + C
1970 : A = 16777216*A1 + D
1971 : END SUBROUTINE I1MCR1
1972 :
1973 0 : SUBROUTINE ZUCHK(YR, YI, NZ, ASCLE, TOL)
1974 : !C***BEGIN PROLOGUE ZUCHK
1975 : !C***REFER TO ZSERI,ZUOIK,ZUNK1,ZUNK2,ZUNI1,ZUNI2,ZKSCL
1976 : !C
1977 : !C Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN
1978 : !C EXP(-ALIM)=ASCLE=1.0E+3*D1MACH(1)/TOL. THE TEST IS MADE TO SEE
1979 : !C IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDERFLOW
1980 : !C WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED
1981 : !C IF THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE
1982 : !C OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE
1983 : !C ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED.
1984 : !C
1985 : !C***ROUTINES CALLED (NONE)
1986 : !C***END PROLOGUE ZUCHK
1987 : !C
1988 : !C COMPLEX Y
1989 : DOUBLE PRECISION ASCLE, SS, ST, TOL, WR, WI, YR, YI
1990 : INTEGER NZ
1991 0 : NZ = 0
1992 0 : WR = DABS(YR)
1993 0 : WI = DABS(YI)
1994 0 : ST = DMIN1(WR,WI)
1995 0 : IF (ST.GT.ASCLE) RETURN
1996 0 : SS = DMAX1(WR,WI)
1997 0 : ST = ST/TOL
1998 0 : IF (SS.LT.ST) NZ = 1
1999 : RETURN
2000 : END SUBROUTINE ZUCHK
2001 :
2002 0 : SUBROUTINE ZDIV(AR, AI, BR, BI, CR, CI)
2003 : !C***BEGIN PROLOGUE ZDIV
2004 : !C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
2005 : !C
2006 : !C DOUBLE PRECISION COMPLEX DIVIDE C=A/B.
2007 : !C
2008 : !C***ROUTINES CALLED AZABS
2009 : !C***END PROLOGUE ZDIV
2010 : DOUBLE PRECISION AR, AI, BR, BI, CR, CI, BM, CA, CB, CC, CD
2011 : !DOUBLE PRECISION AZABS
2012 0 : BM = 1.0D0/AZABS(BR,BI)
2013 0 : CC = BR*BM
2014 0 : CD = BI*BM
2015 0 : CA = (AR*CC+AI*CD)*BM
2016 0 : CB = (AI*CC-AR*CD)*BM
2017 0 : CR = CA
2018 0 : CI = CB
2019 0 : RETURN
2020 : END SUBROUTINE ZDIV
2021 :
2022 :
2023 0 : SUBROUTINE ZASYI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, RL, TOL, ELIM, &
2024 : & ALIM)
2025 : !C***BEGIN PROLOGUE ZASYI
2026 : !C***REFER TO ZBESI,ZBESK
2027 : !C
2028 : !C ZASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY
2029 : !C MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z) IN THE
2030 : !C REGION CABS(Z).GT.MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL RETURN.
2031 : !C NZ.LT.0 INDICATES AN OVERFLOW ON KODE=1.
2032 : !C
2033 : !C***ROUTINES CALLED D1MACH,AZABS,ZDIV,AZEXP,ZMLT,AZSQRT
2034 : !C***END PROLOGUE ZASYI
2035 : !C COMPLEX AK1,CK,CONE,CS1,CS2,CZ,CZERO,DK,EZ,P1,RZ,S2,Y,Z
2036 : DOUBLE PRECISION AA, AEZ, AK, AK1I, AK1R, ALIM, ARG, ARM, ATOL, &
2037 : & AZ, BB, BK, CKI, CKR, CONEI, CONER, CS1I, CS1R, CS2I, CS2R, CZI, &
2038 : & CZR, DFNU, DKI, DKR, DNU2, ELIM, EZI, EZR, FDN, FNU, PI, P1I, &
2039 : & P1R, RAZ, RL, RTPI, RTR1, RZI, RZR, S, SGN, SQK, STI, STR, S2I, &
2040 : & S2R, TOL, TZI, TZR, YI, YR, ZEROI, ZEROR, ZI, ZR!, D1MACH, AZABS
2041 : INTEGER I, IB, IL, INU, J, JL, K, KODE, KODED, M, N, NN, NZ
2042 : DIMENSION YR(N), YI(N)
2043 : DATA PI, RTPI /3.14159265358979324D0 , 0.159154943091895336D0 /
2044 : DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
2045 : !C
2046 0 : NZ = 0
2047 0 : AZ = AZABS(ZR,ZI)
2048 0 : ARM = 1.0D+3*D1MACH(1)
2049 0 : RTR1 = DSQRT(ARM)
2050 0 : IL = MIN0(2,N)
2051 0 : DFNU = FNU + DBLE(FLOAT(N-IL))
2052 : !C-----------------------------------------------------------------------
2053 : !C OVERFLOW TEST
2054 : !C-----------------------------------------------------------------------
2055 0 : RAZ = 1.0D0/AZ
2056 0 : STR = ZR*RAZ
2057 0 : STI = -ZI*RAZ
2058 0 : AK1R = RTPI*STR*RAZ
2059 0 : AK1I = RTPI*STI*RAZ
2060 0 : CALL AZSQRT(AK1R, AK1I, AK1R, AK1I)
2061 0 : CZR = ZR
2062 0 : CZI = ZI
2063 0 : IF (KODE.NE.2) GO TO 10
2064 0 : CZR = ZEROR
2065 0 : CZI = ZI
2066 : 10 CONTINUE
2067 0 : IF (DABS(CZR).GT.ELIM) GO TO 100
2068 0 : DNU2 = DFNU + DFNU
2069 0 : KODED = 1
2070 0 : IF ((DABS(CZR).GT.ALIM) .AND. (N.GT.2)) GO TO 20
2071 0 : KODED = 0
2072 0 : CALL AZEXP(CZR, CZI, STR, STI)
2073 0 : CALL ZMLT(AK1R, AK1I, STR, STI, AK1R, AK1I)
2074 : 20 CONTINUE
2075 0 : FDN = 0.0D0
2076 0 : IF (DNU2.GT.RTR1) FDN = DNU2*DNU2
2077 0 : EZR = ZR*8.0D0
2078 0 : EZI = ZI*8.0D0
2079 : !C-----------------------------------------------------------------------
2080 : !C WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO THE
2081 : !C FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF THE
2082 : !C EXPANSION FOR THE IMAGINARY PART.
2083 : !C-----------------------------------------------------------------------
2084 0 : AEZ = 8.0D0*AZ
2085 0 : S = TOL/AEZ
2086 0 : JL = INT(SNGL(RL+RL)) + 2
2087 0 : P1R = ZEROR
2088 0 : P1I = ZEROI
2089 0 : IF (ZI.EQ.0.0D0) GO TO 30
2090 : !C-----------------------------------------------------------------------
2091 : !C CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF
2092 : !C SIGNIFICANCE WHEN FNU OR N IS LARGE
2093 : !C-----------------------------------------------------------------------
2094 0 : INU = INT(SNGL(FNU))
2095 0 : ARG = (FNU-DBLE(FLOAT(INU)))*PI
2096 0 : INU = INU + N - IL
2097 0 : AK = -DSIN(ARG)
2098 0 : BK = DCOS(ARG)
2099 0 : IF (ZI.LT.0.0D0) BK = -BK
2100 0 : P1R = AK
2101 0 : P1I = BK
2102 0 : IF (MOD(INU,2).EQ.0) GO TO 30
2103 0 : P1R = -P1R
2104 0 : P1I = -P1I
2105 : 30 CONTINUE
2106 0 : DO 70 K=1,IL
2107 0 : SQK = FDN - 1.0D0
2108 0 : ATOL = S*DABS(SQK)
2109 0 : SGN = 1.0D0
2110 0 : CS1R = CONER
2111 0 : CS1I = CONEI
2112 0 : CS2R = CONER
2113 0 : CS2I = CONEI
2114 0 : CKR = CONER
2115 0 : CKI = CONEI
2116 0 : AK = 0.0D0
2117 0 : AA = 1.0D0
2118 0 : BB = AEZ
2119 0 : DKR = EZR
2120 0 : DKI = EZI
2121 0 : DO 40 J=1,JL
2122 0 : CALL ZDIV(CKR, CKI, DKR, DKI, STR, STI)
2123 0 : CKR = STR*SQK
2124 0 : CKI = STI*SQK
2125 0 : CS2R = CS2R + CKR
2126 0 : CS2I = CS2I + CKI
2127 0 : SGN = -SGN
2128 0 : CS1R = CS1R + CKR*SGN
2129 0 : CS1I = CS1I + CKI*SGN
2130 0 : DKR = DKR + EZR
2131 0 : DKI = DKI + EZI
2132 0 : AA = AA*DABS(SQK)/BB
2133 0 : BB = BB + AEZ
2134 0 : AK = AK + 8.0D0
2135 0 : SQK = SQK - AK
2136 0 : IF (AA.LE.ATOL) GO TO 50
2137 0 : 40 CONTINUE
2138 0 : GO TO 110
2139 : 50 CONTINUE
2140 0 : S2R = CS1R
2141 0 : S2I = CS1I
2142 0 : IF (ZR+ZR.GE.ELIM) GO TO 60
2143 0 : TZR = ZR + ZR
2144 0 : TZI = ZI + ZI
2145 0 : CALL AZEXP(-TZR, -TZI, STR, STI)
2146 0 : CALL ZMLT(STR, STI, P1R, P1I, STR, STI)
2147 0 : CALL ZMLT(STR, STI, CS2R, CS2I, STR, STI)
2148 0 : S2R = S2R + STR
2149 0 : S2I = S2I + STI
2150 : 60 CONTINUE
2151 0 : FDN = FDN + 8.0D0*DFNU + 4.0D0
2152 0 : P1R = -P1R
2153 0 : P1I = -P1I
2154 0 : M = N - IL + K
2155 0 : YR(M) = S2R*AK1R - S2I*AK1I
2156 0 : YI(M) = S2R*AK1I + S2I*AK1R
2157 0 : 70 CONTINUE
2158 0 : IF (N.LE.2) RETURN
2159 0 : NN = N
2160 0 : K = NN - 2
2161 0 : AK = DBLE(FLOAT(K))
2162 0 : STR = ZR*RAZ
2163 0 : STI = -ZI*RAZ
2164 0 : RZR = (STR+STR)*RAZ
2165 0 : RZI = (STI+STI)*RAZ
2166 0 : IB = 3
2167 0 : DO 80 I=IB,NN
2168 0 : YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2)
2169 0 : YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2)
2170 0 : AK = AK - 1.0D0
2171 0 : K = K - 1
2172 0 : 80 CONTINUE
2173 0 : IF (KODED.EQ.0) RETURN
2174 0 : CALL AZEXP(CZR, CZI, CKR, CKI)
2175 0 : DO 90 I=1,NN
2176 0 : STR = YR(I)*CKR - YI(I)*CKI
2177 0 : YI(I) = YR(I)*CKI + YI(I)*CKR
2178 0 : YR(I) = STR
2179 0 : 90 CONTINUE
2180 0 : RETURN
2181 : 100 CONTINUE
2182 0 : NZ = -1
2183 0 : RETURN
2184 : 110 CONTINUE
2185 0 : NZ=-2
2186 0 : RETURN
2187 : END SUBROUTINE ZASYI
2188 :
2189 0 : SUBROUTINE AZSQRT(AR, AI, BR, BI)
2190 : !C***BEGIN PROLOGUE AZSQRT
2191 : !C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
2192 : !C
2193 : !C DOUBLE PRECISION COMPLEX SQUARE ROOT, B=CSQRT(A)
2194 : !C
2195 : !C***ROUTINES CALLED AZABS
2196 : !C***END PROLOGUE AZSQRT
2197 : DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DRT
2198 : !DOUBLE PRECISION AZABS
2199 : DATA DRT , DPI / 7.071067811865475244008443621D-1, &
2200 : & 3.141592653589793238462643383D+0/
2201 0 : ZM = AZABS(AR,AI)
2202 0 : ZM = DSQRT(ZM)
2203 0 : IF (AR.EQ.0.0D+0) GO TO 10
2204 0 : IF (AI.EQ.0.0D+0) GO TO 20
2205 0 : DTHETA = DATAN(AI/AR)
2206 0 : IF (DTHETA.LE.0.0D+0) GO TO 40
2207 0 : IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI
2208 0 : GO TO 50
2209 0 : 10 IF (AI.GT.0.0D+0) GO TO 60
2210 0 : IF (AI.LT.0.0D+0) GO TO 70
2211 0 : BR = 0.0D+0
2212 0 : BI = 0.0D+0
2213 0 : RETURN
2214 0 : 20 IF (AR.GT.0.0D+0) GO TO 30
2215 0 : BR = 0.0D+0
2216 0 : BI = DSQRT(DABS(AR))
2217 0 : RETURN
2218 0 : 30 BR = DSQRT(AR)
2219 0 : BI = 0.0D+0
2220 0 : RETURN
2221 0 : 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI
2222 0 : 50 DTHETA = DTHETA*0.5D+0
2223 0 : BR = ZM*DCOS(DTHETA)
2224 0 : BI = ZM*DSIN(DTHETA)
2225 0 : RETURN
2226 0 : 60 BR = ZM*DRT
2227 0 : BI = ZM*DRT
2228 0 : RETURN
2229 0 : 70 BR = ZM*DRT
2230 0 : BI = -ZM*DRT
2231 0 : RETURN
2232 : END SUBROUTINE AZSQRT
2233 :
2234 0 : SUBROUTINE AZEXP(AR, AI, BR, BI)
2235 : !C***BEGIN PROLOGUE AZEXP
2236 : !C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
2237 : !C
2238 : !C DOUBLE PRECISION COMPLEX EXPONENTIAL FUNCTION B=EXP(A)
2239 : !C
2240 : !C***ROUTINES CALLED (NONE)
2241 : !C***END PROLOGUE AZEXP
2242 : DOUBLE PRECISION AR, AI, BR, BI, ZM, CA, CB
2243 0 : ZM = DEXP(AR)
2244 0 : CA = ZM*DCOS(AI)
2245 0 : CB = ZM*DSIN(AI)
2246 0 : BR = CA
2247 0 : BI = CB
2248 0 : RETURN
2249 : END SUBROUTINE AZEXP
2250 :
2251 0 : SUBROUTINE ZUOIK(ZR, ZI, FNU, KODE, IKFLG, N, YR, YI, NUF, TOL, &
2252 : & ELIM, ALIM)
2253 : !C***BEGIN PROLOGUE ZUOIK
2254 : !C***REFER TO ZBESI,ZBESK,ZBESH
2255 : !C
2256 : !C ZUOIK COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC
2257 : !C EXPANSIONS FOR THE I AND K FUNCTIONS AND COMPARES THEM
2258 : !C (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW
2259 : !C WHERE ALIM.LT.ELIM. IF THE MAGNITUDE, BASED ON THE LEADING
2260 : !C EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN
2261 : !C THE RESULT IS ON SCALE. IF NOT, THEN A REFINED TEST USING OTHER
2262 : !C MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE
2263 : !C EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)=
2264 : !C EXP(-ELIM)/TOL
2265 : !C
2266 : !C IKFLG=1 MEANS THE I SEQUENCE IS TESTED
2267 : !C =2 MEANS THE K SEQUENCE IS TESTED
2268 : !C NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE
2269 : !C =-1 MEANS AN OVERFLOW WOULD OCCUR
2270 : !C IKFLG=1 AND NUF.GT.0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO
2271 : !C THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE
2272 : !C IKFLG=2 AND NUF.EQ.N MEANS ALL Y VALUES WERE SET TO ZERO
2273 : !C IKFLG=2 AND 0.LT.NUF.LT.N NOT CONSIDERED. Y MUST BE SET BY
2274 : !C ANOTHER ROUTINE
2275 : !C
2276 : !C***ROUTINES CALLED ZUCHK,ZUNHJ,ZUNIK,D1MACH,AZABS,AZLOG
2277 : !C***END PROLOGUE ZUOIK
2278 : !C COMPLEX ARG,ASUM,BSUM,CWRK,CZ,CZERO,PHI,SUM,Y,Z,ZB,ZETA1,ZETA2,ZN,
2279 : !C *ZR
2280 : DOUBLE PRECISION AARG, AIC, ALIM, APHI, ARGI, ARGR, ASUMI, ASUMR, &
2281 : & ASCLE, AX, AY, BSUMI, BSUMR, CWRKI, CWRKR, CZI, CZR, ELIM, FNN, &
2282 : & FNU, GNN, GNU, PHII, PHIR, RCZ, STR, STI, SUMI, SUMR, TOL, YI, &
2283 : & YR, ZBI, ZBR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, &
2284 : & ZNI, ZNR, ZR, ZRI, ZRR!, D1MACH, AZABS
2285 : INTEGER I, IDUM, IFORM, IKFLG, INIT, KODE, N, NN, NUF, NW
2286 : DIMENSION YR(N), YI(N), CWRKR(16), CWRKI(16)
2287 : DATA ZEROR,ZEROI / 0.0D0, 0.0D0 /
2288 : DATA AIC / 1.265512123484645396D+00 /
2289 0 : NUF = 0
2290 0 : NN = N
2291 0 : ZRR = ZR
2292 0 : ZRI = ZI
2293 0 : IF (ZR.GE.0.0D0) GO TO 10
2294 0 : ZRR = -ZR
2295 0 : ZRI = -ZI
2296 : 10 CONTINUE
2297 0 : ZBR = ZRR
2298 0 : ZBI = ZRI
2299 0 : AX = DABS(ZR)*1.7321D0
2300 0 : AY = DABS(ZI)
2301 0 : IFORM = 1
2302 0 : IF (AY.GT.AX) IFORM = 2
2303 0 : GNU = DMAX1(FNU,1.0D0)
2304 0 : IF (IKFLG.EQ.1) GO TO 20
2305 0 : FNN = DBLE(FLOAT(NN))
2306 0 : GNN = FNU + FNN - 1.0D0
2307 0 : GNU = DMAX1(GNN,FNN)
2308 : 20 CONTINUE
2309 : !C-----------------------------------------------------------------------
2310 : !C ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE
2311 : !C REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET
2312 : !C THE SIGN OF THE IMAGINARY PART CORRECT.
2313 : !C-----------------------------------------------------------------------
2314 0 : IF (IFORM.EQ.2) GO TO 30
2315 0 : INIT = 0
2316 : CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII, &
2317 0 : & ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI)
2318 0 : CZR = -ZETA1R + ZETA2R
2319 0 : CZI = -ZETA1I + ZETA2I
2320 0 : GO TO 50
2321 : 30 CONTINUE
2322 0 : ZNR = ZRI
2323 0 : ZNI = -ZRR
2324 0 : IF (ZI.GT.0.0D0) GO TO 40
2325 0 : ZNR = -ZNR
2326 : 40 CONTINUE
2327 : CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, &
2328 0 : & ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI)
2329 0 : CZR = -ZETA1R + ZETA2R
2330 0 : CZI = -ZETA1I + ZETA2I
2331 0 : AARG = AZABS(ARGR,ARGI)
2332 : 50 CONTINUE
2333 0 : IF (KODE.EQ.1) GO TO 60
2334 0 : CZR = CZR - ZBR
2335 0 : CZI = CZI - ZBI
2336 : 60 CONTINUE
2337 0 : IF (IKFLG.EQ.1) GO TO 70
2338 0 : CZR = -CZR
2339 0 : CZI = -CZI
2340 : 70 CONTINUE
2341 0 : APHI = AZABS(PHIR,PHII)
2342 0 : RCZ = CZR
2343 : !C-----------------------------------------------------------------------
2344 : !C OVERFLOW TEST
2345 : !C-----------------------------------------------------------------------
2346 0 : IF (RCZ.GT.ELIM) GO TO 210
2347 0 : IF (RCZ.LT.ALIM) GO TO 80
2348 0 : RCZ = RCZ + DLOG(APHI)
2349 0 : IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC
2350 0 : IF (RCZ.GT.ELIM) GO TO 210
2351 0 : GO TO 130
2352 : 80 CONTINUE
2353 : !C-----------------------------------------------------------------------
2354 : !C UNDERFLOW TEST
2355 : !C-----------------------------------------------------------------------
2356 0 : IF (RCZ.LT.(-ELIM)) GO TO 90
2357 0 : IF (RCZ.GT.(-ALIM)) GO TO 130
2358 0 : RCZ = RCZ + DLOG(APHI)
2359 0 : IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC
2360 0 : IF (RCZ.GT.(-ELIM)) GO TO 110
2361 : 90 CONTINUE
2362 0 : DO 100 I=1,NN
2363 0 : YR(I) = ZEROR
2364 0 : YI(I) = ZEROI
2365 0 : 100 CONTINUE
2366 0 : NUF = NN
2367 0 : RETURN
2368 : 110 CONTINUE
2369 0 : ASCLE = 1.0D+3*D1MACH(1)/TOL
2370 0 : CALL AZLOG(PHIR, PHII, STR, STI, IDUM)
2371 0 : CZR = CZR + STR
2372 0 : CZI = CZI + STI
2373 0 : IF (IFORM.EQ.1) GO TO 120
2374 0 : CALL AZLOG(ARGR, ARGI, STR, STI, IDUM)
2375 0 : CZR = CZR - 0.25D0*STR - AIC
2376 0 : CZI = CZI - 0.25D0*STI
2377 : 120 CONTINUE
2378 0 : AX = DEXP(RCZ)/TOL
2379 0 : AY = CZI
2380 0 : CZR = AX*DCOS(AY)
2381 0 : CZI = AX*DSIN(AY)
2382 0 : CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL)
2383 : IF (NW.NE.0) GO TO 90
2384 : 130 CONTINUE
2385 0 : IF (IKFLG.EQ.2) RETURN
2386 0 : IF (N.EQ.1) RETURN
2387 : !C-----------------------------------------------------------------------
2388 : !C SET UNDERFLOWS ON I SEQUENCE
2389 : !C-----------------------------------------------------------------------
2390 : 140 CONTINUE
2391 0 : GNU = FNU + DBLE(FLOAT(NN-1))
2392 0 : IF (IFORM.EQ.2) GO TO 150
2393 0 : INIT = 0
2394 : CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII, &
2395 0 : & ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI)
2396 0 : CZR = -ZETA1R + ZETA2R
2397 0 : CZI = -ZETA1I + ZETA2I
2398 0 : GO TO 160
2399 : 150 CONTINUE
2400 : CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, &
2401 0 : & ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI)
2402 0 : CZR = -ZETA1R + ZETA2R
2403 0 : CZI = -ZETA1I + ZETA2I
2404 0 : AARG = AZABS(ARGR,ARGI)
2405 : 160 CONTINUE
2406 0 : IF (KODE.EQ.1) GO TO 170
2407 0 : CZR = CZR - ZBR
2408 0 : CZI = CZI - ZBI
2409 : 170 CONTINUE
2410 0 : APHI = AZABS(PHIR,PHII)
2411 0 : RCZ = CZR
2412 0 : IF (RCZ.LT.(-ELIM)) GO TO 180
2413 0 : IF (RCZ.GT.(-ALIM)) RETURN
2414 0 : RCZ = RCZ + DLOG(APHI)
2415 0 : IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC
2416 0 : IF (RCZ.GT.(-ELIM)) GO TO 190
2417 : 180 CONTINUE
2418 0 : YR(NN) = ZEROR
2419 0 : YI(NN) = ZEROI
2420 0 : NN = NN - 1
2421 0 : NUF = NUF + 1
2422 0 : IF (NN.EQ.0) RETURN
2423 0 : GO TO 140
2424 : 190 CONTINUE
2425 0 : ASCLE = 1.0D+3*D1MACH(1)/TOL
2426 0 : CALL AZLOG(PHIR, PHII, STR, STI, IDUM)
2427 0 : CZR = CZR + STR
2428 0 : CZI = CZI + STI
2429 0 : IF (IFORM.EQ.1) GO TO 200
2430 0 : CALL AZLOG(ARGR, ARGI, STR, STI, IDUM)
2431 0 : CZR = CZR - 0.25D0*STR - AIC
2432 0 : CZI = CZI - 0.25D0*STI
2433 : 200 CONTINUE
2434 0 : AX = DEXP(RCZ)/TOL
2435 0 : AY = CZI
2436 0 : CZR = AX*DCOS(AY)
2437 0 : CZI = AX*DSIN(AY)
2438 0 : CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL)
2439 : IF (NW.NE.0) GO TO 180
2440 0 : RETURN
2441 : 210 CONTINUE
2442 0 : NUF = -1
2443 0 : RETURN
2444 : END SUBROUTINE ZUOIK
2445 :
2446 :
2447 0 : SUBROUTINE ZUNIK(ZRR, ZRI, FNU, IKFLG, IPMTR, TOL, INIT, PHIR, &
2448 : & PHII, ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI)
2449 : !C***BEGIN PROLOGUE ZUNIK
2450 : !C***REFER TO ZBESI,ZBESK
2451 : !C
2452 : !C ZUNIK COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC
2453 : !C EXPANSIONS OF THE I AND K FUNCTIONS ON IKFLG= 1 OR 2
2454 : !C RESPECTIVELY BY
2455 : !C
2456 : !C W(FNU,ZR) = PHI*EXP(ZETA)*SUM
2457 : !C
2458 : !C WHERE ZETA=-ZETA1 + ZETA2 OR
2459 : !C ZETA1 - ZETA2
2460 : !C
2461 : !C THE FIRST CALL MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE
2462 : !C SAME ZR AND FNU WILL RETURN THE I OR K FUNCTION ON IKFLG=
2463 : !C 1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK
2464 : !C ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI,
2465 : !C ZETA1,ZETA2.
2466 : !C
2467 : !C***ROUTINES CALLED ZDIV,AZLOG,AZSQRT,D1MACH
2468 : !C***END PROLOGUE ZUNIK
2469 : !C COMPLEX CFN,CON,CONE,CRFN,CWRK,CZERO,PHI,S,SR,SUM,T,T2,ZETA1,
2470 : !C *ZETA2,ZN,ZR
2471 : DOUBLE PRECISION AC, C, CON, CONEI, CONER, CRFNI, CRFNR, CWRKI, &
2472 : & CWRKR, FNU, PHII, PHIR, RFN, SI, SR, SRI, SRR, STI, STR, SUMI, &
2473 : & SUMR, TEST, TI, TOL, TR, T2I, T2R, ZEROI, ZEROR, ZETA1I, ZETA1R, &
2474 : & ZETA2I, ZETA2R, ZNI, ZNR, ZRI, ZRR!, D1MACH
2475 : INTEGER I, IDUM, IKFLG, INIT, IPMTR, J, K, L
2476 : DIMENSION C(120), CWRKR(16), CWRKI(16), CON(2)
2477 : DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
2478 : DATA CON(1), CON(2) / &
2479 : & 3.98942280401432678D-01, 1.25331413731550025D+00 /
2480 : DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), &
2481 : & C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), &
2482 : & C(19), C(20), C(21), C(22), C(23), C(24)/ &
2483 : & 1.00000000000000000D+00, -2.08333333333333333D-01, &
2484 : & 1.25000000000000000D-01, 3.34201388888888889D-01, &
2485 : & -4.01041666666666667D-01, 7.03125000000000000D-02, &
2486 : & -1.02581259645061728D+00, 1.84646267361111111D+00, &
2487 : & -8.91210937500000000D-01, 7.32421875000000000D-02, &
2488 : & 4.66958442342624743D+00, -1.12070026162229938D+01, &
2489 : & 8.78912353515625000D+00, -2.36408691406250000D+00, &
2490 : & 1.12152099609375000D-01, -2.82120725582002449D+01, &
2491 : & 8.46362176746007346D+01, -9.18182415432400174D+01, &
2492 : & 4.25349987453884549D+01, -7.36879435947963170D+00, &
2493 : & 2.27108001708984375D-01, 2.12570130039217123D+02, &
2494 : & -7.65252468141181642D+02, 1.05999045252799988D+03/
2495 : DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), &
2496 : & C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), &
2497 : & C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ &
2498 : & -6.99579627376132541D+02, 2.18190511744211590D+02, &
2499 : & -2.64914304869515555D+01, 5.72501420974731445D-01, &
2500 : & -1.91945766231840700D+03, 8.06172218173730938D+03, &
2501 : & -1.35865500064341374D+04, 1.16553933368645332D+04, &
2502 : & -5.30564697861340311D+03, 1.20090291321635246D+03, &
2503 : & -1.08090919788394656D+02, 1.72772750258445740D+00, &
2504 : & 2.02042913309661486D+04, -9.69805983886375135D+04, &
2505 : & 1.92547001232531532D+05, -2.03400177280415534D+05, &
2506 : & 1.22200464983017460D+05, -4.11926549688975513D+04, &
2507 : & 7.10951430248936372D+03, -4.93915304773088012D+02, &
2508 : & 6.07404200127348304D+00, -2.42919187900551333D+05, &
2509 : & 1.31176361466297720D+06, -2.99801591853810675D+06/
2510 : DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), &
2511 : & C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), &
2512 : & C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ &
2513 : & 3.76327129765640400D+06, -2.81356322658653411D+06, &
2514 : & 1.26836527332162478D+06, -3.31645172484563578D+05, &
2515 : & 4.52187689813627263D+04, -2.49983048181120962D+03, &
2516 : & 2.43805296995560639D+01, 3.28446985307203782D+06, &
2517 : & -1.97068191184322269D+07, 5.09526024926646422D+07, &
2518 : & -7.41051482115326577D+07, 6.63445122747290267D+07, &
2519 : & -3.75671766607633513D+07, 1.32887671664218183D+07, &
2520 : & -2.78561812808645469D+06, 3.08186404612662398D+05, &
2521 : & -1.38860897537170405D+04, 1.10017140269246738D+02, &
2522 : & -4.93292536645099620D+07, 3.25573074185765749D+08, &
2523 : & -9.39462359681578403D+08, 1.55359689957058006D+09,&
2524 : & -1.62108055210833708D+09, 1.10684281682301447D+09/
2525 : DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), &
2526 : & C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), &
2527 : & C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ &
2528 : & -4.95889784275030309D+08, 1.42062907797533095D+08, &
2529 : & -2.44740627257387285D+07, 2.24376817792244943D+06, &
2530 : & -8.40054336030240853D+04, 5.51335896122020586D+02, &
2531 : & 8.14789096118312115D+08, -5.86648149205184723D+09, &
2532 : & 1.86882075092958249D+10, -3.46320433881587779D+10, &
2533 : & 4.12801855797539740D+10, -3.30265997498007231D+10, &
2534 : & 1.79542137311556001D+10, -6.56329379261928433D+09, &
2535 : & 1.55927986487925751D+09, -2.25105661889415278D+08, &
2536 : & 1.73951075539781645D+07, -5.49842327572288687D+05, &
2537 : & 3.03809051092238427D+03, -1.46792612476956167D+10, &
2538 : & 1.14498237732025810D+11, -3.99096175224466498D+11,&
2539 : & 8.19218669548577329D+11, -1.09837515608122331D+12/
2540 : DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), &
2541 : & C(105), C(106), C(107), C(108), C(109), C(110), C(111), &
2542 : & C(112), C(113), C(114), C(115), C(116), C(117), C(118)/ &
2543 : & 1.00815810686538209D+12, -6.45364869245376503D+11, &
2544 : & 2.87900649906150589D+11, -8.78670721780232657D+10, &
2545 : & 1.76347306068349694D+10, -2.16716498322379509D+09, &
2546 : & 1.43157876718888981D+08, -3.87183344257261262D+06, &
2547 : & 1.82577554742931747D+04, 2.86464035717679043D+11, &
2548 : & -2.40629790002850396D+12, 9.10934118523989896D+12, &
2549 : & -2.05168994109344374D+13, 3.05651255199353206D+13, &
2550 : & -3.16670885847851584D+13, 2.33483640445818409D+13, &
2551 : & -1.23204913055982872D+13, 4.61272578084913197D+12, &
2552 : & -1.19655288019618160D+12, 2.05914503232410016D+11, &
2553 : & -2.18229277575292237D+10, 1.24700929351271032D+09/
2554 : DATA C(119), C(120)/ &
2555 : & -2.91883881222208134D+07, 1.18838426256783253D+05/
2556 : !C
2557 0 : IF (INIT.NE.0) GO TO 40
2558 : !C-----------------------------------------------------------------------
2559 : !C INITIALIZE ALL VARIABLES
2560 : !C-----------------------------------------------------------------------
2561 0 : RFN = 1.0D0/FNU
2562 : !C-----------------------------------------------------------------------
2563 : !C OVERFLOW TEST (ZR/FNU TOO SMALL)
2564 : !C-----------------------------------------------------------------------
2565 0 : TEST = D1MACH(1)*1.0D+3
2566 0 : AC = FNU*TEST
2567 0 : IF (DABS(ZRR).GT.AC .OR. DABS(ZRI).GT.AC) GO TO 15
2568 0 : ZETA1R = 2.0D0*DABS(DLOG(TEST))+FNU
2569 0 : ZETA1I = 0.0D0
2570 0 : ZETA2R = FNU
2571 0 : ZETA2I = 0.0D0
2572 0 : PHIR = 1.0D0
2573 0 : PHII = 0.0D0
2574 0 : RETURN
2575 : 15 CONTINUE
2576 0 : TR = ZRR*RFN
2577 0 : TI = ZRI*RFN
2578 0 : SR = CONER + (TR*TR-TI*TI)
2579 0 : SI = CONEI + (TR*TI+TI*TR)
2580 0 : CALL AZSQRT(SR, SI, SRR, SRI)
2581 0 : STR = CONER + SRR
2582 0 : STI = CONEI + SRI
2583 0 : CALL ZDIV(STR, STI, TR, TI, ZNR, ZNI)
2584 0 : CALL AZLOG(ZNR, ZNI, STR, STI, IDUM)
2585 0 : ZETA1R = FNU*STR
2586 0 : ZETA1I = FNU*STI
2587 0 : ZETA2R = FNU*SRR
2588 0 : ZETA2I = FNU*SRI
2589 0 : CALL ZDIV(CONER, CONEI, SRR, SRI, TR, TI)
2590 0 : SRR = TR*RFN
2591 0 : SRI = TI*RFN
2592 0 : CALL AZSQRT(SRR, SRI, CWRKR(16), CWRKI(16))
2593 0 : PHIR = CWRKR(16)*CON(IKFLG)
2594 0 : PHII = CWRKI(16)*CON(IKFLG)
2595 0 : IF (IPMTR.NE.0) RETURN
2596 0 : CALL ZDIV(CONER, CONEI, SR, SI, T2R, T2I)
2597 0 : CWRKR(1) = CONER
2598 0 : CWRKI(1) = CONEI
2599 0 : CRFNR = CONER
2600 0 : CRFNI = CONEI
2601 0 : AC = 1.0D0
2602 0 : L = 1
2603 0 : DO 20 K=2,15
2604 0 : SR = ZEROR
2605 0 : SI = ZEROI
2606 0 : DO 10 J=1,K
2607 0 : L = L + 1
2608 0 : STR = SR*T2R - SI*T2I + C(L)
2609 0 : SI = SR*T2I + SI*T2R
2610 0 : SR = STR
2611 0 : 10 CONTINUE
2612 0 : STR = CRFNR*SRR - CRFNI*SRI
2613 0 : CRFNI = CRFNR*SRI + CRFNI*SRR
2614 0 : CRFNR = STR
2615 0 : CWRKR(K) = CRFNR*SR - CRFNI*SI
2616 0 : CWRKI(K) = CRFNR*SI + CRFNI*SR
2617 0 : AC = AC*RFN
2618 0 : TEST = DABS(CWRKR(K)) + DABS(CWRKI(K))
2619 0 : IF (AC.LT.TOL .AND. TEST.LT.TOL) GO TO 30
2620 0 : 20 CONTINUE
2621 0 : K = 15
2622 : 30 CONTINUE
2623 0 : INIT = K
2624 : 40 CONTINUE
2625 0 : IF (IKFLG.EQ.2) GO TO 60
2626 : !C-----------------------------------------------------------------------
2627 : !C COMPUTE SUM FOR THE I FUNCTION
2628 : !C-----------------------------------------------------------------------
2629 0 : SR = ZEROR
2630 0 : SI = ZEROI
2631 0 : DO 50 I=1,INIT
2632 0 : SR = SR + CWRKR(I)
2633 0 : SI = SI + CWRKI(I)
2634 0 : 50 CONTINUE
2635 0 : SUMR = SR
2636 0 : SUMI = SI
2637 0 : PHIR = CWRKR(16)*CON(1)
2638 0 : PHII = CWRKI(16)*CON(1)
2639 0 : RETURN
2640 : 60 CONTINUE
2641 : !C-----------------------------------------------------------------------
2642 : !C COMPUTE SUM FOR THE K FUNCTION
2643 : !C-----------------------------------------------------------------------
2644 0 : SR = ZEROR
2645 0 : SI = ZEROI
2646 0 : TR = CONER
2647 0 : DO 70 I=1,INIT
2648 0 : SR = SR + TR*CWRKR(I)
2649 0 : SI = SI + TR*CWRKI(I)
2650 0 : TR = -TR
2651 0 : 70 CONTINUE
2652 0 : SUMR = SR
2653 0 : SUMI = SI
2654 0 : PHIR = CWRKR(16)*CON(2)
2655 0 : PHII = CWRKI(16)*CON(2)
2656 0 : RETURN
2657 : END SUBROUTINE ZUNIK
2658 :
2659 :
2660 0 : SUBROUTINE ZUNHJ(ZR, ZI, FNU, IPMTR, TOL, PHIR, PHII, ARGR, ARGI, &
2661 : & ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI)
2662 : !C***BEGIN PROLOGUE ZUNHJ
2663 : !C***REFER TO ZBESI,ZBESK
2664 : !C
2665 : !C REFERENCES
2666 : !C HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ AND I.A.
2667 : !C STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9.
2668 : !C
2669 : !C ASYMPTOTICS AND SPECIAL FUNCTIONS BY F.W.J. OLVER, ACADEMIC
2670 : !C PRESS, N.Y., 1974, PAGE 420
2671 : !C
2672 : !C ABSTRACT
2673 : !C ZUNHJ COMPUTES PARAMETERS FOR BESSEL FUNCTIONS C(FNU,Z) =
2674 : !C J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU
2675 : !C BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION
2676 : !C
2677 : !C C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) )
2678 : !C
2679 : !C FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS
2680 : !C AN AIRY FUNCTION AND DAIRY IS ITS DERIVATIVE.
2681 : !C
2682 : !C (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2,
2683 : !C
2684 : !C ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING
2685 : !C PURPOSES IN AIRY FUNCTIONS FROM CAIRY OR CBIRY.
2686 : !C
2687 : !C MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND
2688 : !C MUST BE SPECIFIED. IPMTR=0 RETURNS ALL PARAMETERS. IPMTR=
2689 : !C 1 COMPUTES ALL EXCEPT ASUM AND BSUM.
2690 : !C
2691 : !C***ROUTINES CALLED AZABS,ZDIV,AZLOG,AZSQRT,D1MACH
2692 : !C***END PROLOGUE ZUNHJ
2693 : !C COMPLEX ARG,ASUM,BSUM,CFNU,CONE,CR,CZERO,DR,P,PHI,PRZTH,PTFN,
2694 : !C *RFN13,RTZTA,RZTH,SUMA,SUMB,TFN,T2,UP,W,W2,Z,ZA,ZB,ZC,ZETA,ZETA1,
2695 : !C *ZETA2,ZTH
2696 : DOUBLE PRECISION ALFA, ANG, AP, AR, ARGI, ARGR, ASUMI, ASUMR, &
2697 : & ATOL, AW2, AZTH, BETA, BR, BSUMI, BSUMR, BTOL, C, CONEI, CONER, &
2698 : & CRI, CRR, DRI, DRR, EX1, EX2, FNU, FN13, FN23, GAMA, GPI, HPI, &
2699 : & PHII, PHIR, PI, PP, PR, PRZTHI, PRZTHR, PTFNI, PTFNR, RAW, RAW2, &
2700 : & RAZTH, RFNU, RFNU2, RFN13, RTZTI, RTZTR, RZTHI, RZTHR, STI, STR, &
2701 : & SUMAI, SUMAR, SUMBI, SUMBR, TEST, TFNI, TFNR, THPI, TOL, TZAI, &
2702 : & TZAR, T2I, T2R, UPI, UPR, WI, WR, W2I, W2R, ZAI, ZAR, ZBI, ZBR, &
2703 : & ZCI, ZCR, ZEROI, ZEROR, ZETAI, ZETAR, ZETA1I, ZETA1R, ZETA2I, &
2704 : & ZETA2R, ZI, ZR, ZTHI, ZTHR, AC !, AZABS, D1MACH
2705 : INTEGER IAS, IBS, IPMTR, IS, J, JR, JU, K, KMAX, KP1, KS, L, LR, &
2706 : & LRP1, L1, L2, M, IDUM
2707 : DIMENSION AR(14), BR(14), C(105), ALFA(180), BETA(210), GAMA(30), &
2708 : & AP(30), PR(30), PI(30), UPR(14), UPI(14), CRR(14), CRI(14), &
2709 : & DRR(14), DRI(14)
2710 : DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), AR(8), &
2711 : & AR(9), AR(10), AR(11), AR(12), AR(13), AR(14)/ &
2712 : & 1.00000000000000000D+00, 1.04166666666666667D-01, &
2713 : & 8.35503472222222222D-02, 1.28226574556327160D-01, &
2714 : & 2.91849026464140464D-01, 8.81627267443757652D-01, &
2715 : & 3.32140828186276754D+00, 1.49957629868625547D+01, &
2716 : & 7.89230130115865181D+01, 4.74451538868264323D+02, &
2717 : & 3.20749009089066193D+03, 2.40865496408740049D+04, &
2718 : & 1.98923119169509794D+05, 1.79190200777534383D+06/
2719 : DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8), &
2720 : & BR(9), BR(10), BR(11), BR(12), BR(13), BR(14)/ &
2721 : & 1.00000000000000000D+00, -1.45833333333333333D-01, &
2722 : & -9.87413194444444444D-02, -1.43312053915895062D-01, &
2723 : & -3.17227202678413548D-01, -9.42429147957120249D-01, &
2724 : & -3.51120304082635426D+00, -1.57272636203680451D+01, &
2725 : & -8.22814390971859444D+01, -4.92355370523670524D+02, &
2726 : & -3.31621856854797251D+03, -2.48276742452085896D+04, &
2727 : & -2.04526587315129788D+05, -1.83844491706820990D+06/
2728 : DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), &
2729 : & C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), &
2730 : & C(19), C(20), C(21), C(22), C(23), C(24)/ &
2731 : & 1.00000000000000000D+00, -2.08333333333333333D-01, &
2732 : & 1.25000000000000000D-01, 3.34201388888888889D-01, &
2733 : & -4.01041666666666667D-01, 7.03125000000000000D-02, &
2734 : & -1.02581259645061728D+00, 1.84646267361111111D+00, &
2735 : & -8.91210937500000000D-01, 7.32421875000000000D-02, &
2736 : & 4.66958442342624743D+00, -1.12070026162229938D+01, &
2737 : & 8.78912353515625000D+00, -2.36408691406250000D+00, &
2738 : & 1.12152099609375000D-01, -2.82120725582002449D+01, &
2739 : & 8.46362176746007346D+01, -9.18182415432400174D+01, &
2740 : & 4.25349987453884549D+01, -7.36879435947963170D+00, &
2741 : & 2.27108001708984375D-01, 2.12570130039217123D+02, &
2742 : & -7.65252468141181642D+02, 1.05999045252799988D+03/
2743 : DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), &
2744 : & C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), &
2745 : & C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ &
2746 : & -6.99579627376132541D+02, 2.18190511744211590D+02, &
2747 : & -2.64914304869515555D+01, 5.72501420974731445D-01, &
2748 : & -1.91945766231840700D+03, 8.06172218173730938D+03, &
2749 : & -1.35865500064341374D+04, 1.16553933368645332D+04, &
2750 : & -5.30564697861340311D+03, 1.20090291321635246D+03, &
2751 : & -1.08090919788394656D+02, 1.72772750258445740D+00, &
2752 : & 2.02042913309661486D+04, -9.69805983886375135D+04, &
2753 : & 1.92547001232531532D+05, -2.03400177280415534D+05, &
2754 : & 1.22200464983017460D+05, -4.11926549688975513D+04, &
2755 : & 7.10951430248936372D+03, -4.93915304773088012D+02, &
2756 : & 6.07404200127348304D+00, -2.42919187900551333D+05, &
2757 : & 1.31176361466297720D+06, -2.99801591853810675D+06/
2758 : DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), &
2759 : & C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), &
2760 : & C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ &
2761 : & 3.76327129765640400D+06, -2.81356322658653411D+06, &
2762 : & 1.26836527332162478D+06, -3.31645172484563578D+05, &
2763 : & 4.52187689813627263D+04, -2.49983048181120962D+03, &
2764 : & 2.43805296995560639D+01, 3.28446985307203782D+06, &
2765 : & -1.97068191184322269D+07, 5.09526024926646422D+07, &
2766 : & -7.41051482115326577D+07, 6.63445122747290267D+07, &
2767 : & -3.75671766607633513D+07, 1.32887671664218183D+07, &
2768 : & -2.78561812808645469D+06, 3.08186404612662398D+05, &
2769 : & -1.38860897537170405D+04, 1.10017140269246738D+02, &
2770 : & -4.93292536645099620D+07, 3.25573074185765749D+08, &
2771 : & -9.39462359681578403D+08, 1.55359689957058006D+09, &
2772 : & -1.62108055210833708D+09, 1.10684281682301447D+09/
2773 : DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), &
2774 : & C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), &
2775 : & C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ &
2776 : & -4.95889784275030309D+08, 1.42062907797533095D+08, &
2777 : & -2.44740627257387285D+07, 2.24376817792244943D+06, &
2778 : & -8.40054336030240853D+04, 5.51335896122020586D+02, &
2779 : & 8.14789096118312115D+08, -5.86648149205184723D+09, &
2780 : & 1.86882075092958249D+10, -3.46320433881587779D+10, &
2781 : & 4.12801855797539740D+10, -3.30265997498007231D+10, &
2782 : & 1.79542137311556001D+10, -6.56329379261928433D+09, &
2783 : & 1.55927986487925751D+09, -2.25105661889415278D+08, &
2784 : & 1.73951075539781645D+07, -5.49842327572288687D+05, &
2785 : & 3.03809051092238427D+03, -1.46792612476956167D+10, &
2786 : & 1.14498237732025810D+11, -3.99096175224466498D+11, &
2787 : & 8.19218669548577329D+11, -1.09837515608122331D+12/
2788 : DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), &
2789 : & C(105)/ &
2790 : & 1.00815810686538209D+12, -6.45364869245376503D+11, &
2791 : & 2.87900649906150589D+11, -8.78670721780232657D+10, &
2792 : & 1.76347306068349694D+10, -2.16716498322379509D+09, &
2793 : & 1.43157876718888981D+08, -3.87183344257261262D+06, &
2794 : & 1.82577554742931747D+04/
2795 : DATA ALFA(1), ALFA(2), ALFA(3), ALFA(4), ALFA(5), ALFA(6), &
2796 : & ALFA(7), ALFA(8), ALFA(9), ALFA(10), ALFA(11), ALFA(12), &
2797 : & ALFA(13), ALFA(14), ALFA(15), ALFA(16), ALFA(17), ALFA(18), &
2798 : & ALFA(19), ALFA(20), ALFA(21), ALFA(22)/ &
2799 : & -4.44444444444444444D-03, -9.22077922077922078D-04, &
2800 : & -8.84892884892884893D-05, 1.65927687832449737D-04, &
2801 : & 2.46691372741792910D-04, 2.65995589346254780D-04, &
2802 : & 2.61824297061500945D-04, 2.48730437344655609D-04, &
2803 : & 2.32721040083232098D-04, 2.16362485712365082D-04, &
2804 : & 2.00738858762752355D-04, 1.86267636637545172D-04, &
2805 : & 1.73060775917876493D-04, 1.61091705929015752D-04, &
2806 : & 1.50274774160908134D-04, 1.40503497391269794D-04, &
2807 : & 1.31668816545922806D-04, 1.23667445598253261D-04, &
2808 : & 1.16405271474737902D-04, 1.09798298372713369D-04, &
2809 : & 1.03772410422992823D-04, 9.82626078369363448D-05/
2810 : DATA ALFA(23), ALFA(24), ALFA(25), ALFA(26), ALFA(27), ALFA(28), &
2811 : & ALFA(29), ALFA(30), ALFA(31), ALFA(32), ALFA(33), ALFA(34), &
2812 : & ALFA(35), ALFA(36), ALFA(37), ALFA(38), ALFA(39), ALFA(40), &
2813 : & ALFA(41), ALFA(42), ALFA(43), ALFA(44)/ &
2814 : & 9.32120517249503256D-05, 8.85710852478711718D-05, &
2815 : & 8.42963105715700223D-05, 8.03497548407791151D-05, &
2816 : & 7.66981345359207388D-05, 7.33122157481777809D-05, &
2817 : & 7.01662625163141333D-05, 6.72375633790160292D-05, &
2818 : & 6.93735541354588974D-04, 2.32241745182921654D-04, &
2819 : & -1.41986273556691197D-05, -1.16444931672048640D-04, &
2820 : & -1.50803558053048762D-04, -1.55121924918096223D-04, &
2821 : & -1.46809756646465549D-04, -1.33815503867491367D-04, &
2822 : & -1.19744975684254051D-04, -1.06184319207974020D-04, &
2823 : & -9.37699549891194492D-05, -8.26923045588193274D-05, &
2824 : & -7.29374348155221211D-05, -6.44042357721016283D-05/
2825 : DATA ALFA(45), ALFA(46), ALFA(47), ALFA(48), ALFA(49), ALFA(50), &
2826 : & ALFA(51), ALFA(52), ALFA(53), ALFA(54), ALFA(55), ALFA(56), &
2827 : & ALFA(57), ALFA(58), ALFA(59), ALFA(60), ALFA(61), ALFA(62), &
2828 : & ALFA(63), ALFA(64), ALFA(65), ALFA(66)/ &
2829 : & -5.69611566009369048D-05, -5.04731044303561628D-05, &
2830 : & -4.48134868008882786D-05, -3.98688727717598864D-05, &
2831 : & -3.55400532972042498D-05, -3.17414256609022480D-05, &
2832 : & -2.83996793904174811D-05, -2.54522720634870566D-05, &
2833 : & -2.28459297164724555D-05, -2.05352753106480604D-05, &
2834 : & -1.84816217627666085D-05, -1.66519330021393806D-05, &
2835 : & -1.50179412980119482D-05, -1.35554031379040526D-05, &
2836 : & -1.22434746473858131D-05, -1.10641884811308169D-05, &
2837 : & -3.54211971457743841D-04, -1.56161263945159416D-04, &
2838 : & 3.04465503594936410D-05, 1.30198655773242693D-04, &
2839 : & 1.67471106699712269D-04, 1.70222587683592569D-04/
2840 : DATA ALFA(67), ALFA(68), ALFA(69), ALFA(70), ALFA(71), ALFA(72), &
2841 : & ALFA(73), ALFA(74), ALFA(75), ALFA(76), ALFA(77), ALFA(78), &
2842 : & ALFA(79), ALFA(80), ALFA(81), ALFA(82), ALFA(83), ALFA(84), &
2843 : & ALFA(85), ALFA(86), ALFA(87), ALFA(88)/ &
2844 : & 1.56501427608594704D-04, 1.36339170977445120D-04, &
2845 : & 1.14886692029825128D-04, 9.45869093034688111D-05, &
2846 : & 7.64498419250898258D-05, 6.07570334965197354D-05, &
2847 : & 4.74394299290508799D-05, 3.62757512005344297D-05, &
2848 : & 2.69939714979224901D-05, 1.93210938247939253D-05, &
2849 : & 1.30056674793963203D-05, 7.82620866744496661D-06, &
2850 : & 3.59257485819351583D-06, 1.44040049814251817D-07, &
2851 : & -2.65396769697939116D-06, -4.91346867098485910D-06, &
2852 : & -6.72739296091248287D-06, -8.17269379678657923D-06, &
2853 : & -9.31304715093561232D-06, -1.02011418798016441D-05, &
2854 : -1.08805962510592880D-05, -1.13875481509603555D-05/
2855 : DATA ALFA(89), ALFA(90), ALFA(91), ALFA(92), ALFA(93), ALFA(94), &
2856 : & ALFA(95), ALFA(96), ALFA(97), ALFA(98), ALFA(99), ALFA(100), &
2857 : & ALFA(101), ALFA(102), ALFA(103), ALFA(104), ALFA(105), &
2858 : & ALFA(106), ALFA(107), ALFA(108), ALFA(109), ALFA(110)/ &
2859 : & -1.17519675674556414D-05, -1.19987364870944141D-05, &
2860 : & 3.78194199201772914D-04, 2.02471952761816167D-04, &
2861 : & -6.37938506318862408D-05, -2.38598230603005903D-04, &
2862 : & -3.10916256027361568D-04, -3.13680115247576316D-04, &
2863 : & -2.78950273791323387D-04, -2.28564082619141374D-04, &
2864 : & -1.75245280340846749D-04, -1.25544063060690348D-04, &
2865 : & -8.22982872820208365D-05, -4.62860730588116458D-05, &
2866 : & -1.72334302366962267D-05, 5.60690482304602267D-06, &
2867 : & 2.31395443148286800D-05, 3.62642745856793957D-05, &
2868 : & 4.58006124490188752D-05, 5.24595294959114050D-05, &
2869 : & 5.68396208545815266D-05, 5.94349820393104052D-05/
2870 : DATA ALFA(111), ALFA(112), ALFA(113), ALFA(114), ALFA(115), &
2871 : & ALFA(116), ALFA(117), ALFA(118), ALFA(119), ALFA(120), &
2872 : & ALFA(121), ALFA(122), ALFA(123), ALFA(124), ALFA(125), &
2873 : & ALFA(126), ALFA(127), ALFA(128), ALFA(129), ALFA(130)/ &
2874 : & 6.06478527578421742D-05, 6.08023907788436497D-05, &
2875 : & 6.01577894539460388D-05, 5.89199657344698500D-05, &
2876 : & 5.72515823777593053D-05, 5.52804375585852577D-05, &
2877 : & 5.31063773802880170D-05, 5.08069302012325706D-05, &
2878 : & 4.84418647620094842D-05, 4.60568581607475370D-05, &
2879 : & -6.91141397288294174D-04, -4.29976633058871912D-04, &
2880 : & 1.83067735980039018D-04, 6.60088147542014144D-04, &
2881 : & 8.75964969951185931D-04, 8.77335235958235514D-04, &
2882 : & 7.49369585378990637D-04, 5.63832329756980918D-04, &
2883 : & 3.68059319971443156D-04, 1.88464535514455599D-04/
2884 : DATA ALFA(131), ALFA(132), ALFA(133), ALFA(134), ALFA(135), &
2885 : & ALFA(136), ALFA(137), ALFA(138), ALFA(139), ALFA(140), &
2886 : & ALFA(141), ALFA(142), ALFA(143), ALFA(144), ALFA(145), &
2887 : & ALFA(146), ALFA(147), ALFA(148), ALFA(149), ALFA(150)/ &
2888 : & 3.70663057664904149D-05, -8.28520220232137023D-05, &
2889 : & -1.72751952869172998D-04, -2.36314873605872983D-04, &
2890 : & -2.77966150694906658D-04, -3.02079514155456919D-04, &
2891 : & -3.12594712643820127D-04, -3.12872558758067163D-04, &
2892 : & -3.05678038466324377D-04, -2.93226470614557331D-04, &
2893 : & -2.77255655582934777D-04, -2.59103928467031709D-04, &
2894 : & -2.39784014396480342D-04, -2.20048260045422848D-04, &
2895 : & -2.00443911094971498D-04, -1.81358692210970687D-04, &
2896 : & -1.63057674478657464D-04, -1.45712672175205844D-04, &
2897 : & -1.29425421983924587D-04, -1.14245691942445952D-04/
2898 : DATA ALFA(151), ALFA(152), ALFA(153), ALFA(154), ALFA(155), &
2899 : & ALFA(156), ALFA(157), ALFA(158), ALFA(159), ALFA(160), &
2900 : & ALFA(161), ALFA(162), ALFA(163), ALFA(164), ALFA(165), &
2901 : & ALFA(166), ALFA(167), ALFA(168), ALFA(169), ALFA(170)/ &
2902 : & 1.92821964248775885D-03, 1.35592576302022234D-03, &
2903 : & -7.17858090421302995D-04, -2.58084802575270346D-03, &
2904 : & -3.49271130826168475D-03, -3.46986299340960628D-03, &
2905 : & -2.82285233351310182D-03, -1.88103076404891354D-03, &
2906 : & -8.89531718383947600D-04, 3.87912102631035228D-06, &
2907 : & 7.28688540119691412D-04, 1.26566373053457758D-03, &
2908 : & 1.62518158372674427D-03, 1.83203153216373172D-03, &
2909 : & 1.91588388990527909D-03, 1.90588846755546138D-03, &
2910 : & 1.82798982421825727D-03, 1.70389506421121530D-03, &
2911 : & 1.55097127171097686D-03, 1.38261421852276159D-03/
2912 : DATA ALFA(171), ALFA(172), ALFA(173), ALFA(174), ALFA(175), &
2913 : & ALFA(176), ALFA(177), ALFA(178), ALFA(179), ALFA(180)/ &
2914 : & 1.20881424230064774D-03, 1.03676532638344962D-03, &
2915 : & 8.71437918068619115D-04, 7.16080155297701002D-04, &
2916 : & 5.72637002558129372D-04, 4.42089819465802277D-04, &
2917 : & 3.24724948503090564D-04, 2.20342042730246599D-04, &
2918 : & 1.28412898401353882D-04, 4.82005924552095464D-05/
2919 : DATA BETA(1), BETA(2), BETA(3), BETA(4), BETA(5), BETA(6), &
2920 : & BETA(7), BETA(8), BETA(9), BETA(10), BETA(11), BETA(12), &
2921 : & BETA(13), BETA(14), BETA(15), BETA(16), BETA(17), BETA(18), &
2922 : & BETA(19), BETA(20), BETA(21), BETA(22)/ &
2923 : & 1.79988721413553309D-02, 5.59964911064388073D-03, &
2924 : & 2.88501402231132779D-03, 1.80096606761053941D-03, &
2925 : & 1.24753110589199202D-03, 9.22878876572938311D-04, &
2926 : & 7.14430421727287357D-04, 5.71787281789704872D-04, &
2927 : & 4.69431007606481533D-04, 3.93232835462916638D-04, &
2928 : & 3.34818889318297664D-04, 2.88952148495751517D-04, &
2929 : & 2.52211615549573284D-04, 2.22280580798883327D-04, &
2930 : & 1.97541838033062524D-04, 1.76836855019718004D-04, &
2931 : & 1.59316899661821081D-04, 1.44347930197333986D-04, &
2932 : & 1.31448068119965379D-04, 1.20245444949302884D-04, &
2933 : & 1.10449144504599392D-04, 1.01828770740567258D-04/
2934 : DATA BETA(23), BETA(24), BETA(25), BETA(26), BETA(27), BETA(28), &
2935 : & BETA(29), BETA(30), BETA(31), BETA(32), BETA(33), BETA(34), &
2936 : & BETA(35), BETA(36), BETA(37), BETA(38), BETA(39), BETA(40), &
2937 : & BETA(41), BETA(42), BETA(43), BETA(44)/ &
2938 : & 9.41998224204237509D-05, 8.74130545753834437D-05, &
2939 : & 8.13466262162801467D-05, 7.59002269646219339D-05, &
2940 : & 7.09906300634153481D-05, 6.65482874842468183D-05, &
2941 : & 6.25146958969275078D-05, 5.88403394426251749D-05, &
2942 : & -1.49282953213429172D-03, -8.78204709546389328D-04, &
2943 : & -5.02916549572034614D-04, -2.94822138512746025D-04, &
2944 : & -1.75463996970782828D-04, -1.04008550460816434D-04, &
2945 : & -5.96141953046457895D-05, -3.12038929076098340D-05, &
2946 : & -1.26089735980230047D-05, -2.42892608575730389D-07, &
2947 : & 8.05996165414273571D-06, 1.36507009262147391D-05, &
2948 : & 1.73964125472926261D-05, 1.98672978842133780D-05/
2949 : DATA BETA(45), BETA(46), BETA(47), BETA(48), BETA(49), BETA(50), &
2950 : & BETA(51), BETA(52), BETA(53), BETA(54), BETA(55), BETA(56), &
2951 : & BETA(57), BETA(58), BETA(59), BETA(60), BETA(61), BETA(62), &
2952 : & BETA(63), BETA(64), BETA(65), BETA(66)/ &
2953 : & 2.14463263790822639D-05, 2.23954659232456514D-05, &
2954 : & 2.28967783814712629D-05, 2.30785389811177817D-05, &
2955 : & 2.30321976080909144D-05, 2.28236073720348722D-05, &
2956 : & 2.25005881105292418D-05, 2.20981015361991429D-05, &
2957 : & 2.16418427448103905D-05, 2.11507649256220843D-05, &
2958 : & 2.06388749782170737D-05, 2.01165241997081666D-05, &
2959 : & 1.95913450141179244D-05, 1.90689367910436740D-05, &
2960 : & 1.85533719641636667D-05, 1.80475722259674218D-05, &
2961 : & 5.52213076721292790D-04, 4.47932581552384646D-04, &
2962 : & 2.79520653992020589D-04, 1.52468156198446602D-04, &
2963 : & 6.93271105657043598D-05, 1.76258683069991397D-05/
2964 : DATA BETA(67), BETA(68), BETA(69), BETA(70), BETA(71), BETA(72), &
2965 : & BETA(73), BETA(74), BETA(75), BETA(76), BETA(77), BETA(78), &
2966 : & BETA(79), BETA(80), BETA(81), BETA(82), BETA(83), BETA(84), &
2967 : & BETA(85), BETA(86), BETA(87), BETA(88)/ &
2968 : & -1.35744996343269136D-05, -3.17972413350427135D-05, &
2969 : & -4.18861861696693365D-05, -4.69004889379141029D-05, &
2970 : & -4.87665447413787352D-05, -4.87010031186735069D-05, &
2971 : & -4.74755620890086638D-05, -4.55813058138628452D-05, &
2972 : & -4.33309644511266036D-05, -4.09230193157750364D-05, &
2973 : & -3.84822638603221274D-05, -3.60857167535410501D-05, &
2974 : & -3.37793306123367417D-05, -3.15888560772109621D-05, &
2975 : & -2.95269561750807315D-05, -2.75978914828335759D-05, &
2976 : & -2.58006174666883713D-05, -2.41308356761280200D-05, &
2977 : & -2.25823509518346033D-05, -2.11479656768912971D-05, &
2978 : & -1.98200638885294927D-05, -1.85909870801065077D-05/
2979 : DATA BETA(89), BETA(90), BETA(91), BETA(92), BETA(93), BETA(94), &
2980 : & BETA(95), BETA(96), BETA(97), BETA(98), BETA(99), BETA(100), &
2981 : & BETA(101), BETA(102), BETA(103), BETA(104), BETA(105), &
2982 : & BETA(106), BETA(107), BETA(108), BETA(109), BETA(110)/&
2983 : & -1.74532699844210224D-05, -1.63997823854497997D-05, &
2984 : & -4.74617796559959808D-04, -4.77864567147321487D-04, &
2985 : & -3.20390228067037603D-04, -1.61105016119962282D-04, &
2986 : & -4.25778101285435204D-05, 3.44571294294967503D-05, &
2987 : & 7.97092684075674924D-05, 1.03138236708272200D-04, &
2988 : & 1.12466775262204158D-04, 1.13103642108481389D-04, &
2989 : & 1.08651634848774268D-04, 1.01437951597661973D-04, &
2990 : & 9.29298396593363896D-05, 8.40293133016089978D-05, &
2991 : & 7.52727991349134062D-05, 6.69632521975730872D-05, &
2992 : & 5.92564547323194704D-05, 5.22169308826975567D-05, &
2993 : & 4.58539485165360646D-05, 4.01445513891486808D-05/
2994 : DATA BETA(111), BETA(112), BETA(113), BETA(114), BETA(115), &
2995 : & BETA(116), BETA(117), BETA(118), BETA(119), BETA(120), &
2996 : & BETA(121), BETA(122), BETA(123), BETA(124), BETA(125), &
2997 : & BETA(126), BETA(127), BETA(128), BETA(129), BETA(130)/ &
2998 : & 3.50481730031328081D-05, 3.05157995034346659D-05, &
2999 : & 2.64956119950516039D-05, 2.29363633690998152D-05, &
3000 : & 1.97893056664021636D-05, 1.70091984636412623D-05, &
3001 : & 1.45547428261524004D-05, 1.23886640995878413D-05, &
3002 : & 1.04775876076583236D-05, 8.79179954978479373D-06, &
3003 : & 7.36465810572578444D-04, 8.72790805146193976D-04, &
3004 : & 6.22614862573135066D-04, 2.85998154194304147D-04, &
3005 : & 3.84737672879366102D-06, -1.87906003636971558D-04, &
3006 : & -2.97603646594554535D-04, -3.45998126832656348D-04, &
3007 : & -3.53382470916037712D-04, -3.35715635775048757D-04/
3008 : DATA BETA(131), BETA(132), BETA(133), BETA(134), BETA(135), &
3009 : & BETA(136), BETA(137), BETA(138), BETA(139), BETA(140), &
3010 : & BETA(141), BETA(142), BETA(143), BETA(144), BETA(145), &
3011 : & BETA(146), BETA(147), BETA(148), BETA(149), BETA(150)/ &
3012 : & -3.04321124789039809D-04, -2.66722723047612821D-04, &
3013 : & -2.27654214122819527D-04, -1.89922611854562356D-04, &
3014 : & -1.55058918599093870D-04, -1.23778240761873630D-04, &
3015 : & -9.62926147717644187D-05, -7.25178327714425337D-05, &
3016 : & -5.22070028895633801D-05, -3.50347750511900522D-05, &
3017 : & -2.06489761035551757D-05, -8.70106096849767054D-06, &
3018 : & 1.13698686675100290D-06, 9.16426474122778849D-06, &
3019 : & 1.56477785428872620D-05, 2.08223629482466847D-05, &
3020 : & 2.48923381004595156D-05, 2.80340509574146325D-05, &
3021 : & 3.03987774629861915D-05, 3.21156731406700616D-05/
3022 : DATA BETA(151), BETA(152), BETA(153), BETA(154), BETA(155), &
3023 : & BETA(156), BETA(157), BETA(158), BETA(159), BETA(160), &
3024 : & BETA(161), BETA(162), BETA(163), BETA(164), BETA(165), &
3025 : & BETA(166), BETA(167), BETA(168), BETA(169), BETA(170)/ &
3026 : & -1.80182191963885708D-03, -2.43402962938042533D-03, &
3027 : & -1.83422663549856802D-03, -7.62204596354009765D-04, &
3028 : & 2.39079475256927218D-04, 9.49266117176881141D-04, &
3029 : & 1.34467449701540359D-03, 1.48457495259449178D-03, &
3030 : & 1.44732339830617591D-03, 1.30268261285657186D-03, &
3031 : & 1.10351597375642682D-03, 8.86047440419791759D-04, &
3032 : & 6.73073208165665473D-04, 4.77603872856582378D-04, &
3033 : & 3.05991926358789362D-04, 1.60315694594721630D-04, &
3034 : & 4.00749555270613286D-05, -5.66607461635251611D-05, &
3035 : & -1.32506186772982638D-04, -1.90296187989614057D-04/
3036 : DATA BETA(171), BETA(172), BETA(173), BETA(174), BETA(175), &
3037 : & BETA(176), BETA(177), BETA(178), BETA(179), BETA(180), &
3038 : & BETA(181), BETA(182), BETA(183), BETA(184), BETA(185), &
3039 : & BETA(186), BETA(187), BETA(188), BETA(189), BETA(190)/ &
3040 : & -2.32811450376937408D-04, -2.62628811464668841D-04, &
3041 : & -2.82050469867598672D-04, -2.93081563192861167D-04, &
3042 : & -2.97435962176316616D-04, -2.96557334239348078D-04, &
3043 : & -2.91647363312090861D-04, -2.83696203837734166D-04, &
3044 : & -2.73512317095673346D-04, -2.61750155806768580D-04, &
3045 : & 6.38585891212050914D-03, 9.62374215806377941D-03, &
3046 : & 7.61878061207001043D-03, 2.83219055545628054D-03, &
3047 : & -2.09841352012720090D-03, -5.73826764216626498D-03, &
3048 : & -7.70804244495414620D-03, -8.21011692264844401D-03, &
3049 : & -7.65824520346905413D-03, -6.47209729391045177D-03/
3050 : DATA BETA(191), BETA(192), BETA(193), BETA(194), BETA(195), &
3051 : & BETA(196), BETA(197), BETA(198), BETA(199), BETA(200), &
3052 : & BETA(201), BETA(202), BETA(203), BETA(204), BETA(205), &
3053 : & BETA(206), BETA(207), BETA(208), BETA(209), BETA(210)/ &
3054 : & -4.99132412004966473D-03, -3.45612289713133280D-03, &
3055 : & -2.01785580014170775D-03, -7.59430686781961401D-04, &
3056 : & 2.84173631523859138D-04, 1.10891667586337403D-03, &
3057 : & 1.72901493872728771D-03, 2.16812590802684701D-03, &
3058 : & 2.45357710494539735D-03, 2.61281821058334862D-03, &
3059 : & 2.67141039656276912D-03, 2.65203073395980430D-03, &
3060 : & 2.57411652877287315D-03, 2.45389126236094427D-03, &
3061 : & 2.30460058071795494D-03, 2.13684837686712662D-03, &
3062 : & 1.95896528478870911D-03, 1.77737008679454412D-03, &
3063 : & 1.59690280765839059D-03, 1.42111975664438546D-03/
3064 : DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), GAMA(6), &
3065 : & GAMA(7), GAMA(8), GAMA(9), GAMA(10), GAMA(11), GAMA(12), &
3066 : & GAMA(13), GAMA(14), GAMA(15), GAMA(16), GAMA(17), GAMA(18), &
3067 : & GAMA(19), GAMA(20), GAMA(21), GAMA(22)/ &
3068 : & 6.29960524947436582D-01, 2.51984209978974633D-01, &
3069 : & 1.54790300415655846D-01, 1.10713062416159013D-01, &
3070 : & 8.57309395527394825D-02, 6.97161316958684292D-02, &
3071 : & 5.86085671893713576D-02, 5.04698873536310685D-02, &
3072 : & 4.42600580689154809D-02, 3.93720661543509966D-02, &
3073 : & 3.54283195924455368D-02, 3.21818857502098231D-02, &
3074 : & 2.94646240791157679D-02, 2.71581677112934479D-02, &
3075 : & 2.51768272973861779D-02, 2.34570755306078891D-02, &
3076 : & 2.19508390134907203D-02, 2.06210828235646240D-02, &
3077 : & 1.94388240897880846D-02, 1.83810633800683158D-02, &
3078 : & 1.74293213231963172D-02, 1.65685837786612353D-02/
3079 : DATA GAMA(23), GAMA(24), GAMA(25), GAMA(26), GAMA(27), GAMA(28), &
3080 : & GAMA(29), GAMA(30)/ &
3081 : & 1.57865285987918445D-02, 1.50729501494095594D-02, &
3082 : & 1.44193250839954639D-02, 1.38184805735341786D-02, &
3083 : & 1.32643378994276568D-02, 1.27517121970498651D-02, &
3084 : & 1.22761545318762767D-02, 1.18338262398482403D-02/
3085 : DATA EX1, EX2, HPI, GPI, THPI / &
3086 : & 3.33333333333333333D-01, 6.66666666666666667D-01, &
3087 : & 1.57079632679489662D+00, 3.14159265358979324D+00, &
3088 : & 4.71238898038468986D+00/
3089 : DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
3090 : !C
3091 0 : RFNU = 1.0D0/FNU
3092 : !C-----------------------------------------------------------------------
3093 : !C OVERFLOW TEST (Z/FNU TOO SMALL)
3094 : !C-----------------------------------------------------------------------
3095 0 : TEST = D1MACH(1)*1.0D+3
3096 0 : AC = FNU*TEST
3097 0 : IF (DABS(ZR).GT.AC .OR. DABS(ZI).GT.AC) GO TO 15
3098 0 : ZETA1R = 2.0D0*DABS(DLOG(TEST))+FNU
3099 0 : ZETA1I = 0.0D0
3100 0 : ZETA2R = FNU
3101 0 : ZETA2I = 0.0D0
3102 0 : PHIR = 1.0D0
3103 0 : PHII = 0.0D0
3104 0 : ARGR = 1.0D0
3105 0 : ARGI = 0.0D0
3106 0 : RETURN
3107 : 15 CONTINUE
3108 0 : ZBR = ZR*RFNU
3109 0 : ZBI = ZI*RFNU
3110 0 : RFNU2 = RFNU*RFNU
3111 : !C-----------------------------------------------------------------------
3112 : !C COMPUTE IN THE FOURTH QUADRANT
3113 : !C-----------------------------------------------------------------------
3114 0 : FN13 = FNU**EX1
3115 0 : FN23 = FN13*FN13
3116 0 : RFN13 = 1.0D0/FN13
3117 0 : W2R = CONER - ZBR*ZBR + ZBI*ZBI
3118 0 : W2I = CONEI - ZBR*ZBI - ZBR*ZBI
3119 0 : AW2 = AZABS(W2R,W2I)
3120 0 : IF (AW2.GT.0.25D0) GO TO 130
3121 : !C-----------------------------------------------------------------------
3122 : !C POWER SERIES FOR CABS(W2).LE.0.25D0
3123 : !C-----------------------------------------------------------------------
3124 0 : K = 1
3125 0 : PR(1) = CONER
3126 0 : PI(1) = CONEI
3127 0 : SUMAR = GAMA(1)
3128 0 : SUMAI = ZEROI
3129 0 : AP(1) = 1.0D0
3130 0 : IF (AW2.LT.TOL) GO TO 20
3131 0 : DO 10 K=2,30
3132 0 : PR(K) = PR(K-1)*W2R - PI(K-1)*W2I
3133 0 : PI(K) = PR(K-1)*W2I + PI(K-1)*W2R
3134 0 : SUMAR = SUMAR + PR(K)*GAMA(K)
3135 0 : SUMAI = SUMAI + PI(K)*GAMA(K)
3136 0 : AP(K) = AP(K-1)*AW2
3137 0 : IF (AP(K).LT.TOL) GO TO 20
3138 0 : 10 CONTINUE
3139 0 : K = 30
3140 : 20 CONTINUE
3141 0 : KMAX = K
3142 0 : ZETAR = W2R*SUMAR - W2I*SUMAI
3143 0 : ZETAI = W2R*SUMAI + W2I*SUMAR
3144 0 : ARGR = ZETAR*FN23
3145 0 : ARGI = ZETAI*FN23
3146 0 : CALL AZSQRT(SUMAR, SUMAI, ZAR, ZAI)
3147 0 : CALL AZSQRT(W2R, W2I, STR, STI)
3148 0 : ZETA2R = STR*FNU
3149 0 : ZETA2I = STI*FNU
3150 0 : STR = CONER + EX2*(ZETAR*ZAR-ZETAI*ZAI)
3151 0 : STI = CONEI + EX2*(ZETAR*ZAI+ZETAI*ZAR)
3152 0 : ZETA1R = STR*ZETA2R - STI*ZETA2I
3153 0 : ZETA1I = STR*ZETA2I + STI*ZETA2R
3154 0 : ZAR = ZAR + ZAR
3155 0 : ZAI = ZAI + ZAI
3156 0 : CALL AZSQRT(ZAR, ZAI, STR, STI)
3157 0 : PHIR = STR*RFN13
3158 0 : PHII = STI*RFN13
3159 0 : IF (IPMTR.EQ.1) GO TO 120
3160 : !C-----------------------------------------------------------------------
3161 : !C SUM SERIES FOR ASUM AND BSUM
3162 : !C-----------------------------------------------------------------------
3163 0 : SUMBR = ZEROR
3164 0 : SUMBI = ZEROI
3165 0 : DO 30 K=1,KMAX
3166 0 : SUMBR = SUMBR + PR(K)*BETA(K)
3167 0 : SUMBI = SUMBI + PI(K)*BETA(K)
3168 0 : 30 CONTINUE
3169 0 : ASUMR = ZEROR
3170 0 : ASUMI = ZEROI
3171 0 : BSUMR = SUMBR
3172 0 : BSUMI = SUMBI
3173 0 : L1 = 0
3174 0 : L2 = 30
3175 0 : BTOL = TOL*(DABS(BSUMR)+DABS(BSUMI))
3176 0 : ATOL = TOL
3177 0 : PP = 1.0D0
3178 0 : IAS = 0
3179 0 : IBS = 0
3180 0 : IF (RFNU2.LT.TOL) GO TO 110
3181 0 : DO 100 IS=2,7
3182 0 : ATOL = ATOL/RFNU2
3183 0 : PP = PP*RFNU2
3184 0 : IF (IAS.EQ.1) GO TO 60
3185 0 : SUMAR = ZEROR
3186 0 : SUMAI = ZEROI
3187 0 : DO 40 K=1,KMAX
3188 0 : M = L1 + K
3189 0 : SUMAR = SUMAR + PR(K)*ALFA(M)
3190 0 : SUMAI = SUMAI + PI(K)*ALFA(M)
3191 0 : IF (AP(K).LT.ATOL) GO TO 50
3192 0 : 40 CONTINUE
3193 : 50 CONTINUE
3194 0 : ASUMR = ASUMR + SUMAR*PP
3195 0 : ASUMI = ASUMI + SUMAI*PP
3196 0 : IF (PP.LT.TOL) IAS = 1
3197 : 60 CONTINUE
3198 0 : IF (IBS.EQ.1) GO TO 90
3199 : SUMBR = ZEROR
3200 : SUMBI = ZEROI
3201 0 : DO 70 K=1,KMAX
3202 0 : M = L2 + K
3203 0 : SUMBR = SUMBR + PR(K)*BETA(M)
3204 0 : SUMBI = SUMBI + PI(K)*BETA(M)
3205 0 : IF (AP(K).LT.ATOL) GO TO 80
3206 0 : 70 CONTINUE
3207 : 80 CONTINUE
3208 0 : BSUMR = BSUMR + SUMBR*PP
3209 0 : BSUMI = BSUMI + SUMBI*PP
3210 0 : IF (PP.LT.BTOL) IBS = 1
3211 : 90 CONTINUE
3212 0 : IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 110
3213 0 : L1 = L1 + 30
3214 0 : L2 = L2 + 30
3215 0 : 100 CONTINUE
3216 : 110 CONTINUE
3217 0 : ASUMR = ASUMR + CONER
3218 0 : PP = RFNU*RFN13
3219 0 : BSUMR = BSUMR*PP
3220 0 : BSUMI = BSUMI*PP
3221 : 120 CONTINUE
3222 0 : RETURN
3223 : !C-----------------------------------------------------------------------
3224 : !C CABS(W2).GT.0.25D0
3225 : !C-----------------------------------------------------------------------
3226 : 130 CONTINUE
3227 0 : CALL AZSQRT(W2R, W2I, WR, WI)
3228 0 : IF (WR.LT.0.0D0) WR = 0.0D0
3229 0 : IF (WI.LT.0.0D0) WI = 0.0D0
3230 0 : STR = CONER + WR
3231 0 : STI = WI
3232 0 : CALL ZDIV(STR, STI, ZBR, ZBI, ZAR, ZAI)
3233 0 : CALL AZLOG(ZAR, ZAI, ZCR, ZCI, IDUM)
3234 0 : IF (ZCI.LT.0.0D0) ZCI = 0.0D0
3235 0 : IF (ZCI.GT.HPI) ZCI = HPI
3236 0 : IF (ZCR.LT.0.0D0) ZCR = 0.0D0
3237 0 : ZTHR = (ZCR-WR)*1.5D0
3238 0 : ZTHI = (ZCI-WI)*1.5D0
3239 0 : ZETA1R = ZCR*FNU
3240 0 : ZETA1I = ZCI*FNU
3241 0 : ZETA2R = WR*FNU
3242 0 : ZETA2I = WI*FNU
3243 0 : AZTH = AZABS(ZTHR,ZTHI)
3244 0 : ANG = THPI
3245 0 : IF (ZTHR.GE.0.0D0 .AND. ZTHI.LT.0.0D0) GO TO 140
3246 0 : ANG = HPI
3247 0 : IF (ZTHR.EQ.0.0D0) GO TO 140
3248 0 : ANG = DATAN(ZTHI/ZTHR)
3249 0 : IF (ZTHR.LT.0.0D0) ANG = ANG + GPI
3250 : 140 CONTINUE
3251 0 : PP = AZTH**EX2
3252 0 : ANG = ANG*EX2
3253 0 : ZETAR = PP*DCOS(ANG)
3254 0 : ZETAI = PP*DSIN(ANG)
3255 0 : IF (ZETAI.LT.0.0D0) ZETAI = 0.0D0
3256 0 : ARGR = ZETAR*FN23
3257 0 : ARGI = ZETAI*FN23
3258 0 : CALL ZDIV(ZTHR, ZTHI, ZETAR, ZETAI, RTZTR, RTZTI)
3259 0 : CALL ZDIV(RTZTR, RTZTI, WR, WI, ZAR, ZAI)
3260 0 : TZAR = ZAR + ZAR
3261 0 : TZAI = ZAI + ZAI
3262 0 : CALL AZSQRT(TZAR, TZAI, STR, STI)
3263 0 : PHIR = STR*RFN13
3264 0 : PHII = STI*RFN13
3265 0 : IF (IPMTR.EQ.1) GO TO 120
3266 0 : RAW = 1.0D0/DSQRT(AW2)
3267 0 : STR = WR*RAW
3268 0 : STI = -WI*RAW
3269 0 : TFNR = STR*RFNU*RAW
3270 0 : TFNI = STI*RFNU*RAW
3271 0 : RAZTH = 1.0D0/AZTH
3272 0 : STR = ZTHR*RAZTH
3273 0 : STI = -ZTHI*RAZTH
3274 0 : RZTHR = STR*RAZTH*RFNU
3275 0 : RZTHI = STI*RAZTH*RFNU
3276 0 : ZCR = RZTHR*AR(2)
3277 0 : ZCI = RZTHI*AR(2)
3278 0 : RAW2 = 1.0D0/AW2
3279 0 : STR = W2R*RAW2
3280 0 : STI = -W2I*RAW2
3281 0 : T2R = STR*RAW2
3282 0 : T2I = STI*RAW2
3283 0 : STR = T2R*C(2) + C(3)
3284 0 : STI = T2I*C(2)
3285 0 : UPR(2) = STR*TFNR - STI*TFNI
3286 0 : UPI(2) = STR*TFNI + STI*TFNR
3287 0 : BSUMR = UPR(2) + ZCR
3288 0 : BSUMI = UPI(2) + ZCI
3289 0 : ASUMR = ZEROR
3290 0 : ASUMI = ZEROI
3291 0 : IF (RFNU.LT.TOL) GO TO 220
3292 0 : PRZTHR = RZTHR
3293 0 : PRZTHI = RZTHI
3294 0 : PTFNR = TFNR
3295 0 : PTFNI = TFNI
3296 0 : UPR(1) = CONER
3297 0 : UPI(1) = CONEI
3298 0 : PP = 1.0D0
3299 0 : BTOL = TOL*(DABS(BSUMR)+DABS(BSUMI))
3300 0 : KS = 0
3301 0 : KP1 = 2
3302 0 : L = 3
3303 0 : IAS = 0
3304 0 : IBS = 0
3305 0 : DO 210 LR=2,12,2
3306 0 : LRP1 = LR + 1
3307 : !C-----------------------------------------------------------------------
3308 : !C COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE TERMS IN
3309 : !C NEXT SUMA AND SUMB
3310 : !C-----------------------------------------------------------------------
3311 0 : DO 160 K=LR,LRP1
3312 0 : KS = KS + 1
3313 0 : KP1 = KP1 + 1
3314 0 : L = L + 1
3315 0 : ZAR = C(L)
3316 0 : ZAI = ZEROI
3317 0 : DO 150 J=2,KP1
3318 0 : L = L + 1
3319 0 : STR = ZAR*T2R - T2I*ZAI + C(L)
3320 0 : ZAI = ZAR*T2I + ZAI*T2R
3321 0 : ZAR = STR
3322 0 : 150 CONTINUE
3323 0 : STR = PTFNR*TFNR - PTFNI*TFNI
3324 0 : PTFNI = PTFNR*TFNI + PTFNI*TFNR
3325 0 : PTFNR = STR
3326 0 : UPR(KP1) = PTFNR*ZAR - PTFNI*ZAI
3327 0 : UPI(KP1) = PTFNI*ZAR + PTFNR*ZAI
3328 0 : CRR(KS) = PRZTHR*BR(KS+1)
3329 0 : CRI(KS) = PRZTHI*BR(KS+1)
3330 0 : STR = PRZTHR*RZTHR - PRZTHI*RZTHI
3331 0 : PRZTHI = PRZTHR*RZTHI + PRZTHI*RZTHR
3332 0 : PRZTHR = STR
3333 0 : DRR(KS) = PRZTHR*AR(KS+2)
3334 0 : DRI(KS) = PRZTHI*AR(KS+2)
3335 0 : 160 CONTINUE
3336 0 : PP = PP*RFNU2
3337 0 : IF (IAS.EQ.1) GO TO 180
3338 0 : SUMAR = UPR(LRP1)
3339 0 : SUMAI = UPI(LRP1)
3340 0 : JU = LRP1
3341 0 : DO 170 JR=1,LR
3342 0 : JU = JU - 1
3343 0 : SUMAR = SUMAR + CRR(JR)*UPR(JU) - CRI(JR)*UPI(JU)
3344 0 : SUMAI = SUMAI + CRR(JR)*UPI(JU) + CRI(JR)*UPR(JU)
3345 0 : 170 CONTINUE
3346 0 : ASUMR = ASUMR + SUMAR
3347 0 : ASUMI = ASUMI + SUMAI
3348 0 : TEST = DABS(SUMAR) + DABS(SUMAI)
3349 0 : IF (PP.LT.TOL .AND. TEST.LT.TOL) IAS = 1
3350 : 180 CONTINUE
3351 0 : IF (IBS.EQ.1) GO TO 200
3352 0 : SUMBR = UPR(LR+2) + UPR(LRP1)*ZCR - UPI(LRP1)*ZCI
3353 0 : SUMBI = UPI(LR+2) + UPR(LRP1)*ZCI + UPI(LRP1)*ZCR
3354 0 : JU = LRP1
3355 0 : DO 190 JR=1,LR
3356 0 : JU = JU - 1
3357 0 : SUMBR = SUMBR + DRR(JR)*UPR(JU) - DRI(JR)*UPI(JU)
3358 0 : SUMBI = SUMBI + DRR(JR)*UPI(JU) + DRI(JR)*UPR(JU)
3359 0 : 190 CONTINUE
3360 0 : BSUMR = BSUMR + SUMBR
3361 0 : BSUMI = BSUMI + SUMBI
3362 0 : TEST = DABS(SUMBR) + DABS(SUMBI)
3363 0 : IF (PP.LT.BTOL .AND. TEST.LT.BTOL) IBS = 1
3364 : 200 CONTINUE
3365 0 : IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 220
3366 0 : 210 CONTINUE
3367 : 220 CONTINUE
3368 0 : ASUMR = ASUMR + CONER
3369 0 : STR = -BSUMR*RFN13
3370 0 : STI = -BSUMI*RFN13
3371 0 : CALL ZDIV(STR, STI, RTZTR, RTZTI, BSUMR, BSUMI)
3372 0 : GO TO 120
3373 : END SUBROUTINE ZUNHJ
3374 :
3375 0 : SUBROUTINE ZMLRI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL)
3376 : !C***BEGIN PROLOGUE ZMLRI
3377 : !C***REFER TO ZBESI,ZBESK
3378 : !C
3379 : !C ZMLRI COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY THE
3380 : !C MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES.
3381 : !C
3382 : !C***ROUTINES CALLED DGAMLN,D1MACH,AZABS,AZEXP,AZLOG,ZMLT
3383 : !C***END PROLOGUE ZMLRI
3384 : !C COMPLEX CK,CNORM,CONE,CTWO,CZERO,PT,P1,P2,RZ,SUM,Y,Z
3385 : DOUBLE PRECISION ACK, AK, AP, AT, AZ, BK, CKI, CKR, CNORMI, &
3386 : & CNORMR, CONEI, CONER, FKAP, FKK, FLAM, FNF, FNU, PTI, PTR, P1I, &
3387 : & P1R, P2I, P2R, RAZ, RHO, RHO2, RZI, RZR, SCLE, STI, STR, SUMI, &
3388 : & SUMR, TFNF, TOL, TST, YI, YR, ZEROI, ZEROR, ZI, ZR!, DGAMLN, &
3389 : ! & D1MACH, AZABS
3390 : INTEGER I, IAZ, IDUM, IFNU, INU, ITIME, K, KK, KM, KODE, M, N, NZ
3391 : DIMENSION YR(N), YI(N)
3392 : DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
3393 0 : SCLE = D1MACH(1)/TOL
3394 0 : NZ=0
3395 0 : AZ = AZABS(ZR,ZI)
3396 0 : IAZ = INT(SNGL(AZ))
3397 0 : IFNU = INT(SNGL(FNU))
3398 0 : INU = IFNU + N - 1
3399 0 : AT = DBLE(FLOAT(IAZ)) + 1.0D0
3400 0 : RAZ = 1.0D0/AZ
3401 0 : STR = ZR*RAZ
3402 0 : STI = -ZI*RAZ
3403 0 : CKR = STR*AT*RAZ
3404 0 : CKI = STI*AT*RAZ
3405 0 : RZR = (STR+STR)*RAZ
3406 0 : RZI = (STI+STI)*RAZ
3407 0 : P1R = ZEROR
3408 0 : P1I = ZEROI
3409 0 : P2R = CONER
3410 0 : P2I = CONEI
3411 0 : ACK = (AT+1.0D0)*RAZ
3412 0 : RHO = ACK + DSQRT(ACK*ACK-1.0D0)
3413 0 : RHO2 = RHO*RHO
3414 0 : TST = (RHO2+RHO2)/((RHO2-1.0D0)*(RHO-1.0D0))
3415 0 : TST = TST/TOL
3416 : !C-----------------------------------------------------------------------
3417 : !C COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES
3418 : !C-----------------------------------------------------------------------
3419 0 : AK = AT
3420 0 : DO 10 I=1,80
3421 0 : PTR = P2R
3422 0 : PTI = P2I
3423 0 : P2R = P1R - (CKR*PTR-CKI*PTI)
3424 0 : P2I = P1I - (CKI*PTR+CKR*PTI)
3425 0 : P1R = PTR
3426 0 : P1I = PTI
3427 0 : CKR = CKR + RZR
3428 0 : CKI = CKI + RZI
3429 0 : AP = AZABS(P2R,P2I)
3430 0 : IF (AP.GT.TST*AK*AK) GO TO 20
3431 0 : AK = AK + 1.0D0
3432 0 : 10 CONTINUE
3433 0 : GO TO 110
3434 : 20 CONTINUE
3435 0 : I = I + 1
3436 0 : K = 0
3437 0 : IF (INU.LT.IAZ) GO TO 40
3438 : !C-----------------------------------------------------------------------
3439 : !C COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS
3440 : !C-----------------------------------------------------------------------
3441 0 : P1R = ZEROR
3442 0 : P1I = ZEROI
3443 0 : P2R = CONER
3444 0 : P2I = CONEI
3445 0 : AT = DBLE(FLOAT(INU)) + 1.0D0
3446 : STR = ZR*RAZ
3447 : STI = -ZI*RAZ
3448 0 : CKR = STR*AT*RAZ
3449 0 : CKI = STI*AT*RAZ
3450 0 : ACK = AT*RAZ
3451 0 : TST = DSQRT(ACK/TOL)
3452 0 : ITIME = 1
3453 0 : DO 30 K=1,80
3454 0 : PTR = P2R
3455 0 : PTI = P2I
3456 0 : P2R = P1R - (CKR*PTR-CKI*PTI)
3457 0 : P2I = P1I - (CKR*PTI+CKI*PTR)
3458 0 : P1R = PTR
3459 0 : P1I = PTI
3460 0 : CKR = CKR + RZR
3461 0 : CKI = CKI + RZI
3462 0 : AP = AZABS(P2R,P2I)
3463 0 : IF (AP.LT.TST) GO TO 30
3464 0 : IF (ITIME.EQ.2) GO TO 40
3465 0 : ACK = AZABS(CKR,CKI)
3466 0 : FLAM = ACK + DSQRT(ACK*ACK-1.0D0)
3467 0 : FKAP = AP/AZABS(P1R,P1I)
3468 0 : RHO = DMIN1(FLAM,FKAP)
3469 0 : TST = TST*DSQRT(RHO/(RHO*RHO-1.0D0))
3470 0 : ITIME = 2
3471 0 : 30 CONTINUE
3472 0 : GO TO 110
3473 : 40 CONTINUE
3474 : !C-----------------------------------------------------------------------
3475 : !C BACKWARD RECURRENCE AND SUM NORMALIZING RELATION
3476 : !C-----------------------------------------------------------------------
3477 0 : K = K + 1
3478 0 : KK = MAX0(I+IAZ,K+INU)
3479 0 : FKK = DBLE(FLOAT(KK))
3480 0 : P1R = ZEROR
3481 0 : P1I = ZEROI
3482 : !C-----------------------------------------------------------------------
3483 : !C SCALE P2 AND SUM BY SCLE
3484 : !C-----------------------------------------------------------------------
3485 0 : P2R = SCLE
3486 0 : P2I = ZEROI
3487 0 : FNF = FNU - DBLE(FLOAT(IFNU))
3488 0 : TFNF = FNF + FNF
3489 : BK = DGAMLN(FKK+TFNF+1.0D0,IDUM) - DGAMLN(FKK+1.0D0,IDUM) - &
3490 0 : & DGAMLN(TFNF+1.0D0,IDUM)
3491 0 : BK = DEXP(BK)
3492 0 : SUMR = ZEROR
3493 0 : SUMI = ZEROI
3494 0 : KM = KK - INU
3495 0 : DO 50 I=1,KM
3496 0 : PTR = P2R
3497 0 : PTI = P2I
3498 0 : P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI)
3499 0 : P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI)
3500 0 : P1R = PTR
3501 0 : P1I = PTI
3502 0 : AK = 1.0D0 - TFNF/(FKK+TFNF)
3503 0 : ACK = BK*AK
3504 0 : SUMR = SUMR + (ACK+BK)*P1R
3505 0 : SUMI = SUMI + (ACK+BK)*P1I
3506 0 : BK = ACK
3507 0 : FKK = FKK - 1.0D0
3508 0 : 50 CONTINUE
3509 0 : YR(N) = P2R
3510 0 : YI(N) = P2I
3511 0 : IF (N.EQ.1) GO TO 70
3512 0 : DO 60 I=2,N
3513 0 : PTR = P2R
3514 0 : PTI = P2I
3515 0 : P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI)
3516 0 : P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI)
3517 0 : P1R = PTR
3518 0 : P1I = PTI
3519 0 : AK = 1.0D0 - TFNF/(FKK+TFNF)
3520 0 : ACK = BK*AK
3521 0 : SUMR = SUMR + (ACK+BK)*P1R
3522 0 : SUMI = SUMI + (ACK+BK)*P1I
3523 0 : BK = ACK
3524 0 : FKK = FKK - 1.0D0
3525 0 : M = N - I + 1
3526 0 : YR(M) = P2R
3527 0 : YI(M) = P2I
3528 0 : 60 CONTINUE
3529 : 70 CONTINUE
3530 0 : IF (IFNU.LE.0) GO TO 90
3531 0 : DO 80 I=1,IFNU
3532 0 : PTR = P2R
3533 0 : PTI = P2I
3534 0 : P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI)
3535 0 : P2I = P1I + (FKK+FNF)*(RZR*PTI+RZI*PTR)
3536 0 : P1R = PTR
3537 0 : P1I = PTI
3538 0 : AK = 1.0D0 - TFNF/(FKK+TFNF)
3539 0 : ACK = BK*AK
3540 0 : SUMR = SUMR + (ACK+BK)*P1R
3541 0 : SUMI = SUMI + (ACK+BK)*P1I
3542 0 : BK = ACK
3543 0 : FKK = FKK - 1.0D0
3544 0 : 80 CONTINUE
3545 : 90 CONTINUE
3546 0 : PTR = ZR
3547 0 : PTI = ZI
3548 0 : IF (KODE.EQ.2) PTR = ZEROR
3549 0 : CALL AZLOG(RZR, RZI, STR, STI, IDUM)
3550 0 : P1R = -FNF*STR + PTR
3551 0 : P1I = -FNF*STI + PTI
3552 0 : AP = DGAMLN(1.0D0+FNF,IDUM)
3553 0 : PTR = P1R - AP
3554 0 : PTI = P1I
3555 : !C-----------------------------------------------------------------------
3556 : !C THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW
3557 : !C IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES
3558 : !C-----------------------------------------------------------------------
3559 0 : P2R = P2R + SUMR
3560 0 : P2I = P2I + SUMI
3561 0 : AP = AZABS(P2R,P2I)
3562 0 : P1R = 1.0D0/AP
3563 0 : CALL AZEXP(PTR, PTI, STR, STI)
3564 0 : CKR = STR*P1R
3565 0 : CKI = STI*P1R
3566 0 : PTR = P2R*P1R
3567 0 : PTI = -P2I*P1R
3568 0 : CALL ZMLT(CKR, CKI, PTR, PTI, CNORMR, CNORMI)
3569 0 : DO 100 I=1,N
3570 0 : STR = YR(I)*CNORMR - YI(I)*CNORMI
3571 0 : YI(I) = YR(I)*CNORMI + YI(I)*CNORMR
3572 0 : YR(I) = STR
3573 0 : 100 CONTINUE
3574 : RETURN
3575 : 110 CONTINUE
3576 0 : NZ=-2
3577 0 : RETURN
3578 : END SUBROUTINE ZMLRI
3579 :
3580 0 : SUBROUTINE ZWRSK(ZRR, ZRI, FNU, KODE, N, YR, YI, NZ, CWR, CWI, &
3581 : & TOL, ELIM, ALIM)
3582 : !C***BEGIN PROLOGUE ZWRSK
3583 : !C***REFER TO ZBESI,ZBESK
3584 : !C
3585 : !C ZWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY
3586 : !C NORMALIZING THE I FUNCTION RATIOS FROM ZRATI BY THE WRONSKIAN
3587 : !C
3588 : !C***ROUTINES CALLED D1MACH,ZBKNU,ZRATI,AZABS
3589 : !C***END PROLOGUE ZWRSK
3590 : !C COMPLEX CINU,CSCL,CT,CW,C1,C2,RCT,ST,Y,ZR
3591 : DOUBLE PRECISION ACT, ACW, ALIM, ASCLE, CINUI, CINUR, CSCLR, CTI, &
3592 : & CTR, CWI, CWR, C1I, C1R, C2I, C2R, ELIM, FNU, PTI, PTR, RACT, &
3593 : & STI, STR, TOL, YI, YR, ZRI, ZRR!, AZABS, D1MACH
3594 : INTEGER I, KODE, N, NW, NZ
3595 : DIMENSION YR(N), YI(N), CWR(2), CWI(2)
3596 : !C-----------------------------------------------------------------------
3597 : !C I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS
3598 : !C Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM CRATI NORMALIZED BY THE
3599 : !C WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM CBKNU.
3600 : !C-----------------------------------------------------------------------
3601 0 : NZ = 0
3602 0 : CALL ZBKNU(ZRR, ZRI, FNU, KODE, 2, CWR, CWI, NW, TOL, ELIM, ALIM)
3603 0 : IF (NW.NE.0) GO TO 50
3604 0 : CALL ZRATI(ZRR, ZRI, FNU, N, YR, YI, TOL)
3605 : !C-----------------------------------------------------------------------
3606 : !C RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z),
3607 : !C R(FNU+J-1,Z)=Y(J), J=1,...,N
3608 : !C-----------------------------------------------------------------------
3609 0 : CINUR = 1.0D0
3610 0 : CINUI = 0.0D0
3611 0 : IF (KODE.EQ.1) GO TO 10
3612 0 : CINUR = DCOS(ZRI)
3613 0 : CINUI = DSIN(ZRI)
3614 : 10 CONTINUE
3615 : !C-----------------------------------------------------------------------
3616 : !C ON LOW EXPONENT MACHINES THE K FUNCTIONS CAN BE CLOSE TO BOTH
3617 : !C THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE
3618 : !C SCALED TO PREVENT OVER OR UNDERFLOW. CUOIK HAS DETERMINED THAT
3619 : !C THE RESULT IS ON SCALE.
3620 : !C-----------------------------------------------------------------------
3621 0 : ACW = AZABS(CWR(2),CWI(2))
3622 0 : ASCLE = 1.0D+3*D1MACH(1)/TOL
3623 0 : CSCLR = 1.0D0
3624 0 : IF (ACW.GT.ASCLE) GO TO 20
3625 0 : CSCLR = 1.0D0/TOL
3626 0 : GO TO 30
3627 : 20 CONTINUE
3628 0 : ASCLE = 1.0D0/ASCLE
3629 0 : IF (ACW.LT.ASCLE) GO TO 30
3630 0 : CSCLR = TOL
3631 : 30 CONTINUE
3632 0 : C1R = CWR(1)*CSCLR
3633 0 : C1I = CWI(1)*CSCLR
3634 0 : C2R = CWR(2)*CSCLR
3635 0 : C2I = CWI(2)*CSCLR
3636 0 : STR = YR(1)
3637 0 : STI = YI(1)
3638 : !C-----------------------------------------------------------------------
3639 : !C CINU=CINU*(CONJG(CT)/CABS(CT))*(1.0D0/CABS(CT) PREVENTS
3640 : !C UNDER- OR OVERFLOW PREMATURELY BY SQUARING CABS(CT)
3641 : !C-----------------------------------------------------------------------
3642 0 : PTR = STR*C1R - STI*C1I
3643 0 : PTI = STR*C1I + STI*C1R
3644 0 : PTR = PTR + C2R
3645 0 : PTI = PTI + C2I
3646 0 : CTR = ZRR*PTR - ZRI*PTI
3647 0 : CTI = ZRR*PTI + ZRI*PTR
3648 0 : ACT = AZABS(CTR,CTI)
3649 0 : RACT = 1.0D0/ACT
3650 0 : CTR = CTR*RACT
3651 0 : CTI = -CTI*RACT
3652 0 : PTR = CINUR*RACT
3653 0 : PTI = CINUI*RACT
3654 0 : CINUR = PTR*CTR - PTI*CTI
3655 0 : CINUI = PTR*CTI + PTI*CTR
3656 0 : YR(1) = CINUR*CSCLR
3657 0 : YI(1) = CINUI*CSCLR
3658 0 : IF (N.EQ.1) RETURN
3659 0 : DO 40 I=2,N
3660 0 : PTR = STR*CINUR - STI*CINUI
3661 0 : CINUI = STR*CINUI + STI*CINUR
3662 0 : CINUR = PTR
3663 0 : STR = YR(I)
3664 0 : STI = YI(I)
3665 0 : YR(I) = CINUR*CSCLR
3666 0 : YI(I) = CINUI*CSCLR
3667 0 : 40 CONTINUE
3668 0 : RETURN
3669 : 50 CONTINUE
3670 0 : NZ = -1
3671 0 : IF(NW.EQ.(-2)) NZ=-2
3672 : RETURN
3673 : END SUBROUTINE ZWRSK
3674 :
3675 0 : SUBROUTINE ZBKNU(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, &
3676 : & ALIM)
3677 : !C***BEGIN PROLOGUE ZBKNU
3678 : !C***REFER TO ZBESI,ZBESK,ZAIRY,ZBESH
3679 : !C
3680 : !C ZBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE.
3681 : !C
3682 : !C***ROUTINES CALLED DGAMLN,I1MACH,D1MACH,ZKSCL,ZSHCH,ZUCHK,AZABS,ZDIV,
3683 : !C AZEXP,AZLOG,ZMLT,AZSQRT
3684 : !C***END PROLOGUE ZBKNU
3685 : !C
3686 : DOUBLE PRECISION AA, AK, ALIM, ASCLE, A1, A2, BB, BK, BRY, CAZ, &
3687 : & CBI, CBR, CC, CCHI, CCHR, CKI, CKR, COEFI, COEFR, CONEI, CONER, &
3688 : & CRSCR, CSCLR, CSHI, CSHR, CSI, CSR, CSRR, CSSR, CTWOR, &
3689 : & CZEROI, CZEROR, CZI, CZR, DNU, DNU2, DPI, ELIM, ETEST, FC, FHS, &
3690 : & FI, FK, FKS, FMUI, FMUR, FNU, FPI, FR, G1, G2, HPI, PI, PR, PTI, &
3691 : & PTR, P1I, P1R, P2I, P2M, P2R, QI, QR, RAK, RCAZ, RTHPI, RZI, &
3692 : & RZR, R1, S, SMUI, SMUR, SPI, STI, STR, S1I, S1R, S2I, S2R, TM, &
3693 : & TOL, TTH, T1, T2, YI, YR, ZI, ZR, ELM, & ! , DGAMLN, D1MACH, AZABS,
3694 : & CELMR, ZDR, ZDI, AS, ALAS, HELIM, CYR, CYI
3695 : INTEGER I, IFLAG, INU, K, KFLAG, KK, KMAX, KODE, KODED, N, NZ, &
3696 : & IDUM, J, IC, INUB, NW !I1MACH
3697 : DIMENSION YR(N), YI(N), CC(8), CSSR(3), CSRR(3), BRY(3), CYR(2), &
3698 : & CYI(2)
3699 : !C COMPLEX Z,Y,A,B,RZ,SMU,FU,FMU,F,FLRZ,CZ,S1,S2,CSH,CCH
3700 : !C COMPLEX CK,P,Q,COEF,P1,P2,CBK,PT,CZERO,CONE,CTWO,ST,EZ,CS,DK
3701 : !C
3702 : DATA KMAX / 30 /
3703 : DATA CZEROR,CZEROI,CONER,CONEI,CTWOR,R1/ &
3704 : & 0.0D0 , 0.0D0 , 1.0D0 , 0.0D0 , 2.0D0 , 2.0D0 /
3705 : DATA DPI, RTHPI, SPI ,HPI, FPI, TTH / &
3706 : & 3.14159265358979324D0, 1.25331413731550025D0, &
3707 : & 1.90985931710274403D0, 1.57079632679489662D0, &
3708 : & 1.89769999331517738D0, 6.66666666666666666D-01/
3709 : DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)/ &
3710 : & 5.77215664901532861D-01, -4.20026350340952355D-02, &
3711 : & -4.21977345555443367D-02, 7.21894324666309954D-03, &
3712 : & -2.15241674114950973D-04, -2.01348547807882387D-05, &
3713 : & 1.13302723198169588D-06, 6.11609510448141582D-09/
3714 : !C
3715 0 : CAZ = AZABS(ZR,ZI)
3716 0 : CSCLR = 1.0D0/TOL
3717 0 : CRSCR = TOL
3718 0 : CSSR(1) = CSCLR
3719 0 : CSSR(2) = 1.0D0
3720 0 : CSSR(3) = CRSCR
3721 0 : CSRR(1) = CRSCR
3722 0 : CSRR(2) = 1.0D0
3723 0 : CSRR(3) = CSCLR
3724 0 : BRY(1) = 1.0D+3*D1MACH(1)/TOL
3725 0 : BRY(2) = 1.0D0/BRY(1)
3726 0 : BRY(3) = D1MACH(2)
3727 0 : NZ = 0
3728 0 : IFLAG = 0
3729 0 : KODED = KODE
3730 0 : RCAZ = 1.0D0/CAZ
3731 0 : STR = ZR*RCAZ
3732 0 : STI = -ZI*RCAZ
3733 0 : RZR = (STR+STR)*RCAZ
3734 0 : RZI = (STI+STI)*RCAZ
3735 0 : INU = INT(SNGL(FNU+0.5D0))
3736 0 : DNU = FNU - DBLE(FLOAT(INU))
3737 0 : IF (DABS(DNU).EQ.0.5D0) GO TO 110
3738 0 : DNU2 = 0.0D0
3739 0 : IF (DABS(DNU).GT.TOL) DNU2 = DNU*DNU
3740 0 : IF (CAZ.GT.R1) GO TO 110
3741 : !C-----------------------------------------------------------------------
3742 : !C SERIES FOR CABS(Z).LE.R1
3743 : !C-----------------------------------------------------------------------
3744 0 : FC = 1.0D0
3745 0 : CALL AZLOG(RZR, RZI, SMUR, SMUI, IDUM)
3746 0 : FMUR = SMUR*DNU
3747 0 : FMUI = SMUI*DNU
3748 0 : CALL ZSHCH(FMUR, FMUI, CSHR, CSHI, CCHR, CCHI)
3749 0 : IF (DNU.EQ.0.0D0) GO TO 10
3750 0 : FC = DNU*DPI
3751 0 : FC = FC/DSIN(FC)
3752 0 : SMUR = CSHR/DNU
3753 0 : SMUI = CSHI/DNU
3754 : 10 CONTINUE
3755 0 : A2 = 1.0D0 + DNU
3756 : !C-----------------------------------------------------------------------
3757 : !C GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU), T2=1/GAM(1+DNU)
3758 : !C-----------------------------------------------------------------------
3759 0 : T2 = DEXP(-DGAMLN(A2,IDUM))
3760 0 : T1 = 1.0D0/(T2*FC)
3761 0 : IF (DABS(DNU).GT.0.1D0) GO TO 40
3762 : !C-----------------------------------------------------------------------
3763 : !C SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU)
3764 : !C-----------------------------------------------------------------------
3765 0 : AK = 1.0D0
3766 0 : S = CC(1)
3767 0 : DO 20 K=2,8
3768 0 : AK = AK*DNU2
3769 0 : TM = CC(K)*AK
3770 0 : S = S + TM
3771 0 : IF (DABS(TM).LT.TOL) GO TO 30
3772 0 : 20 CONTINUE
3773 0 : 30 G1 = -S
3774 0 : GO TO 50
3775 : 40 CONTINUE
3776 0 : G1 = (T1-T2)/(DNU+DNU)
3777 : 50 CONTINUE
3778 0 : G2 = (T1+T2)*0.5D0
3779 0 : FR = FC*(CCHR*G1+SMUR*G2)
3780 0 : FI = FC*(CCHI*G1+SMUI*G2)
3781 0 : CALL AZEXP(FMUR, FMUI, STR, STI)
3782 0 : PR = 0.5D0*STR/T2
3783 0 : PI = 0.5D0*STI/T2
3784 0 : CALL ZDIV(0.5D0, 0.0D0, STR, STI, PTR, PTI)
3785 0 : QR = PTR/T1
3786 0 : QI = PTI/T1
3787 0 : S1R = FR
3788 0 : S1I = FI
3789 0 : S2R = PR
3790 0 : S2I = PI
3791 0 : AK = 1.0D0
3792 0 : A1 = 1.0D0
3793 0 : CKR = CONER
3794 0 : CKI = CONEI
3795 0 : BK = 1.0D0 - DNU2
3796 0 : IF (INU.GT.0 .OR. N.GT.1) GO TO 80
3797 : !C-----------------------------------------------------------------------
3798 : !C GENERATE K(FNU,Z), 0.0D0 .LE. FNU .LT. 0.5D0 AND N=1
3799 : !C-----------------------------------------------------------------------
3800 0 : IF (CAZ.LT.TOL) GO TO 70
3801 0 : CALL ZMLT(ZR, ZI, ZR, ZI, CZR, CZI)
3802 0 : CZR = 0.25D0*CZR
3803 0 : CZI = 0.25D0*CZI
3804 0 : T1 = 0.25D0*CAZ*CAZ
3805 : 60 CONTINUE
3806 0 : FR = (FR*AK+PR+QR)/BK
3807 0 : FI = (FI*AK+PI+QI)/BK
3808 0 : STR = 1.0D0/(AK-DNU)
3809 0 : PR = PR*STR
3810 0 : PI = PI*STR
3811 0 : STR = 1.0D0/(AK+DNU)
3812 0 : QR = QR*STR
3813 0 : QI = QI*STR
3814 0 : STR = CKR*CZR - CKI*CZI
3815 0 : RAK = 1.0D0/AK
3816 0 : CKI = (CKR*CZI+CKI*CZR)*RAK
3817 0 : CKR = STR*RAK
3818 0 : S1R = CKR*FR - CKI*FI + S1R
3819 0 : S1I = CKR*FI + CKI*FR + S1I
3820 0 : A1 = A1*T1*RAK
3821 0 : BK = BK + AK + AK + 1.0D0
3822 0 : AK = AK + 1.0D0
3823 0 : IF (A1.GT.TOL) GO TO 60
3824 : 70 CONTINUE
3825 0 : YR(1) = S1R
3826 0 : YI(1) = S1I
3827 0 : IF (KODED.EQ.1) RETURN
3828 0 : CALL AZEXP(ZR, ZI, STR, STI)
3829 0 : CALL ZMLT(S1R, S1I, STR, STI, YR(1), YI(1))
3830 0 : RETURN
3831 : !C-----------------------------------------------------------------------
3832 : !C GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE
3833 : !C-----------------------------------------------------------------------
3834 : 80 CONTINUE
3835 0 : IF (CAZ.LT.TOL) GO TO 100
3836 0 : CALL ZMLT(ZR, ZI, ZR, ZI, CZR, CZI)
3837 0 : CZR = 0.25D0*CZR
3838 0 : CZI = 0.25D0*CZI
3839 0 : T1 = 0.25D0*CAZ*CAZ
3840 : 90 CONTINUE
3841 0 : FR = (FR*AK+PR+QR)/BK
3842 0 : FI = (FI*AK+PI+QI)/BK
3843 0 : STR = 1.0D0/(AK-DNU)
3844 0 : PR = PR*STR
3845 0 : PI = PI*STR
3846 0 : STR = 1.0D0/(AK+DNU)
3847 0 : QR = QR*STR
3848 0 : QI = QI*STR
3849 0 : STR = CKR*CZR - CKI*CZI
3850 0 : RAK = 1.0D0/AK
3851 0 : CKI = (CKR*CZI+CKI*CZR)*RAK
3852 0 : CKR = STR*RAK
3853 0 : S1R = CKR*FR - CKI*FI + S1R
3854 0 : S1I = CKR*FI + CKI*FR + S1I
3855 0 : STR = PR - FR*AK
3856 0 : STI = PI - FI*AK
3857 0 : S2R = CKR*STR - CKI*STI + S2R
3858 0 : S2I = CKR*STI + CKI*STR + S2I
3859 0 : A1 = A1*T1*RAK
3860 0 : BK = BK + AK + AK + 1.0D0
3861 0 : AK = AK + 1.0D0
3862 0 : IF (A1.GT.TOL) GO TO 90
3863 : 100 CONTINUE
3864 0 : KFLAG = 2
3865 0 : A1 = FNU + 1.0D0
3866 0 : AK = A1*DABS(SMUR)
3867 0 : IF (AK.GT.ALIM) KFLAG = 3
3868 0 : STR = CSSR(KFLAG)
3869 0 : P2R = S2R*STR
3870 0 : P2I = S2I*STR
3871 0 : CALL ZMLT(P2R, P2I, RZR, RZI, S2R, S2I)
3872 0 : S1R = S1R*STR
3873 0 : S1I = S1I*STR
3874 0 : IF (KODED.EQ.1) GO TO 210
3875 0 : CALL AZEXP(ZR, ZI, FR, FI)
3876 0 : CALL ZMLT(S1R, S1I, FR, FI, S1R, S1I)
3877 0 : CALL ZMLT(S2R, S2I, FR, FI, S2R, S2I)
3878 0 : GO TO 210
3879 : !C-----------------------------------------------------------------------
3880 : !C IFLAG=0 MEANS NO UNDERFLOW OCCURRED
3881 : !C IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH
3882 : !C KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD
3883 : !C RECURSION
3884 : !C-----------------------------------------------------------------------
3885 : 110 CONTINUE
3886 0 : CALL AZSQRT(ZR, ZI, STR, STI)
3887 0 : CALL ZDIV(RTHPI, CZEROI, STR, STI, COEFR, COEFI)
3888 0 : KFLAG = 2
3889 0 : IF (KODED.EQ.2) GO TO 120
3890 0 : IF (ZR.GT.ALIM) GO TO 290
3891 : !C BLANK LINE
3892 0 : STR = DEXP(-ZR)*CSSR(KFLAG)
3893 0 : STI = -STR*DSIN(ZI)
3894 0 : STR = STR*DCOS(ZI)
3895 0 : CALL ZMLT(COEFR, COEFI, STR, STI, COEFR, COEFI)
3896 : 120 CONTINUE
3897 0 : IF (DABS(DNU).EQ.0.5D0) GO TO 300
3898 : !C-----------------------------------------------------------------------
3899 : !C MILLER ALGORITHM FOR CABS(Z).GT.R1
3900 : !C-----------------------------------------------------------------------
3901 0 : AK = DCOS(DPI*DNU)
3902 0 : AK = DABS(AK)
3903 0 : IF (AK.EQ.CZEROR) GO TO 300
3904 0 : FHS = DABS(0.25D0-DNU2)
3905 0 : IF (FHS.EQ.CZEROR) GO TO 300
3906 : !C-----------------------------------------------------------------------
3907 : !C COMPUTE R2=F(E). IF CABS(Z).GE.R2, USE FORWARD RECURRENCE TO
3908 : !C DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT LINE ON
3909 : !C 12.LE.E.LE.60. E IS COMPUTED FROM 2**(-E)=B**(1-I1MACH(14))=
3910 : !C TOL WHERE B IS THE BASE OF THE ARITHMETIC.
3911 : !C-----------------------------------------------------------------------
3912 0 : T1 = DBLE(FLOAT(I1MACH(14)-1))
3913 0 : T1 = T1*D1MACH(5)*3.321928094D0
3914 0 : T1 = DMAX1(T1,12.0D0)
3915 0 : T1 = DMIN1(T1,60.0D0)
3916 0 : T2 = TTH*T1 - 6.0D0
3917 0 : IF (ZR.NE.0.0D0) GO TO 130
3918 0 : T1 = HPI
3919 0 : GO TO 140
3920 : 130 CONTINUE
3921 0 : T1 = DATAN(ZI/ZR)
3922 0 : T1 = DABS(T1)
3923 : 140 CONTINUE
3924 0 : IF (T2.GT.CAZ) GO TO 170
3925 : !C-----------------------------------------------------------------------
3926 : !C FORWARD RECURRENCE LOOP WHEN CABS(Z).GE.R2
3927 : !C-----------------------------------------------------------------------
3928 0 : ETEST = AK/(DPI*CAZ*TOL)
3929 0 : FK = CONER
3930 0 : IF (ETEST.LT.CONER) GO TO 180
3931 0 : FKS = CTWOR
3932 0 : CKR = CAZ + CAZ + CTWOR
3933 0 : P1R = CZEROR
3934 0 : P2R = CONER
3935 0 : DO 150 I=1,KMAX
3936 0 : AK = FHS/FKS
3937 0 : CBR = CKR/(FK+CONER)
3938 0 : PTR = P2R
3939 0 : P2R = CBR*P2R - P1R*AK
3940 0 : P1R = PTR
3941 0 : CKR = CKR + CTWOR
3942 0 : FKS = FKS + FK + FK + CTWOR
3943 0 : FHS = FHS + FK + FK
3944 0 : FK = FK + CONER
3945 0 : STR = DABS(P2R)*FK
3946 0 : IF (ETEST.LT.STR) GO TO 160
3947 0 : 150 CONTINUE
3948 0 : GO TO 310
3949 : 160 CONTINUE
3950 0 : FK = FK + SPI*T1*DSQRT(T2/CAZ)
3951 0 : FHS = DABS(0.25D0-DNU2)
3952 0 : GO TO 180
3953 : 170 CONTINUE
3954 : !C-----------------------------------------------------------------------
3955 : !C COMPUTE BACKWARD INDEX K FOR CABS(Z).LT.R2
3956 : !C-----------------------------------------------------------------------
3957 0 : A2 = DSQRT(CAZ)
3958 0 : AK = FPI*AK/(TOL*DSQRT(A2))
3959 0 : AA = 3.0D0*T1/(1.0D0+CAZ)
3960 0 : BB = 14.7D0*T1/(28.0D0+CAZ)
3961 0 : AK = (DLOG(AK)+CAZ*DCOS(AA)/(1.0D0+0.008D0*CAZ))/DCOS(BB)
3962 0 : FK = 0.12125D0*AK*AK/CAZ + 1.5D0
3963 : 180 CONTINUE
3964 : !C-----------------------------------------------------------------------
3965 : !C BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM
3966 : !C-----------------------------------------------------------------------
3967 0 : K = INT(SNGL(FK))
3968 0 : FK = DBLE(FLOAT(K))
3969 0 : FKS = FK*FK
3970 0 : P1R = CZEROR
3971 0 : P1I = CZEROI
3972 0 : P2R = TOL
3973 0 : P2I = CZEROI
3974 0 : CSR = P2R
3975 0 : CSI = P2I
3976 0 : DO 190 I=1,K
3977 0 : A1 = FKS - FK
3978 0 : AK = (FKS+FK)/(A1+FHS)
3979 0 : RAK = 2.0D0/(FK+CONER)
3980 0 : CBR = (FK+ZR)*RAK
3981 0 : CBI = ZI*RAK
3982 0 : PTR = P2R
3983 0 : PTI = P2I
3984 0 : P2R = (PTR*CBR-PTI*CBI-P1R)*AK
3985 0 : P2I = (PTI*CBR+PTR*CBI-P1I)*AK
3986 0 : P1R = PTR
3987 0 : P1I = PTI
3988 0 : CSR = CSR + P2R
3989 0 : CSI = CSI + P2I
3990 0 : FKS = A1 - FK + CONER
3991 0 : FK = FK - CONER
3992 0 : 190 CONTINUE
3993 : !C-----------------------------------------------------------------------
3994 : !C COMPUTE (P2/CS)=(P2/CABS(CS))*(CONJG(CS)/CABS(CS)) FOR BETTER
3995 : !C SCALING
3996 : !C-----------------------------------------------------------------------
3997 0 : TM = AZABS(CSR,CSI)
3998 0 : PTR = 1.0D0/TM
3999 0 : S1R = P2R*PTR
4000 0 : S1I = P2I*PTR
4001 0 : CSR = CSR*PTR
4002 0 : CSI = -CSI*PTR
4003 0 : CALL ZMLT(COEFR, COEFI, S1R, S1I, STR, STI)
4004 0 : CALL ZMLT(STR, STI, CSR, CSI, S1R, S1I)
4005 0 : IF (INU.GT.0 .OR. N.GT.1) GO TO 200
4006 0 : ZDR = ZR
4007 0 : ZDI = ZI
4008 0 : IF(IFLAG.EQ.1) GO TO 270
4009 0 : GO TO 240
4010 : 200 CONTINUE
4011 : !C-----------------------------------------------------------------------
4012 : !C COMPUTE P1/P2=(P1/CABS(P2)*CONJG(P2)/CABS(P2) FOR SCALING
4013 : !C-----------------------------------------------------------------------
4014 0 : TM = AZABS(P2R,P2I)
4015 0 : PTR = 1.0D0/TM
4016 0 : P1R = P1R*PTR
4017 0 : P1I = P1I*PTR
4018 0 : P2R = P2R*PTR
4019 0 : P2I = -P2I*PTR
4020 0 : CALL ZMLT(P1R, P1I, P2R, P2I, PTR, PTI)
4021 0 : STR = DNU + 0.5D0 - PTR
4022 0 : STI = -PTI
4023 0 : CALL ZDIV(STR, STI, ZR, ZI, STR, STI)
4024 0 : STR = STR + 1.0D0
4025 0 : CALL ZMLT(STR, STI, S1R, S1I, S2R, S2I)
4026 : !C-----------------------------------------------------------------------
4027 : !C FORWARD RECURSION ON THE THREE TERM RECURSION WITH RELATION WITH
4028 : !C SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3
4029 : !C-----------------------------------------------------------------------
4030 : 210 CONTINUE
4031 0 : STR = DNU + 1.0D0
4032 0 : CKR = STR*RZR
4033 0 : CKI = STR*RZI
4034 0 : IF (N.EQ.1) INU = INU - 1
4035 0 : IF (INU.GT.0) GO TO 220
4036 0 : IF (N.GT.1) GO TO 215
4037 0 : S1R = S2R
4038 0 : S1I = S2I
4039 : 215 CONTINUE
4040 0 : ZDR = ZR
4041 0 : ZDI = ZI
4042 0 : IF(IFLAG.EQ.1) GO TO 270
4043 0 : GO TO 240
4044 : 220 CONTINUE
4045 0 : INUB = 1
4046 0 : IF(IFLAG.EQ.1) GO TO 261
4047 : 225 CONTINUE
4048 0 : P1R = CSRR(KFLAG)
4049 0 : ASCLE = BRY(KFLAG)
4050 0 : DO 230 I=INUB,INU
4051 0 : STR = S2R
4052 0 : STI = S2I
4053 0 : S2R = CKR*STR - CKI*STI + S1R
4054 0 : S2I = CKR*STI + CKI*STR + S1I
4055 0 : S1R = STR
4056 0 : S1I = STI
4057 0 : CKR = CKR + RZR
4058 0 : CKI = CKI + RZI
4059 0 : IF (KFLAG.GE.3) GO TO 230
4060 0 : P2R = S2R*P1R
4061 0 : P2I = S2I*P1R
4062 0 : STR = DABS(P2R)
4063 0 : STI = DABS(P2I)
4064 0 : P2M = DMAX1(STR,STI)
4065 0 : IF (P2M.LE.ASCLE) GO TO 230
4066 0 : KFLAG = KFLAG + 1
4067 0 : ASCLE = BRY(KFLAG)
4068 0 : S1R = S1R*P1R
4069 0 : S1I = S1I*P1R
4070 : S2R = P2R
4071 : S2I = P2I
4072 0 : STR = CSSR(KFLAG)
4073 0 : S1R = S1R*STR
4074 0 : S1I = S1I*STR
4075 0 : S2R = S2R*STR
4076 0 : S2I = S2I*STR
4077 0 : P1R = CSRR(KFLAG)
4078 0 : 230 CONTINUE
4079 0 : IF (N.NE.1) GO TO 240
4080 0 : S1R = S2R
4081 0 : S1I = S2I
4082 : 240 CONTINUE
4083 0 : STR = CSRR(KFLAG)
4084 0 : YR(1) = S1R*STR
4085 0 : YI(1) = S1I*STR
4086 0 : IF (N.EQ.1) RETURN
4087 0 : YR(2) = S2R*STR
4088 0 : YI(2) = S2I*STR
4089 0 : IF (N.EQ.2) RETURN
4090 : KK = 2
4091 : 250 CONTINUE
4092 0 : KK = KK + 1
4093 0 : IF (KK.GT.N) RETURN
4094 0 : P1R = CSRR(KFLAG)
4095 0 : ASCLE = BRY(KFLAG)
4096 0 : DO 260 I=KK,N
4097 0 : P2R = S2R
4098 0 : P2I = S2I
4099 0 : S2R = CKR*P2R - CKI*P2I + S1R
4100 0 : S2I = CKI*P2R + CKR*P2I + S1I
4101 0 : S1R = P2R
4102 0 : S1I = P2I
4103 0 : CKR = CKR + RZR
4104 0 : CKI = CKI + RZI
4105 0 : P2R = S2R*P1R
4106 0 : P2I = S2I*P1R
4107 0 : YR(I) = P2R
4108 0 : YI(I) = P2I
4109 0 : IF (KFLAG.GE.3) GO TO 260
4110 0 : STR = DABS(P2R)
4111 0 : STI = DABS(P2I)
4112 0 : P2M = DMAX1(STR,STI)
4113 0 : IF (P2M.LE.ASCLE) GO TO 260
4114 0 : KFLAG = KFLAG + 1
4115 0 : ASCLE = BRY(KFLAG)
4116 0 : S1R = S1R*P1R
4117 0 : S1I = S1I*P1R
4118 : S2R = P2R
4119 : S2I = P2I
4120 0 : STR = CSSR(KFLAG)
4121 0 : S1R = S1R*STR
4122 0 : S1I = S1I*STR
4123 0 : S2R = S2R*STR
4124 0 : S2I = S2I*STR
4125 0 : P1R = CSRR(KFLAG)
4126 0 : 260 CONTINUE
4127 0 : RETURN
4128 : !C-----------------------------------------------------------------------
4129 : !C IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW
4130 : !C-----------------------------------------------------------------------
4131 : 261 CONTINUE
4132 0 : HELIM = 0.5D0*ELIM
4133 0 : ELM = DEXP(-ELIM)
4134 0 : CELMR = ELM
4135 0 : ASCLE = BRY(1)
4136 0 : ZDR = ZR
4137 0 : ZDI = ZI
4138 0 : IC = -1
4139 0 : J = 2
4140 0 : DO 262 I=1,INU
4141 0 : STR = S2R
4142 0 : STI = S2I
4143 0 : S2R = STR*CKR-STI*CKI+S1R
4144 0 : S2I = STI*CKR+STR*CKI+S1I
4145 0 : S1R = STR
4146 0 : S1I = STI
4147 0 : CKR = CKR+RZR
4148 0 : CKI = CKI+RZI
4149 0 : AS = AZABS(S2R,S2I)
4150 0 : ALAS = DLOG(AS)
4151 0 : P2R = -ZDR+ALAS
4152 0 : IF(P2R.LT.(-ELIM)) GO TO 263
4153 0 : CALL AZLOG(S2R,S2I,STR,STI,IDUM)
4154 0 : P2R = -ZDR+STR
4155 0 : P2I = -ZDI+STI
4156 0 : P2M = DEXP(P2R)/TOL
4157 0 : P1R = P2M*DCOS(P2I)
4158 0 : P1I = P2M*DSIN(P2I)
4159 0 : CALL ZUCHK(P1R,P1I,NW,ASCLE,TOL)
4160 : IF(NW.NE.0) GO TO 263
4161 0 : J = 3 - J
4162 0 : CYR(J) = P1R
4163 0 : CYI(J) = P1I
4164 0 : IF(IC.EQ.(I-1)) GO TO 264
4165 : IC = I
4166 0 : GO TO 262
4167 : 263 CONTINUE
4168 0 : IF(ALAS.LT.HELIM) GO TO 262
4169 0 : ZDR = ZDR-ELIM
4170 0 : S1R = S1R*CELMR
4171 0 : S1I = S1I*CELMR
4172 0 : S2R = S2R*CELMR
4173 0 : S2I = S2I*CELMR
4174 0 : 262 CONTINUE
4175 0 : IF(N.NE.1) GO TO 270
4176 0 : S1R = S2R
4177 0 : S1I = S2I
4178 0 : GO TO 270
4179 : 264 CONTINUE
4180 0 : KFLAG = 1
4181 0 : INUB = I+1
4182 0 : S2R = CYR(J)
4183 0 : S2I = CYI(J)
4184 0 : J = 3 - J
4185 0 : S1R = CYR(J)
4186 0 : S1I = CYI(J)
4187 0 : IF(INUB.LE.INU) GO TO 225
4188 0 : IF(N.NE.1) GO TO 240
4189 0 : S1R = S2R
4190 0 : S1I = S2I
4191 0 : GO TO 240
4192 : 270 CONTINUE
4193 0 : YR(1) = S1R
4194 0 : YI(1) = S1I
4195 0 : IF(N.EQ.1) GO TO 280
4196 0 : YR(2) = S2R
4197 0 : YI(2) = S2I
4198 : 280 CONTINUE
4199 0 : ASCLE = BRY(1)
4200 0 : CALL ZKSCL(ZDR,ZDI,FNU,N,YR,YI,NZ,RZR,RZI,ASCLE,TOL,ELIM)
4201 0 : INU = N - NZ
4202 0 : IF (INU.LE.0) RETURN
4203 0 : KK = NZ + 1
4204 0 : S1R = YR(KK)
4205 0 : S1I = YI(KK)
4206 0 : YR(KK) = S1R*CSRR(1)
4207 0 : YI(KK) = S1I*CSRR(1)
4208 0 : IF (INU.EQ.1) RETURN
4209 0 : KK = NZ + 2
4210 0 : S2R = YR(KK)
4211 0 : S2I = YI(KK)
4212 0 : YR(KK) = S2R*CSRR(1)
4213 0 : YI(KK) = S2I*CSRR(1)
4214 0 : IF (INU.EQ.2) RETURN
4215 0 : T2 = FNU + DBLE(FLOAT(KK-1))
4216 0 : CKR = T2*RZR
4217 0 : CKI = T2*RZI
4218 0 : KFLAG = 1
4219 0 : GO TO 250
4220 : 290 CONTINUE
4221 : !C-----------------------------------------------------------------------
4222 : !C SCALE BY DEXP(Z), IFLAG = 1 CASES
4223 : !C-----------------------------------------------------------------------
4224 0 : KODED = 2
4225 : IFLAG = 1
4226 : KFLAG = 2
4227 0 : GO TO 120
4228 : !C-----------------------------------------------------------------------
4229 : !C FNU=HALF ODD INTEGER CASE, DNU=-0.5
4230 : !C-----------------------------------------------------------------------
4231 : 300 CONTINUE
4232 0 : S1R = COEFR
4233 0 : S1I = COEFI
4234 0 : S2R = COEFR
4235 0 : S2I = COEFI
4236 0 : GO TO 210
4237 : !C
4238 : !C
4239 : 310 CONTINUE
4240 0 : NZ=-2
4241 0 : RETURN
4242 : END SUBROUTINE ZBKNU
4243 :
4244 0 : SUBROUTINE ZRATI(ZR, ZI, FNU, N, CYR, CYI, TOL)
4245 : !C***BEGIN PROLOGUE ZRATI
4246 : !C***REFER TO ZBESI,ZBESK,ZBESH
4247 : !C
4248 : !C ZRATI COMPUTES RATIOS OF I BESSEL FUNCTIONS BY BACKWARD
4249 : !C RECURRENCE. THE STARTING INDEX IS DETERMINED BY FORWARD
4250 : !C RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B,
4251 : !C MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973,
4252 : !C BESSEL FUNCTIONS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER,
4253 : !C BY D. J. SOOKNE.
4254 : !C
4255 : !C***ROUTINES CALLED AZABS,ZDIV
4256 : !C***END PROLOGUE ZRATI
4257 : !C COMPLEX Z,CY(1),CONE,CZERO,P1,P2,T1,RZ,PT,CDFNU
4258 : DOUBLE PRECISION AK, AMAGZ, AP1, AP2, ARG, AZ, CDFNUI, CDFNUR, &
4259 : & CONEI, CONER, CYI, CYR, CZEROI, CZEROR, DFNU, FDNU, FLAM, FNU, &
4260 : & FNUP, PTI, PTR, P1I, P1R, P2I, P2R, RAK, RAP1, RHO, RT2, RZI, &
4261 : & RZR, TEST, TEST1, TOL, TTI, TTR, T1I, T1R, ZI, ZR!, AZABS
4262 : INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ, N
4263 : DIMENSION CYR(N), CYI(N)
4264 : DATA CZEROR,CZEROI,CONER,CONEI,RT2/ &
4265 : & 0.0D0, 0.0D0, 1.0D0, 0.0D0, 1.41421356237309505D0 /
4266 0 : AZ = AZABS(ZR,ZI)
4267 0 : INU = INT(SNGL(FNU))
4268 0 : IDNU = INU + N - 1
4269 0 : MAGZ = INT(SNGL(AZ))
4270 0 : AMAGZ = DBLE(FLOAT(MAGZ+1))
4271 0 : FDNU = DBLE(FLOAT(IDNU))
4272 0 : FNUP = DMAX1(AMAGZ,FDNU)
4273 0 : ID = IDNU - MAGZ - 1
4274 0 : ITIME = 1
4275 0 : K = 1
4276 0 : PTR = 1.0D0/AZ
4277 0 : RZR = PTR*(ZR+ZR)*PTR
4278 0 : RZI = -PTR*(ZI+ZI)*PTR
4279 0 : T1R = RZR*FNUP
4280 0 : T1I = RZI*FNUP
4281 0 : P2R = -T1R
4282 0 : P2I = -T1I
4283 0 : P1R = CONER
4284 0 : P1I = CONEI
4285 0 : T1R = T1R + RZR
4286 0 : T1I = T1I + RZI
4287 0 : IF (ID.GT.0) ID = 0
4288 0 : AP2 = AZABS(P2R,P2I)
4289 0 : AP1 = AZABS(P1R,P1I)
4290 : !C-----------------------------------------------------------------------
4291 : !C THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNU
4292 : !C GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT
4293 : !C P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR
4294 : !C PREMATURELY.
4295 : !C-----------------------------------------------------------------------
4296 0 : ARG = (AP2+AP2)/(AP1*TOL)
4297 0 : TEST1 = DSQRT(ARG)
4298 0 : TEST = TEST1
4299 0 : RAP1 = 1.0D0/AP1
4300 0 : P1R = P1R*RAP1
4301 0 : P1I = P1I*RAP1
4302 0 : P2R = P2R*RAP1
4303 0 : P2I = P2I*RAP1
4304 0 : AP2 = AP2*RAP1
4305 : 10 CONTINUE
4306 0 : K = K + 1
4307 0 : AP1 = AP2
4308 0 : PTR = P2R
4309 0 : PTI = P2I
4310 0 : P2R = P1R - (T1R*PTR-T1I*PTI)
4311 0 : P2I = P1I - (T1R*PTI+T1I*PTR)
4312 0 : P1R = PTR
4313 0 : P1I = PTI
4314 0 : T1R = T1R + RZR
4315 0 : T1I = T1I + RZI
4316 0 : AP2 = AZABS(P2R,P2I)
4317 0 : IF (AP1.LE.TEST) GO TO 10
4318 0 : IF (ITIME.EQ.2) GO TO 20
4319 0 : AK = AZABS(T1R,T1I)*0.5D0
4320 0 : FLAM = AK + DSQRT(AK*AK-1.0D0)
4321 0 : RHO = DMIN1(AP2/AP1,FLAM)
4322 0 : TEST = TEST1*DSQRT(RHO/(RHO*RHO-1.0D0))
4323 0 : ITIME = 2
4324 0 : GO TO 10
4325 : 20 CONTINUE
4326 0 : KK = K + 1 - ID
4327 0 : AK = DBLE(FLOAT(KK))
4328 0 : T1R = AK
4329 0 : T1I = CZEROI
4330 0 : DFNU = FNU + DBLE(FLOAT(N-1))
4331 0 : P1R = 1.0D0/AP2
4332 0 : P1I = CZEROI
4333 0 : P2R = CZEROR
4334 0 : P2I = CZEROI
4335 0 : DO 30 I=1,KK
4336 0 : PTR = P1R
4337 0 : PTI = P1I
4338 0 : RAP1 = DFNU + T1R
4339 0 : TTR = RZR*RAP1
4340 0 : TTI = RZI*RAP1
4341 0 : P1R = (PTR*TTR-PTI*TTI) + P2R
4342 0 : P1I = (PTR*TTI+PTI*TTR) + P2I
4343 0 : P2R = PTR
4344 0 : P2I = PTI
4345 0 : T1R = T1R - CONER
4346 0 : 30 CONTINUE
4347 0 : IF (P1R.NE.CZEROR .OR. P1I.NE.CZEROI) GO TO 40
4348 0 : P1R = TOL
4349 0 : P1I = TOL
4350 : 40 CONTINUE
4351 0 : CALL ZDIV(P2R, P2I, P1R, P1I, CYR(N), CYI(N))
4352 0 : IF (N.EQ.1) RETURN
4353 0 : K = N - 1
4354 0 : AK = DBLE(FLOAT(K))
4355 0 : T1R = AK
4356 : T1I = CZEROI
4357 0 : CDFNUR = FNU*RZR
4358 0 : CDFNUI = FNU*RZI
4359 0 : DO 60 I=2,N
4360 0 : PTR = CDFNUR + (T1R*RZR-T1I*RZI) + CYR(K+1)
4361 0 : PTI = CDFNUI + (T1R*RZI+T1I*RZR) + CYI(K+1)
4362 0 : AK = AZABS(PTR,PTI)
4363 0 : IF (AK.NE.CZEROR) GO TO 50
4364 0 : PTR = TOL
4365 0 : PTI = TOL
4366 0 : AK = TOL*RT2
4367 : 50 CONTINUE
4368 0 : RAK = CONER/AK
4369 0 : CYR(K) = RAK*PTR*RAK
4370 0 : CYI(K) = -RAK*PTI*RAK
4371 0 : T1R = T1R - CONER
4372 0 : K = K - 1
4373 0 : 60 CONTINUE
4374 : RETURN
4375 : END SUBROUTINE ZRATI
4376 :
4377 0 : SUBROUTINE ZBUNI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NUI, NLAST, &
4378 : & FNUL, TOL, ELIM, ALIM)
4379 : !C***BEGIN PROLOGUE ZBUNI
4380 : !C***REFER TO ZBESI,ZBESK
4381 : !C
4382 : !C ZBUNI COMPUTES THE I BESSEL FUNCTION FOR LARGE CABS(Z).GT.
4383 : !C FNUL AND FNU+N-1.LT.FNUL. THE ORDER IS INCREASED FROM
4384 : !C FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING
4385 : !C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z)
4386 : !C ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2
4387 : !C
4388 : !C***ROUTINES CALLED ZUNI1,ZUNI2,AZABS,D1MACH
4389 : !C***END PROLOGUE ZBUNI
4390 : !C COMPLEX CSCL,CSCR,CY,RZ,ST,S1,S2,Y,Z
4391 : DOUBLE PRECISION ALIM, AX, AY, CSCLR, CSCRR, CYI, CYR, DFNU, &
4392 : & ELIM, FNU, FNUI, FNUL, GNU, RAZ, RZI, RZR, STI, STR, S1I, S1R, &
4393 : & S2I, S2R, TOL, YI, YR, ZI, ZR, ASCLE, BRY, C1R, C1I, C1M!,AZABS &
4394 : !& D1MACH
4395 : INTEGER I, IFLAG, IFORM, K, KODE, N, NL, NLAST, NUI, NW, NZ
4396 : DIMENSION YR(N), YI(N), CYR(2), CYI(2), BRY(3)
4397 0 : NZ = 0
4398 0 : AX = DABS(ZR)*1.7321D0
4399 0 : AY = DABS(ZI)
4400 0 : IFORM = 1
4401 0 : IF (AY.GT.AX) IFORM = 2
4402 0 : IF (NUI.EQ.0) GO TO 60
4403 0 : FNUI = DBLE(FLOAT(NUI))
4404 0 : DFNU = FNU + DBLE(FLOAT(N-1))
4405 0 : GNU = DFNU + FNUI
4406 0 : IF (IFORM.EQ.2) GO TO 10
4407 : !C-----------------------------------------------------------------------
4408 : !C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN
4409 : !C -PI/3.LE.ARG(Z).LE.PI/3
4410 : !C-----------------------------------------------------------------------
4411 : CALL ZUNI1(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, &
4412 0 : & ELIM, ALIM)
4413 0 : GO TO 20
4414 : 10 CONTINUE
4415 : !C-----------------------------------------------------------------------
4416 : !C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU
4417 : !C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I
4418 : !C AND HPI=PI/2
4419 : !C-----------------------------------------------------------------------
4420 : CALL ZUNI2(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, &
4421 0 : & ELIM, ALIM)
4422 : 20 CONTINUE
4423 0 : IF (NW.LT.0) GO TO 50
4424 0 : IF (NW.NE.0) GO TO 90
4425 0 : STR = AZABS(CYR(1),CYI(1))
4426 : !C----------------------------------------------------------------------
4427 : !C SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER USED
4428 : !C----------------------------------------------------------------------
4429 0 : BRY(1)=1.0D+3*D1MACH(1)/TOL
4430 0 : BRY(2) = 1.0D0/BRY(1)
4431 0 : BRY(3) = BRY(2)
4432 0 : IFLAG = 2
4433 0 : ASCLE = BRY(2)
4434 0 : CSCLR = 1.0D0
4435 0 : IF (STR.GT.BRY(1)) GO TO 21
4436 0 : IFLAG = 1
4437 0 : ASCLE = BRY(1)
4438 0 : CSCLR = 1.0D0/TOL
4439 0 : GO TO 25
4440 : 21 CONTINUE
4441 0 : IF (STR.LT.BRY(2)) GO TO 25
4442 0 : IFLAG = 3
4443 0 : ASCLE=BRY(3)
4444 0 : CSCLR = TOL
4445 : 25 CONTINUE
4446 0 : CSCRR = 1.0D0/CSCLR
4447 0 : S1R = CYR(2)*CSCLR
4448 0 : S1I = CYI(2)*CSCLR
4449 0 : S2R = CYR(1)*CSCLR
4450 0 : S2I = CYI(1)*CSCLR
4451 0 : RAZ = 1.0D0/AZABS(ZR,ZI)
4452 0 : STR = ZR*RAZ
4453 0 : STI = -ZI*RAZ
4454 0 : RZR = (STR+STR)*RAZ
4455 0 : RZI = (STI+STI)*RAZ
4456 0 : DO 30 I=1,NUI
4457 0 : STR = S2R
4458 0 : STI = S2I
4459 0 : S2R = (DFNU+FNUI)*(RZR*STR-RZI*STI) + S1R
4460 0 : S2I = (DFNU+FNUI)*(RZR*STI+RZI*STR) + S1I
4461 0 : S1R = STR
4462 0 : S1I = STI
4463 0 : FNUI = FNUI - 1.0D0
4464 0 : IF (IFLAG.GE.3) GO TO 30
4465 0 : STR = S2R*CSCRR
4466 0 : STI = S2I*CSCRR
4467 0 : C1R = DABS(STR)
4468 0 : C1I = DABS(STI)
4469 0 : C1M = DMAX1(C1R,C1I)
4470 0 : IF (C1M.LE.ASCLE) GO TO 30
4471 0 : IFLAG = IFLAG+1
4472 0 : ASCLE = BRY(IFLAG)
4473 0 : S1R = S1R*CSCRR
4474 0 : S1I = S1I*CSCRR
4475 0 : S2R = STR
4476 0 : S2I = STI
4477 0 : CSCLR = CSCLR*TOL
4478 0 : CSCRR = 1.0D0/CSCLR
4479 0 : S1R = S1R*CSCLR
4480 0 : S1I = S1I*CSCLR
4481 0 : S2R = S2R*CSCLR
4482 0 : S2I = S2I*CSCLR
4483 0 : 30 CONTINUE
4484 0 : YR(N) = S2R*CSCRR
4485 0 : YI(N) = S2I*CSCRR
4486 0 : IF (N.EQ.1) RETURN
4487 0 : NL = N - 1
4488 0 : FNUI = DBLE(FLOAT(NL))
4489 0 : K = NL
4490 0 : DO 40 I=1,NL
4491 0 : STR = S2R
4492 0 : STI = S2I
4493 0 : S2R = (FNU+FNUI)*(RZR*STR-RZI*STI) + S1R
4494 0 : S2I = (FNU+FNUI)*(RZR*STI+RZI*STR) + S1I
4495 0 : S1R = STR
4496 0 : S1I = STI
4497 0 : STR = S2R*CSCRR
4498 0 : STI = S2I*CSCRR
4499 0 : YR(K) = STR
4500 0 : YI(K) = STI
4501 0 : FNUI = FNUI - 1.0D0
4502 0 : K = K - 1
4503 0 : IF (IFLAG.GE.3) GO TO 40
4504 0 : C1R = DABS(STR)
4505 0 : C1I = DABS(STI)
4506 0 : C1M = DMAX1(C1R,C1I)
4507 0 : IF (C1M.LE.ASCLE) GO TO 40
4508 0 : IFLAG = IFLAG+1
4509 0 : ASCLE = BRY(IFLAG)
4510 0 : S1R = S1R*CSCRR
4511 0 : S1I = S1I*CSCRR
4512 0 : S2R = STR
4513 0 : S2I = STI
4514 0 : CSCLR = CSCLR*TOL
4515 0 : CSCRR = 1.0D0/CSCLR
4516 0 : S1R = S1R*CSCLR
4517 0 : S1I = S1I*CSCLR
4518 0 : S2R = S2R*CSCLR
4519 0 : S2I = S2I*CSCLR
4520 0 : 40 CONTINUE
4521 0 : RETURN
4522 : 50 CONTINUE
4523 0 : NZ = -1
4524 0 : IF(NW.EQ.(-2)) NZ=-2
4525 0 : RETURN
4526 : 60 CONTINUE
4527 0 : IF (IFORM.EQ.2) GO TO 70
4528 : !C-----------------------------------------------------------------------
4529 : !C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN
4530 : !C -PI/3.LE.ARG(Z).LE.PI/3
4531 : !C-----------------------------------------------------------------------
4532 : CALL ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL, &
4533 0 : & ELIM, ALIM)
4534 0 : GO TO 80
4535 : 70 CONTINUE
4536 : !C-----------------------------------------------------------------------
4537 : !C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU
4538 : !C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I
4539 : !C AND HPI=PI/2
4540 : !C-----------------------------------------------------------------------
4541 : CALL ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL, &
4542 0 : & ELIM, ALIM)
4543 : 80 CONTINUE
4544 0 : IF (NW.LT.0) GO TO 50
4545 0 : NZ = NW
4546 0 : RETURN
4547 : 90 CONTINUE
4548 0 : NLAST = N
4549 0 : RETURN
4550 : END SUBROUTINE ZBUNI
4551 :
4552 0 : SUBROUTINE ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, &
4553 : & TOL, ELIM, ALIM)
4554 : !C***BEGIN PROLOGUE ZUNI1
4555 : !C***REFER TO ZBESI,ZBESK
4556 : !C
4557 : !C ZUNI1 COMPUTES I(FNU,Z) BY MEANS OF THE UNIFORM ASYMPTOTIC
4558 : !C EXPANSION FOR I(FNU,Z) IN -PI/3.LE.ARG Z.LE.PI/3.
4559 : !C
4560 : !C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC
4561 : !C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET.
4562 : !C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER
4563 : !C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL.
4564 : !C Y(I)=CZERO FOR I=NLAST+1,N
4565 : !C
4566 : !C***ROUTINES CALLED ZUCHK,ZUNIK,ZUOIK,D1MACH,AZABS
4567 : !C***END PROLOGUE ZUNI1
4568 : !C COMPLEX CFN,CONE,CRSC,CSCL,CSR,CSS,CWRK,CZERO,C1,C2,PHI,RZ,SUM,S1,
4569 : !C *S2,Y,Z,ZETA1,ZETA2
4570 : DOUBLE PRECISION ALIM, APHI, ASCLE, BRY, CONER, CRSC, &
4571 : & CSCL, CSRR, CSSR, CWRKI, CWRKR, C1R, C2I, C2M, C2R, ELIM, FN, &
4572 : & FNU, FNUL, PHII, PHIR, RAST, RS1, RZI, RZR, STI, STR, SUMI, &
4573 : & SUMR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, &
4574 : & ZETA1R, ZETA2I, ZETA2R, ZI, ZR, CYR, CYI!, D1MACH, AZABS
4575 : INTEGER I, IFLAG, INIT, K, KODE, M, N, ND, NLAST, NN, NUF, NW, NZ
4576 : DIMENSION BRY(3), YR(N), YI(N), CWRKR(16), CWRKI(16), CSSR(3), &
4577 : & CSRR(3), CYR(2), CYI(2)
4578 : DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 /
4579 : !C
4580 0 : NZ = 0
4581 0 : ND = N
4582 0 : NLAST = 0
4583 : !C-----------------------------------------------------------------------
4584 : !C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG-
4585 : !C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE,
4586 : !C EXP(ALIM)=EXP(ELIM)*TOL
4587 : !C-----------------------------------------------------------------------
4588 0 : CSCL = 1.0D0/TOL
4589 0 : CRSC = TOL
4590 0 : CSSR(1) = CSCL
4591 0 : CSSR(2) = CONER
4592 0 : CSSR(3) = CRSC
4593 0 : CSRR(1) = CRSC
4594 0 : CSRR(2) = CONER
4595 0 : CSRR(3) = CSCL
4596 0 : BRY(1) = 1.0D+3*D1MACH(1)/TOL
4597 : !C-----------------------------------------------------------------------
4598 : !C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER
4599 : !C-----------------------------------------------------------------------
4600 0 : FN = DMAX1(FNU,1.0D0)
4601 0 : INIT = 0
4602 : CALL ZUNIK(ZR, ZI, FN, 1, 1, TOL, INIT, PHIR, PHII, ZETA1R, &
4603 0 : & ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI)
4604 0 : IF (KODE.EQ.1) GO TO 10
4605 0 : STR = ZR + ZETA2R
4606 0 : STI = ZI + ZETA2I
4607 0 : RAST = FN/AZABS(STR,STI)
4608 0 : STR = STR*RAST*RAST
4609 0 : STI = -STI*RAST*RAST
4610 0 : S1R = -ZETA1R + STR
4611 0 : S1I = -ZETA1I + STI
4612 0 : GO TO 20
4613 : 10 CONTINUE
4614 0 : S1R = -ZETA1R + ZETA2R
4615 0 : S1I = -ZETA1I + ZETA2I
4616 : 20 CONTINUE
4617 0 : RS1 = S1R
4618 0 : IF (DABS(RS1).GT.ELIM) GO TO 130
4619 : 30 CONTINUE
4620 0 : NN = MIN0(2,ND)
4621 0 : DO 80 I=1,NN
4622 0 : FN = FNU + DBLE(FLOAT(ND-I))
4623 0 : INIT = 0
4624 : CALL ZUNIK(ZR, ZI, FN, 1, 0, TOL, INIT, PHIR, PHII, ZETA1R, &
4625 0 : & ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI)
4626 0 : IF (KODE.EQ.1) GO TO 40
4627 0 : STR = ZR + ZETA2R
4628 0 : STI = ZI + ZETA2I
4629 0 : RAST = FN/AZABS(STR,STI)
4630 0 : STR = STR*RAST*RAST
4631 0 : STI = -STI*RAST*RAST
4632 0 : S1R = -ZETA1R + STR
4633 0 : S1I = -ZETA1I + STI + ZI
4634 0 : GO TO 50
4635 : 40 CONTINUE
4636 0 : S1R = -ZETA1R + ZETA2R
4637 0 : S1I = -ZETA1I + ZETA2I
4638 : 50 CONTINUE
4639 : !C-----------------------------------------------------------------------
4640 : !C TEST FOR UNDERFLOW AND OVERFLOW
4641 : !C-----------------------------------------------------------------------
4642 0 : RS1 = S1R
4643 0 : IF (DABS(RS1).GT.ELIM) GO TO 110
4644 0 : IF (I.EQ.1) IFLAG = 2
4645 0 : IF (DABS(RS1).LT.ALIM) GO TO 60
4646 : !C-----------------------------------------------------------------------
4647 : !C REFINE TEST AND SCALE
4648 : !C-----------------------------------------------------------------------
4649 0 : APHI = AZABS(PHIR,PHII)
4650 0 : RS1 = RS1 + DLOG(APHI)
4651 0 : IF (DABS(RS1).GT.ELIM) GO TO 110
4652 0 : IF (I.EQ.1) IFLAG = 1
4653 0 : IF (RS1.LT.0.0D0) GO TO 60
4654 0 : IF (I.EQ.1) IFLAG = 3
4655 : 60 CONTINUE
4656 : !C-----------------------------------------------------------------------
4657 : !C SCALE S1 IF CABS(S1).LT.ASCLE
4658 : !C-----------------------------------------------------------------------
4659 0 : S2R = PHIR*SUMR - PHII*SUMI
4660 0 : S2I = PHIR*SUMI + PHII*SUMR
4661 0 : STR = DEXP(S1R)*CSSR(IFLAG)
4662 0 : S1R = STR*DCOS(S1I)
4663 0 : S1I = STR*DSIN(S1I)
4664 0 : STR = S2R*S1R - S2I*S1I
4665 0 : S2I = S2R*S1I + S2I*S1R
4666 0 : S2R = STR
4667 0 : IF (IFLAG.NE.1) GO TO 70
4668 0 : CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL)
4669 : IF (NW.NE.0) GO TO 110
4670 : 70 CONTINUE
4671 0 : CYR(I) = S2R
4672 0 : CYI(I) = S2I
4673 0 : M = ND - I + 1
4674 0 : YR(M) = S2R*CSRR(IFLAG)
4675 0 : YI(M) = S2I*CSRR(IFLAG)
4676 0 : 80 CONTINUE
4677 0 : IF (ND.LE.2) GO TO 100
4678 0 : RAST = 1.0D0/AZABS(ZR,ZI)
4679 0 : STR = ZR*RAST
4680 0 : STI = -ZI*RAST
4681 0 : RZR = (STR+STR)*RAST
4682 0 : RZI = (STI+STI)*RAST
4683 0 : BRY(2) = 1.0D0/BRY(1)
4684 0 : BRY(3) = D1MACH(2)
4685 0 : S1R = CYR(1)
4686 0 : S1I = CYI(1)
4687 0 : S2R = CYR(2)
4688 0 : S2I = CYI(2)
4689 0 : C1R = CSRR(IFLAG)
4690 0 : ASCLE = BRY(IFLAG)
4691 0 : K = ND - 2
4692 0 : FN = DBLE(FLOAT(K))
4693 0 : DO 90 I=3,ND
4694 0 : C2R = S2R
4695 0 : C2I = S2I
4696 0 : S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I)
4697 0 : S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R)
4698 0 : S1R = C2R
4699 0 : S1I = C2I
4700 0 : C2R = S2R*C1R
4701 0 : C2I = S2I*C1R
4702 0 : YR(K) = C2R
4703 0 : YI(K) = C2I
4704 0 : K = K - 1
4705 0 : FN = FN - 1.0D0
4706 0 : IF (IFLAG.GE.3) GO TO 90
4707 0 : STR = DABS(C2R)
4708 0 : STI = DABS(C2I)
4709 0 : C2M = DMAX1(STR,STI)
4710 0 : IF (C2M.LE.ASCLE) GO TO 90
4711 0 : IFLAG = IFLAG + 1
4712 0 : ASCLE = BRY(IFLAG)
4713 0 : S1R = S1R*C1R
4714 0 : S1I = S1I*C1R
4715 0 : S2R = C2R
4716 0 : S2I = C2I
4717 0 : S1R = S1R*CSSR(IFLAG)
4718 0 : S1I = S1I*CSSR(IFLAG)
4719 0 : S2R = S2R*CSSR(IFLAG)
4720 0 : S2I = S2I*CSSR(IFLAG)
4721 0 : C1R = CSRR(IFLAG)
4722 0 : 90 CONTINUE
4723 : 100 CONTINUE
4724 0 : RETURN
4725 : !C-----------------------------------------------------------------------
4726 : !C SET UNDERFLOW AND UPDATE PARAMETERS
4727 : !C-----------------------------------------------------------------------
4728 : 110 CONTINUE
4729 0 : IF (RS1.GT.0.0D0) GO TO 120
4730 0 : YR(ND) = ZEROR
4731 0 : YI(ND) = ZEROI
4732 0 : NZ = NZ + 1
4733 0 : ND = ND - 1
4734 0 : IF (ND.EQ.0) GO TO 100
4735 0 : CALL ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM)
4736 0 : IF (NUF.LT.0) GO TO 120
4737 0 : ND = ND - NUF
4738 0 : NZ = NZ + NUF
4739 0 : IF (ND.EQ.0) GO TO 100
4740 0 : FN = FNU + DBLE(FLOAT(ND-1))
4741 0 : IF (FN.GE.FNUL) GO TO 30
4742 0 : NLAST = ND
4743 0 : RETURN
4744 : 120 CONTINUE
4745 0 : NZ = -1
4746 0 : RETURN
4747 : 130 CONTINUE
4748 0 : IF (RS1.GT.0.0D0) GO TO 120
4749 0 : NZ = N
4750 0 : DO 140 I=1,N
4751 0 : YR(I) = ZEROR
4752 0 : YI(I) = ZEROI
4753 0 : 140 CONTINUE
4754 : RETURN
4755 : END SUBROUTINE ZUNI1
4756 :
4757 0 : SUBROUTINE ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, &
4758 : & TOL, ELIM, ALIM)
4759 : !C***BEGIN PROLOGUE ZUNI2
4760 : !C***REFER TO ZBESI,ZBESK
4761 : !C
4762 : !C ZUNI2 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF
4763 : !C UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I
4764 : !C OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO.
4765 : !C
4766 : !C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC
4767 : !C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET.
4768 : !C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER
4769 : !C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL.
4770 : !C Y(I)=CZERO FOR I=NLAST+1,N
4771 : !C
4772 : !C***ROUTINES CALLED ZAIRY,ZUCHK,ZUNHJ,ZUOIK,D1MACH,AZABS
4773 : !C***END PROLOGUE ZUNI2
4774 : !C COMPLEX AI,ARG,ASUM,BSUM,CFN,CI,CID,CIP,CONE,CRSC,CSCL,CSR,CSS,
4775 : !C *CZERO,C1,C2,DAI,PHI,RZ,S1,S2,Y,Z,ZB,ZETA1,ZETA2,ZN
4776 : DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGI, &
4777 : & ARGR, ASCLE, ASUMI, ASUMR, BRY, BSUMI, BSUMR, CIDI, CIPI, CIPR, &
4778 : & CONER, CRSC, CSCL, CSRR, CSSR, C1R, C2I, C2M, C2R, DAII, &
4779 : & DAIR, ELIM, FN, FNU, FNUL, HPI, PHII, PHIR, RAST, RAZ, RS1, RZI, &
4780 : & RZR, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZBI, ZBR, ZEROI, &
4781 : & ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, ZNI, ZNR, ZR, CYR, &
4782 : & CYI, CAR, SAR !D1MACH, AZABS
4783 : INTEGER I, IFLAG, IN, INU, J, K, KODE, N, NAI, ND, NDAI, NLAST, &
4784 : & NN, NUF, NW, NZ, IDUM
4785 : DIMENSION BRY(3), YR(N), YI(N), CIPR(4), CIPI(4), CSSR(3), &
4786 : & CSRR(3), CYR(2), CYI(2)
4787 : DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 /
4788 : DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4), &
4789 : & CIPI(4)/ 1.0D0,0.0D0, 0.0D0,1.0D0, -1.0D0,0.0D0, 0.0D0,-1.0D0/
4790 : DATA HPI, AIC / &
4791 : & 1.57079632679489662D+00, 1.265512123484645396D+00/
4792 : !C
4793 0 : NZ = 0
4794 0 : ND = N
4795 0 : NLAST = 0
4796 : !C-----------------------------------------------------------------------
4797 : !C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG-
4798 : !C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE,
4799 : !C EXP(ALIM)=EXP(ELIM)*TOL
4800 : !C-----------------------------------------------------------------------
4801 0 : CSCL = 1.0D0/TOL
4802 0 : CRSC = TOL
4803 0 : CSSR(1) = CSCL
4804 0 : CSSR(2) = CONER
4805 0 : CSSR(3) = CRSC
4806 0 : CSRR(1) = CRSC
4807 0 : CSRR(2) = CONER
4808 0 : CSRR(3) = CSCL
4809 0 : BRY(1) = 1.0D+3*D1MACH(1)/TOL
4810 : !C-----------------------------------------------------------------------
4811 : !C ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI
4812 : !C-----------------------------------------------------------------------
4813 0 : ZNR = ZI
4814 0 : ZNI = -ZR
4815 0 : ZBR = ZR
4816 0 : ZBI = ZI
4817 0 : CIDI = -CONER
4818 0 : INU = INT(SNGL(FNU))
4819 0 : ANG = HPI*(FNU-DBLE(FLOAT(INU)))
4820 0 : C2R = DCOS(ANG)
4821 0 : C2I = DSIN(ANG)
4822 0 : CAR = C2R
4823 0 : SAR = C2I
4824 0 : IN = INU + N - 1
4825 0 : IN = MOD(IN,4) + 1
4826 0 : STR = C2R*CIPR(IN) - C2I*CIPI(IN)
4827 0 : C2I = C2R*CIPI(IN) + C2I*CIPR(IN)
4828 0 : C2R = STR
4829 0 : IF (ZI.GT.0.0D0) GO TO 10
4830 0 : ZNR = -ZNR
4831 0 : ZBI = -ZBI
4832 0 : CIDI = -CIDI
4833 0 : C2I = -C2I
4834 : 10 CONTINUE
4835 : !C-----------------------------------------------------------------------
4836 : !C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER
4837 : !C-----------------------------------------------------------------------
4838 0 : FN = DMAX1(FNU,1.0D0)
4839 : CALL ZUNHJ(ZNR, ZNI, FN, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, &
4840 0 : & ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI)
4841 0 : IF (KODE.EQ.1) GO TO 20
4842 0 : STR = ZBR + ZETA2R
4843 0 : STI = ZBI + ZETA2I
4844 0 : RAST = FN/AZABS(STR,STI)
4845 0 : STR = STR*RAST*RAST
4846 0 : STI = -STI*RAST*RAST
4847 0 : S1R = -ZETA1R + STR
4848 0 : S1I = -ZETA1I + STI
4849 0 : GO TO 30
4850 : 20 CONTINUE
4851 0 : S1R = -ZETA1R + ZETA2R
4852 0 : S1I = -ZETA1I + ZETA2I
4853 : 30 CONTINUE
4854 0 : RS1 = S1R
4855 0 : IF (DABS(RS1).GT.ELIM) GO TO 150
4856 : 40 CONTINUE
4857 0 : NN = MIN0(2,ND)
4858 0 : DO 90 I=1,NN
4859 0 : FN = FNU + DBLE(FLOAT(ND-I))
4860 : CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR, PHII, ARGR, ARGI, &
4861 0 : & ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI)
4862 0 : IF (KODE.EQ.1) GO TO 50
4863 0 : STR = ZBR + ZETA2R
4864 0 : STI = ZBI + ZETA2I
4865 0 : RAST = FN/AZABS(STR,STI)
4866 0 : STR = STR*RAST*RAST
4867 0 : STI = -STI*RAST*RAST
4868 0 : S1R = -ZETA1R + STR
4869 0 : S1I = -ZETA1I + STI + DABS(ZI)
4870 0 : GO TO 60
4871 : 50 CONTINUE
4872 0 : S1R = -ZETA1R + ZETA2R
4873 0 : S1I = -ZETA1I + ZETA2I
4874 : 60 CONTINUE
4875 : !C-----------------------------------------------------------------------
4876 : !C TEST FOR UNDERFLOW AND OVERFLOW
4877 : !C-----------------------------------------------------------------------
4878 0 : RS1 = S1R
4879 0 : IF (DABS(RS1).GT.ELIM) GO TO 120
4880 0 : IF (I.EQ.1) IFLAG = 2
4881 0 : IF (DABS(RS1).LT.ALIM) GO TO 70
4882 : !C-----------------------------------------------------------------------
4883 : !C REFINE TEST AND SCALE
4884 : !C-----------------------------------------------------------------------
4885 : !C-----------------------------------------------------------------------
4886 0 : APHI = AZABS(PHIR,PHII)
4887 0 : AARG = AZABS(ARGR,ARGI)
4888 0 : RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC
4889 0 : IF (DABS(RS1).GT.ELIM) GO TO 120
4890 0 : IF (I.EQ.1) IFLAG = 1
4891 0 : IF (RS1.LT.0.0D0) GO TO 70
4892 0 : IF (I.EQ.1) IFLAG = 3
4893 : 70 CONTINUE
4894 : !C-----------------------------------------------------------------------
4895 : !C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR
4896 : !C EXPONENT EXTREMES
4897 : !C-----------------------------------------------------------------------
4898 0 : CALL ZAIRY(ARGR, ARGI, 0, 2, AIR, AII, NAI, IDUM)
4899 0 : CALL ZAIRY(ARGR, ARGI, 1, 2, DAIR, DAII, NDAI, IDUM)
4900 0 : STR = DAIR*BSUMR - DAII*BSUMI
4901 0 : STI = DAIR*BSUMI + DAII*BSUMR
4902 0 : STR = STR + (AIR*ASUMR-AII*ASUMI)
4903 0 : STI = STI + (AIR*ASUMI+AII*ASUMR)
4904 0 : S2R = PHIR*STR - PHII*STI
4905 0 : S2I = PHIR*STI + PHII*STR
4906 0 : STR = DEXP(S1R)*CSSR(IFLAG)
4907 0 : S1R = STR*DCOS(S1I)
4908 0 : S1I = STR*DSIN(S1I)
4909 0 : STR = S2R*S1R - S2I*S1I
4910 0 : S2I = S2R*S1I + S2I*S1R
4911 0 : S2R = STR
4912 0 : IF (IFLAG.NE.1) GO TO 80
4913 0 : CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL)
4914 : IF (NW.NE.0) GO TO 120
4915 : 80 CONTINUE
4916 0 : IF (ZI.LE.0.0D0) S2I = -S2I
4917 0 : STR = S2R*C2R - S2I*C2I
4918 0 : S2I = S2R*C2I + S2I*C2R
4919 0 : S2R = STR
4920 0 : CYR(I) = S2R
4921 0 : CYI(I) = S2I
4922 0 : J = ND - I + 1
4923 0 : YR(J) = S2R*CSRR(IFLAG)
4924 0 : YI(J) = S2I*CSRR(IFLAG)
4925 0 : STR = -C2I*CIDI
4926 0 : C2I = C2R*CIDI
4927 0 : C2R = STR
4928 0 : 90 CONTINUE
4929 0 : IF (ND.LE.2) GO TO 110
4930 0 : RAZ = 1.0D0/AZABS(ZR,ZI)
4931 0 : STR = ZR*RAZ
4932 0 : STI = -ZI*RAZ
4933 0 : RZR = (STR+STR)*RAZ
4934 0 : RZI = (STI+STI)*RAZ
4935 0 : BRY(2) = 1.0D0/BRY(1)
4936 0 : BRY(3) = D1MACH(2)
4937 0 : S1R = CYR(1)
4938 0 : S1I = CYI(1)
4939 0 : S2R = CYR(2)
4940 0 : S2I = CYI(2)
4941 0 : C1R = CSRR(IFLAG)
4942 0 : ASCLE = BRY(IFLAG)
4943 0 : K = ND - 2
4944 0 : FN = DBLE(FLOAT(K))
4945 0 : DO 100 I=3,ND
4946 0 : C2R = S2R
4947 0 : C2I = S2I
4948 0 : S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I)
4949 0 : S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R)
4950 0 : S1R = C2R
4951 0 : S1I = C2I
4952 0 : C2R = S2R*C1R
4953 0 : C2I = S2I*C1R
4954 0 : YR(K) = C2R
4955 0 : YI(K) = C2I
4956 0 : K = K - 1
4957 0 : FN = FN - 1.0D0
4958 0 : IF (IFLAG.GE.3) GO TO 100
4959 0 : STR = DABS(C2R)
4960 0 : STI = DABS(C2I)
4961 0 : C2M = DMAX1(STR,STI)
4962 0 : IF (C2M.LE.ASCLE) GO TO 100
4963 0 : IFLAG = IFLAG + 1
4964 0 : ASCLE = BRY(IFLAG)
4965 0 : S1R = S1R*C1R
4966 0 : S1I = S1I*C1R
4967 0 : S2R = C2R
4968 0 : S2I = C2I
4969 0 : S1R = S1R*CSSR(IFLAG)
4970 0 : S1I = S1I*CSSR(IFLAG)
4971 0 : S2R = S2R*CSSR(IFLAG)
4972 0 : S2I = S2I*CSSR(IFLAG)
4973 0 : C1R = CSRR(IFLAG)
4974 0 : 100 CONTINUE
4975 : 110 CONTINUE
4976 0 : RETURN
4977 : 120 CONTINUE
4978 0 : IF (RS1.GT.0.0D0) GO TO 140
4979 : !C-----------------------------------------------------------------------
4980 : !C SET UNDERFLOW AND UPDATE PARAMETERS
4981 : !C-----------------------------------------------------------------------
4982 0 : YR(ND) = ZEROR
4983 0 : YI(ND) = ZEROI
4984 0 : NZ = NZ + 1
4985 0 : ND = ND - 1
4986 0 : IF (ND.EQ.0) GO TO 110
4987 0 : CALL ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM)
4988 0 : IF (NUF.LT.0) GO TO 140
4989 0 : ND = ND - NUF
4990 0 : NZ = NZ + NUF
4991 0 : IF (ND.EQ.0) GO TO 110
4992 0 : FN = FNU + DBLE(FLOAT(ND-1))
4993 0 : IF (FN.LT.FNUL) GO TO 130
4994 : !C FN = CIDI
4995 : !C J = NUF + 1
4996 : !C K = MOD(J,4) + 1
4997 : !C S1R = CIPR(K)
4998 : !C S1I = CIPI(K)
4999 : !C IF (FN.LT.0.0D0) S1I = -S1I
5000 : !C STR = C2R*S1R - C2I*S1I
5001 : !C C2I = C2R*S1I + C2I*S1R
5002 : !C C2R = STR
5003 0 : IN = INU + ND - 1
5004 0 : IN = MOD(IN,4) + 1
5005 0 : C2R = CAR*CIPR(IN) - SAR*CIPI(IN)
5006 0 : C2I = CAR*CIPI(IN) + SAR*CIPR(IN)
5007 0 : IF (ZI.LE.0.0D0) C2I = -C2I
5008 0 : GO TO 40
5009 : 130 CONTINUE
5010 0 : NLAST = ND
5011 0 : RETURN
5012 : 140 CONTINUE
5013 0 : NZ = -1
5014 0 : RETURN
5015 : 150 CONTINUE
5016 0 : IF (RS1.GT.0.0D0) GO TO 140
5017 0 : NZ = N
5018 0 : DO 160 I=1,N
5019 0 : YR(I) = ZEROR
5020 0 : YI(I) = ZEROI
5021 0 : 160 CONTINUE
5022 : RETURN
5023 : END SUBROUTINE ZUNI2
5024 :
5025 0 : SUBROUTINE ZAIRY(ZR, ZI, ID, KODE, AIR, AII, NZ, IERR)
5026 : !C***BEGIN PROLOGUE ZAIRY
5027 : !C***DATE WRITTEN 830501 (YYMMDD)
5028 : !C***REVISION DATE 890801 (YYMMDD)
5029 : !C***CATEGORY NO. B5K
5030 : !C***KEYWORDS AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD
5031 : !C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
5032 : !C***PURPOSE TO COMPUTE AIRY FUNCTIONS AI(Z) AND DAI(Z) FOR COMPLEX Z
5033 : !C***DESCRIPTION
5034 : !C
5035 : !C ***A DOUBLE PRECISION ROUTINE***
5036 : !C ON KODE=1, ZAIRY COMPUTES THE COMPLEX AIRY FUNCTION AI(Z) OR
5037 : !C ITS DERIVATIVE DAI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON
5038 : !C KODE=2, A SCALING OPTION CEXP(ZTA)*AI(Z) OR CEXP(ZTA)*
5039 : !C DAI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL DECAY IN
5040 : !C -PI/3.LT.ARG(Z).LT.PI/3 AND THE EXPONENTIAL GROWTH IN
5041 : !C PI/3.LT.ABS(ARG(Z)).LT.PI WHERE ZTA=(2/3)*Z*CSQRT(Z).
5042 : !C
5043 : !C WHILE THE AIRY FUNCTIONS AI(Z) AND DAI(Z)/DZ ARE ANALYTIC IN
5044 : !C THE WHOLE Z PLANE, THE CORRESPONDING SCALED FUNCTIONS DEFINED
5045 : !C FOR KODE=2 HAVE A CUT ALONG THE NEGATIVE REAL AXIS.
5046 : !C DEFINITIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF
5047 : !C MATHEMATICAL FUNCTIONS (REF. 1).
5048 : !C
5049 : !C INPUT ZR,ZI ARE DOUBLE PRECISION
5050 : !C ZR,ZI - Z=CMPLX(ZR,ZI)
5051 : !C ID - ORDER OF DERIVATIVE, ID=0 OR ID=1
5052 : !C KODE - A PARAMETER TO INDICATE THE SCALING OPTION
5053 : !C KODE= 1 RETURNS
5054 : !C AI=AI(Z) ON ID=0 OR
5055 : !C AI=DAI(Z)/DZ ON ID=1
5056 : !C = 2 RETURNS
5057 : !C AI=CEXP(ZTA)*AI(Z) ON ID=0 OR
5058 : !C AI=CEXP(ZTA)*DAI(Z)/DZ ON ID=1 WHERE
5059 : !C ZTA=(2/3)*Z*CSQRT(Z)
5060 : !C
5061 : !C OUTPUT AIR,AII ARE DOUBLE PRECISION
5062 : !C AIR,AII- COMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND
5063 : !C KODE
5064 : !C NZ - UNDERFLOW INDICATOR
5065 : !C NZ= 0 , NORMAL RETURN
5066 : !C NZ= 1 , AI=CMPLX(0.0D0,0.0D0) DUE TO UNDERFLOW IN
5067 : !C -PI/3.LT.ARG(Z).LT.PI/3 ON KODE=1
5068 : !C IERR - ERROR FLAG
5069 : !C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
5070 : !C IERR=1, INPUT ERROR - NO COMPUTATION
5071 : !C IERR=2, OVERFLOW - NO COMPUTATION, REAL(ZTA)
5072 : !C TOO LARGE ON KODE=1
5073 : !C IERR=3, CABS(Z) LARGE - COMPUTATION COMPLETED
5074 : !C LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION
5075 : !C PRODUCE LESS THAN HALF OF MACHINE ACCURACY
5076 : !C IERR=4, CABS(Z) TOO LARGE - NO COMPUTATION
5077 : !C COMPLETE LOSS OF ACCURACY BY ARGUMENT
5078 : !C REDUCTION
5079 : !C IERR=5, ERROR - NO COMPUTATION,
5080 : !C ALGORITHM TERMINATION CONDITION NOT MET
5081 : !C
5082 : !C***LONG DESCRIPTION
5083 : !C
5084 : !C AI AND DAI ARE COMPUTED FOR CABS(Z).GT.1.0 FROM THE K BESSEL
5085 : !C FUNCTIONS BY
5086 : !C
5087 : !C AI(Z)=C*SQRT(Z)*K(1/3,ZTA) , DAI(Z)=-C*Z*K(2/3,ZTA)
5088 : !C C=1.0/(PI*SQRT(3.0))
5089 : !C ZTA=(2/3)*Z**(3/2)
5090 : !C
5091 : !C WITH THE POWER SERIES FOR CABS(Z).LE.1.0.
5092 : !C
5093 : !C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
5094 : !C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES
5095 : !C OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF
5096 : !C THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR),
5097 : !C THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR
5098 : !C FLAG IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
5099 : !C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
5100 : !C ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN
5101 : !C ALL SIGNIFICANCE IS LOST AND IERR=4. IN ORDER TO USE THE INT
5102 : !C FUNCTION, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE
5103 : !C LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA
5104 : !C MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2,
5105 : !C AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE
5106 : !C PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE
5107 : !C PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT-
5108 : !C ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG-
5109 : !C NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN
5110 : !C DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN
5111 : !C EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES,
5112 : !C NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE
5113 : !C PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER
5114 : !C MACHINES.
5115 : !C
5116 : !C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
5117 : !C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
5118 : !C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
5119 : !C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
5120 : !C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
5121 : !C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
5122 : !C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
5123 : !C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
5124 : !C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
5125 : !C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
5126 : !C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
5127 : !C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
5128 : !C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
5129 : !C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
5130 : !C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
5131 : !C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
5132 : !C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
5133 : !C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
5134 : !C OR -PI/2+P.
5135 : !C
5136 : !C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
5137 : !C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
5138 : !C COMMERCE, 1955.
5139 : !C
5140 : !C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
5141 : !C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
5142 : !C
5143 : !C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
5144 : !C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
5145 : !C 1018, MAY, 1985
5146 : !C
5147 : !C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
5148 : !C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
5149 : !C MATH. SOFTWARE, 1986
5150 : !C
5151 : !C***ROUTINES CALLED ZACAI,ZBKNU,AZEXP,AZSQRT,I1MACH,D1MACH
5152 : !C***END PROLOGUE ZAIRY
5153 : !C COMPLEX AI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3
5154 : DOUBLE PRECISION AA, AD, AII, AIR, AK, ALIM, ATRM, AZ, AZ3, BK, &
5155 : & CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2, DIG, &
5156 : & DK, D1, D2, ELIM, FID, FNU, PTR, RL, R1M5, SFAC, STI, STR, &
5157 : & S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I, TRM2R, TTH, ZEROI, &
5158 : & ZEROR, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, BB, ALAZ ! D1MACH, AZABS
5159 : INTEGER ID, IERR, IFLAG, K, KODE, K1, K2, MR, NN, NZ!, I1MACH
5160 : DIMENSION CYR(1), CYI(1)
5161 : DATA TTH, C1, C2, COEF /6.66666666666666667D-01, &
5162 : & 3.55028053887817240D-01,2.58819403792806799D-01, &
5163 : & 1.83776298473930683D-01/
5164 : DATA ZEROR, ZEROI, CONER, CONEI /0.0D0,0.0D0,1.0D0,0.0D0/
5165 : !C***FIRST EXECUTABLE STATEMENT ZAIRY
5166 0 : IERR = 0
5167 0 : NZ=0
5168 0 : IF (ID.LT.0 .OR. ID.GT.1) IERR=1
5169 0 : IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
5170 0 : IF (IERR.NE.0) RETURN
5171 0 : AZ = AZABS(ZR,ZI)
5172 0 : TOL = DMAX1(D1MACH(4),1.0D-18)
5173 0 : FID = DBLE(FLOAT(ID))
5174 0 : IF (AZ.GT.1.0D0) GO TO 70
5175 : !C-----------------------------------------------------------------------
5176 : !C POWER SERIES FOR CABS(Z).LE.1.
5177 : !C-----------------------------------------------------------------------
5178 0 : S1R = CONER
5179 0 : S1I = CONEI
5180 0 : S2R = CONER
5181 0 : S2I = CONEI
5182 0 : IF (AZ.LT.TOL) GO TO 170
5183 0 : AA = AZ*AZ
5184 0 : IF (AA.LT.TOL/AZ) GO TO 40
5185 0 : TRM1R = CONER
5186 0 : TRM1I = CONEI
5187 0 : TRM2R = CONER
5188 0 : TRM2I = CONEI
5189 0 : ATRM = 1.0D0
5190 0 : STR = ZR*ZR - ZI*ZI
5191 0 : STI = ZR*ZI + ZI*ZR
5192 0 : Z3R = STR*ZR - STI*ZI
5193 0 : Z3I = STR*ZI + STI*ZR
5194 0 : AZ3 = AZ*AA
5195 0 : AK = 2.0D0 + FID
5196 0 : BK = 3.0D0 - FID - FID
5197 0 : CK = 4.0D0 - FID
5198 0 : DK = 3.0D0 + FID + FID
5199 0 : D1 = AK*DK
5200 0 : D2 = BK*CK
5201 0 : AD = DMIN1(D1,D2)
5202 0 : AK = 24.0D0 + 9.0D0*FID
5203 0 : BK = 30.0D0 - 9.0D0*FID
5204 0 : DO 30 K=1,25
5205 0 : STR = (TRM1R*Z3R-TRM1I*Z3I)/D1
5206 0 : TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1
5207 0 : TRM1R = STR
5208 0 : S1R = S1R + TRM1R
5209 0 : S1I = S1I + TRM1I
5210 0 : STR = (TRM2R*Z3R-TRM2I*Z3I)/D2
5211 0 : TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2
5212 0 : TRM2R = STR
5213 0 : S2R = S2R + TRM2R
5214 0 : S2I = S2I + TRM2I
5215 0 : ATRM = ATRM*AZ3/AD
5216 0 : D1 = D1 + AK
5217 0 : D2 = D2 + BK
5218 0 : AD = DMIN1(D1,D2)
5219 0 : IF (ATRM.LT.TOL*AD) GO TO 40
5220 0 : AK = AK + 18.0D0
5221 0 : BK = BK + 18.0D0
5222 0 : 30 CONTINUE
5223 : 40 CONTINUE
5224 0 : IF (ID.EQ.1) GO TO 50
5225 0 : AIR = S1R*C1 - C2*(ZR*S2R-ZI*S2I)
5226 0 : AII = S1I*C1 - C2*(ZR*S2I+ZI*S2R)
5227 0 : IF (KODE.EQ.1) RETURN
5228 0 : CALL AZSQRT(ZR, ZI, STR, STI)
5229 0 : ZTAR = TTH*(ZR*STR-ZI*STI)
5230 0 : ZTAI = TTH*(ZR*STI+ZI*STR)
5231 0 : CALL AZEXP(ZTAR, ZTAI, STR, STI)
5232 0 : PTR = AIR*STR - AII*STI
5233 0 : AII = AIR*STI + AII*STR
5234 0 : AIR = PTR
5235 0 : RETURN
5236 : 50 CONTINUE
5237 0 : AIR = -S2R*C2
5238 0 : AII = -S2I*C2
5239 0 : IF (AZ.LE.TOL) GO TO 60
5240 0 : STR = ZR*S1R - ZI*S1I
5241 0 : STI = ZR*S1I + ZI*S1R
5242 0 : CC = C1/(1.0D0+FID)
5243 0 : AIR = AIR + CC*(STR*ZR-STI*ZI)
5244 0 : AII = AII + CC*(STR*ZI+STI*ZR)
5245 : 60 CONTINUE
5246 0 : IF (KODE.EQ.1) RETURN
5247 0 : CALL AZSQRT(ZR, ZI, STR, STI)
5248 0 : ZTAR = TTH*(ZR*STR-ZI*STI)
5249 0 : ZTAI = TTH*(ZR*STI+ZI*STR)
5250 0 : CALL AZEXP(ZTAR, ZTAI, STR, STI)
5251 0 : PTR = STR*AIR - STI*AII
5252 0 : AII = STR*AII + STI*AIR
5253 0 : AIR = PTR
5254 0 : RETURN
5255 : !C-----------------------------------------------------------------------
5256 : !C CASE FOR CABS(Z).GT.1.0
5257 : !C-----------------------------------------------------------------------
5258 : 70 CONTINUE
5259 0 : FNU = (1.0D0+FID)/3.0D0
5260 : !C-----------------------------------------------------------------------
5261 : !C SET PARAMETERS RELATED TO MACHINE CONSTANTS.
5262 : !C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0D-18.
5263 : !C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
5264 : !C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND
5265 : !C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR
5266 : !C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
5267 : !C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
5268 : !C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
5269 : !C-----------------------------------------------------------------------
5270 0 : K1 = I1MACH(15)
5271 0 : K2 = I1MACH(16)
5272 0 : R1M5 = D1MACH(5)
5273 0 : K = MIN0(IABS(K1),IABS(K2))
5274 0 : ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
5275 0 : K1 = I1MACH(14) - 1
5276 0 : AA = R1M5*DBLE(FLOAT(K1))
5277 0 : DIG = DMIN1(AA,18.0D0)
5278 0 : AA = AA*2.303D0
5279 0 : ALIM = ELIM + DMAX1(-AA,-41.45D0)
5280 0 : RL = 1.2D0*DIG + 3.0D0
5281 0 : ALAZ = DLOG(AZ)
5282 : !C--------------------------------------------------------------------------
5283 : !C TEST FOR PROPER RANGE
5284 : !C-----------------------------------------------------------------------
5285 0 : AA=0.5D0/TOL
5286 0 : BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
5287 0 : AA=DMIN1(AA,BB)
5288 0 : AA=AA**TTH
5289 0 : IF (AZ.GT.AA) GO TO 260
5290 0 : AA=DSQRT(AA)
5291 0 : IF (AZ.GT.AA) IERR=3
5292 0 : CALL AZSQRT(ZR, ZI, CSQR, CSQI)
5293 0 : ZTAR = TTH*(ZR*CSQR-ZI*CSQI)
5294 0 : ZTAI = TTH*(ZR*CSQI+ZI*CSQR)
5295 : !C-----------------------------------------------------------------------
5296 : !C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL
5297 : !C-----------------------------------------------------------------------
5298 0 : IFLAG = 0
5299 0 : SFAC = 1.0D0
5300 0 : AK = ZTAI
5301 0 : IF (ZR.GE.0.0D0) GO TO 80
5302 0 : BK = ZTAR
5303 0 : CK = -DABS(BK)
5304 0 : ZTAR = CK
5305 0 : ZTAI = AK
5306 : 80 CONTINUE
5307 0 : IF (ZI.NE.0.0D0) GO TO 90
5308 0 : IF (ZR.GT.0.0D0) GO TO 90
5309 0 : ZTAR = 0.0D0
5310 0 : ZTAI = AK
5311 : 90 CONTINUE
5312 0 : AA = ZTAR
5313 0 : IF (AA.GE.0.0D0 .AND. ZR.GT.0.0D0) GO TO 110
5314 0 : IF (KODE.EQ.2) GO TO 100
5315 : !C-----------------------------------------------------------------------
5316 : !C OVERFLOW TEST
5317 : !C-----------------------------------------------------------------------
5318 0 : IF (AA.GT.(-ALIM)) GO TO 100
5319 0 : AA = -AA + 0.25D0*ALAZ
5320 0 : IFLAG = 1
5321 0 : SFAC = TOL
5322 0 : IF (AA.GT.ELIM) GO TO 270
5323 : 100 CONTINUE
5324 : !C-----------------------------------------------------------------------
5325 : !C CBKNU AND CACON RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2
5326 : !C-----------------------------------------------------------------------
5327 0 : MR = 1
5328 0 : IF (ZI.LT.0.0D0) MR = -1
5329 : CALL ZACAI(ZTAR, ZTAI, FNU, KODE, MR, 1, CYR, CYI, NN, RL, TOL, &
5330 0 : & ELIM, ALIM)
5331 0 : IF (NN.LT.0) GO TO 280
5332 0 : NZ = NZ + NN
5333 0 : GO TO 130
5334 : 110 CONTINUE
5335 0 : IF (KODE.EQ.2) GO TO 120
5336 : !C-----------------------------------------------------------------------
5337 : !C UNDERFLOW TEST
5338 : !C-----------------------------------------------------------------------
5339 0 : IF (AA.LT.ALIM) GO TO 120
5340 0 : AA = -AA - 0.25D0*ALAZ
5341 0 : IFLAG = 2
5342 0 : SFAC = 1.0D0/TOL
5343 0 : IF (AA.LT.(-ELIM)) GO TO 210
5344 : 120 CONTINUE
5345 : CALL ZBKNU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, TOL, ELIM, &
5346 0 : & ALIM)
5347 : 130 CONTINUE
5348 0 : S1R = CYR(1)*COEF
5349 0 : S1I = CYI(1)*COEF
5350 0 : IF (IFLAG.NE.0) GO TO 150
5351 0 : IF (ID.EQ.1) GO TO 140
5352 0 : AIR = CSQR*S1R - CSQI*S1I
5353 0 : AII = CSQR*S1I + CSQI*S1R
5354 0 : RETURN
5355 : 140 CONTINUE
5356 0 : AIR = -(ZR*S1R-ZI*S1I)
5357 0 : AII = -(ZR*S1I+ZI*S1R)
5358 0 : RETURN
5359 : 150 CONTINUE
5360 0 : S1R = S1R*SFAC
5361 0 : S1I = S1I*SFAC
5362 0 : IF (ID.EQ.1) GO TO 160
5363 0 : STR = S1R*CSQR - S1I*CSQI
5364 0 : S1I = S1R*CSQI + S1I*CSQR
5365 0 : S1R = STR
5366 0 : AIR = S1R/SFAC
5367 0 : AII = S1I/SFAC
5368 0 : RETURN
5369 : 160 CONTINUE
5370 0 : STR = -(S1R*ZR-S1I*ZI)
5371 0 : S1I = -(S1R*ZI+S1I*ZR)
5372 0 : S1R = STR
5373 0 : AIR = S1R/SFAC
5374 0 : AII = S1I/SFAC
5375 0 : RETURN
5376 : 170 CONTINUE
5377 0 : AA = 1.0D+3*D1MACH(1)
5378 0 : S1R = ZEROR
5379 0 : S1I = ZEROI
5380 0 : IF (ID.EQ.1) GO TO 190
5381 0 : IF (AZ.LE.AA) GO TO 180
5382 0 : S1R = C2*ZR
5383 0 : S1I = C2*ZI
5384 : 180 CONTINUE
5385 0 : AIR = C1 - S1R
5386 0 : AII = -S1I
5387 0 : RETURN
5388 : 190 CONTINUE
5389 0 : AIR = -C2
5390 : AII = 0.0D0
5391 0 : AA = DSQRT(AA)
5392 0 : IF (AZ.LE.AA) GO TO 200
5393 0 : S1R = 0.5D0*(ZR*ZR-ZI*ZI)
5394 0 : S1I = ZR*ZI
5395 : 200 CONTINUE
5396 0 : AIR = AIR + C1*S1R
5397 0 : AII = AII + C1*S1I
5398 0 : RETURN
5399 : 210 CONTINUE
5400 0 : NZ = 1
5401 0 : AIR = ZEROR
5402 0 : AII = ZEROI
5403 0 : RETURN
5404 : 270 CONTINUE
5405 0 : NZ = 0
5406 0 : IERR=2
5407 0 : RETURN
5408 : 280 CONTINUE
5409 0 : IF(NN.EQ.(-1)) GO TO 270
5410 0 : NZ=0
5411 0 : IERR=5
5412 0 : RETURN
5413 : 260 CONTINUE
5414 0 : IERR=4
5415 0 : NZ=0
5416 0 : RETURN
5417 : END SUBROUTINE ZAIRY
5418 :
5419 :
5420 0 : SUBROUTINE ZACAI(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, TOL, &
5421 : & ELIM, ALIM)
5422 : !C***BEGIN PROLOGUE ZACAI
5423 : !C***REFER TO ZAIRY
5424 : !C
5425 : !C ZACAI APPLIES THE ANALYTIC CONTINUATION FORMULA
5426 : !C
5427 : !C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN)
5428 : !C MP=PI*MR*CMPLX(0.0,1.0)
5429 : !C
5430 : !C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT
5431 : !C HALF Z PLANE FOR USE WITH ZAIRY WHERE FNU=1/3 OR 2/3 AND N=1.
5432 : !C ZACAI IS THE SAME AS ZACON WITH THE PARTS FOR LARGER ORDERS AND
5433 : !C RECURRENCE REMOVED. A RECURSIVE CALL TO ZACON CAN RESULT IF ZACON
5434 : !C IS CALLED FROM ZAIRY.
5435 : !C
5436 : !C***ROUTINES CALLED ZASYI,ZBKNU,ZMLRI,ZSERI,ZS1S2,D1MACH,AZABS
5437 : !C***END PROLOGUE ZACAI
5438 : !C COMPLEX CSGN,CSPN,C1,C2,Y,Z,ZN,CY
5439 : DOUBLE PRECISION ALIM, ARG, ASCLE, AZ, CSGNR, CSGNI, CSPNR, &
5440 : & CSPNI, C1R, C1I, C2R, C2I, CYR, CYI, DFNU, ELIM, FMR, FNU, PI, &
5441 : & RL, SGN, TOL, YY, YR, YI, ZR, ZI, ZNR, ZNI!, D1MACH, AZABS
5442 : INTEGER INU, IUF, KODE, MR, N, NN, NW, NZ
5443 : DIMENSION YR(N), YI(N), CYR(2), CYI(2)
5444 : DATA PI / 3.14159265358979324D0 /
5445 0 : NZ = 0
5446 0 : ZNR = -ZR
5447 0 : ZNI = -ZI
5448 0 : AZ = AZABS(ZR,ZI)
5449 0 : NN = N
5450 0 : DFNU = FNU + DBLE(FLOAT(N-1))
5451 0 : IF (AZ.LE.2.0D0) GO TO 10
5452 0 : IF (AZ*AZ*0.25D0.GT.DFNU+1.0D0) GO TO 20
5453 : 10 CONTINUE
5454 : !C-----------------------------------------------------------------------
5455 : !C POWER SERIES FOR THE I FUNCTION
5456 : !C-----------------------------------------------------------------------
5457 0 : CALL ZSERI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL, ELIM, ALIM)
5458 0 : GO TO 40
5459 : 20 CONTINUE
5460 0 : IF (AZ.LT.RL) GO TO 30
5461 : !C-----------------------------------------------------------------------
5462 : !C ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I FUNCTION
5463 : !C-----------------------------------------------------------------------
5464 : CALL ZASYI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, TOL, ELIM, &
5465 0 : & ALIM)
5466 0 : IF (NW.LT.0) GO TO 80
5467 0 : GO TO 40
5468 : 30 CONTINUE
5469 : !C-----------------------------------------------------------------------
5470 : !C MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION
5471 : !C-----------------------------------------------------------------------
5472 0 : CALL ZMLRI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL)
5473 0 : IF(NW.LT.0) GO TO 80
5474 : 40 CONTINUE
5475 : !C-----------------------------------------------------------------------
5476 : !C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION
5477 : !C-----------------------------------------------------------------------
5478 0 : CALL ZBKNU(ZNR, ZNI, FNU, KODE, 1, CYR, CYI, NW, TOL, ELIM, ALIM)
5479 0 : IF (NW.NE.0) GO TO 80
5480 0 : FMR = DBLE(FLOAT(MR))
5481 0 : SGN = -DSIGN(PI,FMR)
5482 0 : CSGNR = 0.0D0
5483 0 : CSGNI = SGN
5484 0 : IF (KODE.EQ.1) GO TO 50
5485 0 : YY = -ZNI
5486 0 : CSGNR = -CSGNI*DSIN(YY)
5487 0 : CSGNI = CSGNI*DCOS(YY)
5488 : 50 CONTINUE
5489 : !C-----------------------------------------------------------------------
5490 : !C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
5491 : !C WHEN FNU IS LARGE
5492 : !C-----------------------------------------------------------------------
5493 0 : INU = INT(SNGL(FNU))
5494 0 : ARG = (FNU-DBLE(FLOAT(INU)))*SGN
5495 0 : CSPNR = DCOS(ARG)
5496 0 : CSPNI = DSIN(ARG)
5497 0 : IF (MOD(INU,2).EQ.0) GO TO 60
5498 0 : CSPNR = -CSPNR
5499 0 : CSPNI = -CSPNI
5500 : 60 CONTINUE
5501 0 : C1R = CYR(1)
5502 0 : C1I = CYI(1)
5503 0 : C2R = YR(1)
5504 0 : C2I = YI(1)
5505 0 : IF (KODE.EQ.1) GO TO 70
5506 0 : IUF = 0
5507 0 : ASCLE = 1.0D+3*D1MACH(1)/TOL
5508 0 : CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF)
5509 0 : NZ = NZ + NW
5510 : 70 CONTINUE
5511 0 : YR(1) = CSPNR*C1R - CSPNI*C1I + CSGNR*C2R - CSGNI*C2I
5512 0 : YI(1) = CSPNR*C1I + CSPNI*C1R + CSGNR*C2I + CSGNI*C2R
5513 0 : RETURN
5514 : 80 CONTINUE
5515 0 : NZ = -1
5516 0 : IF(NW.EQ.(-2)) NZ=-2
5517 : RETURN
5518 : END SUBROUTINE ZACAI
5519 :
5520 0 : SUBROUTINE ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NZ, ASCLE, ALIM, &
5521 : & IUF)
5522 : !C***BEGIN PROLOGUE ZS1S2
5523 : !C***REFER TO ZBESK,ZAIRY
5524 : !C
5525 : !C ZS1S2 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE
5526 : !C ADDITION OF THE I AND K FUNCTIONS IN THE ANALYTIC CON-
5527 : !C TINUATION FORMULA WHERE S1=K FUNCTION AND S2=I FUNCTION.
5528 : !C ON KODE=1 THE I AND K FUNCTIONS ARE DIFFERENT ORDERS OF
5529 : !C MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER
5530 : !C OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE
5531 : !C PRECISION ABOVE THE UNDERFLOW LIMIT.
5532 : !C
5533 : !C***ROUTINES CALLED AZABS,AZEXP,AZLOG
5534 : !C***END PROLOGUE ZS1S2
5535 : !C COMPLEX CZERO,C1,S1,S1D,S2,ZR
5536 : DOUBLE PRECISION AA, ALIM, ALN, ASCLE, AS1, AS2, C1I, C1R, S1DI, &
5537 : & S1DR, S1I, S1R, S2I, S2R, ZEROI, ZEROR, ZRI, ZRR!, AZABS
5538 : INTEGER IUF, IDUM, NZ
5539 : DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 /
5540 0 : NZ = 0
5541 0 : AS1 = AZABS(S1R,S1I)
5542 0 : AS2 = AZABS(S2R,S2I)
5543 0 : IF (S1R.EQ.0.0D0 .AND. S1I.EQ.0.0D0) GO TO 10
5544 0 : IF (AS1.EQ.0.0D0) GO TO 10
5545 0 : ALN = -ZRR - ZRR + DLOG(AS1)
5546 0 : S1DR = S1R
5547 0 : S1DI = S1I
5548 0 : S1R = ZEROR
5549 0 : S1I = ZEROI
5550 0 : AS1 = ZEROR
5551 0 : IF (ALN.LT.(-ALIM)) GO TO 10
5552 0 : CALL AZLOG(S1DR, S1DI, C1R, C1I, IDUM)
5553 0 : C1R = C1R - ZRR - ZRR
5554 0 : C1I = C1I - ZRI - ZRI
5555 0 : CALL AZEXP(C1R, C1I, S1R, S1I)
5556 0 : AS1 = AZABS(S1R,S1I)
5557 0 : IUF = IUF + 1
5558 : 10 CONTINUE
5559 0 : AA = DMAX1(AS1,AS2)
5560 0 : IF (AA.GT.ASCLE) RETURN
5561 0 : S1R = ZEROR
5562 0 : S1I = ZEROI
5563 0 : S2R = ZEROR
5564 0 : S2I = ZEROI
5565 0 : NZ = 1
5566 0 : IUF = 0
5567 0 : RETURN
5568 : END SUBROUTINE ZS1S2
5569 :
5570 0 : SUBROUTINE ZSHCH(ZR, ZI, CSHR, CSHI, CCHR, CCHI)
5571 : !C***BEGIN PROLOGUE ZSHCH
5572 : !C***REFER TO ZBESK,ZBESH
5573 : !C
5574 : !C ZSHCH COMPUTES THE COMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y)
5575 : !C AND CCH=COSH(X+I*Y), WHERE I**2=-1.
5576 : !C
5577 : !C***ROUTINES CALLED (NONE)
5578 : !C***END PROLOGUE ZSHCH
5579 : !C
5580 : DOUBLE PRECISION CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, ZI, ZR, &
5581 : & DCOSH, DSINH
5582 0 : SH = DSINH(ZR)
5583 0 : CH = DCOSH(ZR)
5584 0 : SN = DSIN(ZI)
5585 0 : CN = DCOS(ZI)
5586 0 : CSHR = SH*CN
5587 0 : CSHI = CH*SN
5588 0 : CCHR = CH*CN
5589 0 : CCHI = SH*SN
5590 0 : RETURN
5591 : END SUBROUTINE ZSHCH
5592 :
5593 0 : SUBROUTINE ZKSCL(ZRR,ZRI,FNU,N,YR,YI,NZ,RZR,RZI,ASCLE,TOL,ELIM)
5594 : !C***BEGIN PROLOGUE ZKSCL
5595 : !C***REFER TO ZBESK
5596 : !C
5597 : !C SET K FUNCTIONS TO ZERO ON UNDERFLOW, CONTINUE RECURRENCE
5598 : !C ON SCALED FUNCTIONS UNTIL TWO MEMBERS COME ON SCALE, THEN
5599 : !C RETURN WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL.
5600 : !C
5601 : !C***ROUTINES CALLED ZUCHK,AZABS,AZLOG
5602 : !C***END PROLOGUE ZKSCL
5603 : !C COMPLEX CK,CS,CY,CZERO,RZ,S1,S2,Y,ZR,ZD,CELM
5604 : DOUBLE PRECISION ACS, AS, ASCLE, CKI, CKR, CSI, CSR, CYI, &
5605 : & CYR, ELIM, FN, FNU, RZI, RZR, STR, S1I, S1R, S2I, &
5606 : & S2R, TOL, YI, YR, ZEROI, ZEROR, ZRI, ZRR, & !AZABS, &
5607 : & ZDR, ZDI, CELMR, ELM, HELIM, ALAS
5608 : INTEGER I, IC, IDUM, KK, N, NN, NW, NZ
5609 : DIMENSION YR(N), YI(N), CYR(2), CYI(2)
5610 : DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 /
5611 : !C
5612 0 : NZ = 0
5613 0 : IC = 0
5614 0 : NN = MIN0(2,N)
5615 0 : DO 10 I=1,NN
5616 0 : S1R = YR(I)
5617 0 : S1I = YI(I)
5618 0 : CYR(I) = S1R
5619 0 : CYI(I) = S1I
5620 0 : AS = AZABS(S1R,S1I)
5621 0 : ACS = -ZRR + DLOG(AS)
5622 0 : NZ = NZ + 1
5623 0 : YR(I) = ZEROR
5624 0 : YI(I) = ZEROI
5625 0 : IF (ACS.LT.(-ELIM)) GO TO 10
5626 0 : CALL AZLOG(S1R, S1I, CSR, CSI, IDUM)
5627 0 : CSR = CSR - ZRR
5628 0 : CSI = CSI - ZRI
5629 0 : STR = DEXP(CSR)/TOL
5630 0 : CSR = STR*DCOS(CSI)
5631 0 : CSI = STR*DSIN(CSI)
5632 0 : CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL)
5633 : IF (NW.NE.0) GO TO 10
5634 0 : YR(I) = CSR
5635 0 : YI(I) = CSI
5636 0 : IC = I
5637 0 : NZ = NZ - 1
5638 0 : 10 CONTINUE
5639 0 : IF (N.EQ.1) RETURN
5640 0 : IF (IC.GT.1) GO TO 20
5641 0 : YR(1) = ZEROR
5642 0 : YI(1) = ZEROI
5643 0 : NZ = 2
5644 : 20 CONTINUE
5645 0 : IF (N.EQ.2) RETURN
5646 0 : IF (NZ.EQ.0) RETURN
5647 0 : FN = FNU + 1.0D0
5648 0 : CKR = FN*RZR
5649 0 : CKI = FN*RZI
5650 0 : S1R = CYR(1)
5651 0 : S1I = CYI(1)
5652 0 : S2R = CYR(2)
5653 0 : S2I = CYI(2)
5654 0 : HELIM = 0.5D0*ELIM
5655 0 : ELM = DEXP(-ELIM)
5656 0 : CELMR = ELM
5657 0 : ZDR = ZRR
5658 0 : ZDI = ZRI
5659 : !C
5660 : !C FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE RECURRENCE IF
5661 : !C S2 GETS LARGER THAN EXP(ELIM/2)
5662 : !C
5663 0 : DO 30 I=3,N
5664 0 : KK = I
5665 0 : CSR = S2R
5666 0 : CSI = S2I
5667 0 : S2R = CKR*CSR - CKI*CSI + S1R
5668 0 : S2I = CKI*CSR + CKR*CSI + S1I
5669 0 : S1R = CSR
5670 0 : S1I = CSI
5671 0 : CKR = CKR + RZR
5672 0 : CKI = CKI + RZI
5673 0 : AS = AZABS(S2R,S2I)
5674 0 : ALAS = DLOG(AS)
5675 0 : ACS = -ZDR + ALAS
5676 0 : NZ = NZ + 1
5677 0 : YR(I) = ZEROR
5678 0 : YI(I) = ZEROI
5679 0 : IF (ACS.LT.(-ELIM)) GO TO 25
5680 0 : CALL AZLOG(S2R, S2I, CSR, CSI, IDUM)
5681 0 : CSR = CSR - ZDR
5682 0 : CSI = CSI - ZDI
5683 0 : STR = DEXP(CSR)/TOL
5684 0 : CSR = STR*DCOS(CSI)
5685 0 : CSI = STR*DSIN(CSI)
5686 0 : CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL)
5687 : IF (NW.NE.0) GO TO 25
5688 0 : YR(I) = CSR
5689 0 : YI(I) = CSI
5690 0 : NZ = NZ - 1
5691 0 : IF (IC.EQ.KK-1) GO TO 40
5692 : IC = KK
5693 0 : GO TO 30
5694 : 25 CONTINUE
5695 0 : IF(ALAS.LT.HELIM) GO TO 30
5696 0 : ZDR = ZDR - ELIM
5697 0 : S1R = S1R*CELMR
5698 0 : S1I = S1I*CELMR
5699 0 : S2R = S2R*CELMR
5700 0 : S2I = S2I*CELMR
5701 0 : 30 CONTINUE
5702 0 : NZ = N
5703 0 : IF(IC.EQ.N) NZ=N-1
5704 0 : GO TO 45
5705 : 40 CONTINUE
5706 0 : NZ = KK - 2
5707 : 45 CONTINUE
5708 0 : DO 50 I=1,NZ
5709 0 : YR(I) = ZEROR
5710 0 : YI(I) = ZEROI
5711 0 : 50 CONTINUE
5712 : RETURN
5713 : END SUBROUTINE ZKSCL
5714 :
5715 0 : SUBROUTINE ZBUNK(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, &
5716 : & ALIM)
5717 : !C***BEGIN PROLOGUE ZBUNK
5718 : !C***REFER TO ZBESK,ZBESH
5719 : !C
5720 : !C ZBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU.GT.FNUL.
5721 : !C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z)
5722 : !C IN ZUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN ZUNK2
5723 : !C
5724 : !C***ROUTINES CALLED ZUNK1,ZUNK2
5725 : !C***END PROLOGUE ZBUNK
5726 : !C COMPLEX Y,Z
5727 : DOUBLE PRECISION ALIM, AX, AY, ELIM, FNU, TOL, YI, YR, ZI, ZR
5728 : INTEGER KODE, MR, N, NZ
5729 : DIMENSION YR(N), YI(N)
5730 0 : NZ = 0
5731 0 : AX = DABS(ZR)*1.7321D0
5732 0 : AY = DABS(ZI)
5733 0 : IF (AY.GT.AX) GO TO 10
5734 : !C-----------------------------------------------------------------------
5735 : !C ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN
5736 : !C -PI/3.LE.ARG(Z).LE.PI/3
5737 : !C-----------------------------------------------------------------------
5738 0 : CALL ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM)
5739 0 : GO TO 20
5740 : 10 CONTINUE
5741 : !C-----------------------------------------------------------------------
5742 : !C ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU
5743 : !C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I
5744 : !C AND HPI=PI/2
5745 : !C-----------------------------------------------------------------------
5746 0 : CALL ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM)
5747 : 20 CONTINUE
5748 0 : RETURN
5749 : END SUBROUTINE ZBUNK
5750 :
5751 :
5752 0 : SUBROUTINE ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, &
5753 : & ALIM)
5754 : !C***BEGIN PROLOGUE ZUNK1
5755 : !C***REFER TO ZBESK
5756 : !C
5757 : !C ZUNK1 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE
5758 : !C RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE
5759 : !C UNIFORM ASYMPTOTIC EXPANSION.
5760 : !C MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION.
5761 : !C NZ=-1 MEANS AN OVERFLOW WILL OCCUR
5762 : !C
5763 : !C***ROUTINES CALLED ZKSCL,ZS1S2,ZUCHK,ZUNIK,D1MACH,AZABS
5764 : !C***END PROLOGUE ZUNK1
5765 : !C COMPLEX CFN,CK,CONE,CRSC,CS,CSCL,CSGN,CSPN,CSR,CSS,CWRK,CY,CZERO,
5766 : !C *C1,C2,PHI,PHID,RZ,SUM,SUMD,S1,S2,Y,Z,ZETA1,ZETA1D,ZETA2,ZETA2D,ZR
5767 : DOUBLE PRECISION ALIM, ANG, APHI, ASC, ASCLE, BRY, CKI, CKR, &
5768 : & CONER, CRSC, CSCL, CSGNI, CSPNI, CSPNR, CSR, CSRR, CSSR, &
5769 : & CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2M, C2R, ELIM, FMR, FN, &
5770 : & FNF, FNU, PHIDI, PHIDR, PHII, PHIR, PI, RAST, RAZR, RS1, RZI, &
5771 : & RZR, SGN, STI, STR, SUMDI, SUMDR, SUMI, SUMR, S1I, S1R, S2I, &
5772 : & S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, &
5773 : & ZET1DI, ZET1DR, ZET2DI, ZET2DR, ZI, ZR, ZRI, ZRR!, D1MACH, AZABS
5774 : INTEGER I, IB, IFLAG, IFN, IL, INIT, INU, IUF, K, KDFLG, KFLAG, &
5775 : & KK, KODE, MR, N, NW, NZ, INITD, IC, IPARD, J, M
5776 : DIMENSION BRY(3), INIT(2), YR(N), YI(N), SUMR(2), SUMI(2), &
5777 : & ZETA1R(2), ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2), &
5778 : & CWRKR(16,3), CWRKI(16,3), CSSR(3), CSRR(3), PHIR(2), PHII(2)
5779 : DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 /
5780 : DATA PI / 3.14159265358979324D0 /
5781 : !C
5782 0 : KDFLG = 1
5783 0 : NZ = 0
5784 : !C-----------------------------------------------------------------------
5785 : !C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN
5786 : !C THE UNDERFLOW LIMIT
5787 : !C-----------------------------------------------------------------------
5788 0 : CSCL = 1.0D0/TOL
5789 0 : CRSC = TOL
5790 0 : CSSR(1) = CSCL
5791 0 : CSSR(2) = CONER
5792 0 : CSSR(3) = CRSC
5793 0 : CSRR(1) = CRSC
5794 0 : CSRR(2) = CONER
5795 0 : CSRR(3) = CSCL
5796 0 : BRY(1) = 1.0D+3*D1MACH(1)/TOL
5797 0 : BRY(2) = 1.0D0/BRY(1)
5798 0 : BRY(3) = D1MACH(2)
5799 0 : ZRR = ZR
5800 0 : ZRI = ZI
5801 0 : IF (ZR.GE.0.0D0) GO TO 10
5802 0 : ZRR = -ZR
5803 0 : ZRI = -ZI
5804 : 10 CONTINUE
5805 0 : J = 2
5806 0 : DO 70 I=1,N
5807 : !C-----------------------------------------------------------------------
5808 : !C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J
5809 : !C-----------------------------------------------------------------------
5810 0 : J = 3 - J
5811 0 : FN = FNU + DBLE(FLOAT(I-1))
5812 0 : INIT(J) = 0
5813 : CALL ZUNIK(ZRR, ZRI, FN, 2, 0, TOL, INIT(J), PHIR(J), PHII(J), &
5814 : & ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), SUMR(J), SUMI(J), &
5815 0 : & CWRKR(1,J), CWRKI(1,J))
5816 0 : IF (KODE.EQ.1) GO TO 20
5817 0 : STR = ZRR + ZETA2R(J)
5818 0 : STI = ZRI + ZETA2I(J)
5819 0 : RAST = FN/AZABS(STR,STI)
5820 0 : STR = STR*RAST*RAST
5821 0 : STI = -STI*RAST*RAST
5822 0 : S1R = ZETA1R(J) - STR
5823 0 : S1I = ZETA1I(J) - STI
5824 0 : GO TO 30
5825 : 20 CONTINUE
5826 0 : S1R = ZETA1R(J) - ZETA2R(J)
5827 0 : S1I = ZETA1I(J) - ZETA2I(J)
5828 : 30 CONTINUE
5829 0 : RS1 = S1R
5830 : !C-----------------------------------------------------------------------
5831 : !C TEST FOR UNDERFLOW AND OVERFLOW
5832 : !C-----------------------------------------------------------------------
5833 0 : IF (DABS(RS1).GT.ELIM) GO TO 60
5834 0 : IF (KDFLG.EQ.1) KFLAG = 2
5835 0 : IF (DABS(RS1).LT.ALIM) GO TO 40
5836 : !C-----------------------------------------------------------------------
5837 : !C REFINE TEST AND SCALE
5838 : !C-----------------------------------------------------------------------
5839 0 : APHI = AZABS(PHIR(J),PHII(J))
5840 0 : RS1 = RS1 + DLOG(APHI)
5841 0 : IF (DABS(RS1).GT.ELIM) GO TO 60
5842 0 : IF (KDFLG.EQ.1) KFLAG = 1
5843 0 : IF (RS1.LT.0.0D0) GO TO 40
5844 0 : IF (KDFLG.EQ.1) KFLAG = 3
5845 : 40 CONTINUE
5846 : !C-----------------------------------------------------------------------
5847 : !C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR
5848 : !C EXPONENT EXTREMES
5849 : !C-----------------------------------------------------------------------
5850 0 : S2R = PHIR(J)*SUMR(J) - PHII(J)*SUMI(J)
5851 0 : S2I = PHIR(J)*SUMI(J) + PHII(J)*SUMR(J)
5852 0 : STR = DEXP(S1R)*CSSR(KFLAG)
5853 0 : S1R = STR*DCOS(S1I)
5854 0 : S1I = STR*DSIN(S1I)
5855 0 : STR = S2R*S1R - S2I*S1I
5856 0 : S2I = S1R*S2I + S2R*S1I
5857 0 : S2R = STR
5858 0 : IF (KFLAG.NE.1) GO TO 50
5859 0 : CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL)
5860 0 : IF (NW.NE.0) GO TO 60
5861 : 50 CONTINUE
5862 0 : CYR(KDFLG) = S2R
5863 0 : CYI(KDFLG) = S2I
5864 0 : YR(I) = S2R*CSRR(KFLAG)
5865 0 : YI(I) = S2I*CSRR(KFLAG)
5866 0 : IF (KDFLG.EQ.2) GO TO 75
5867 : KDFLG = 2
5868 0 : GO TO 70
5869 : 60 CONTINUE
5870 0 : IF (RS1.GT.0.0D0) GO TO 300
5871 : !C-----------------------------------------------------------------------
5872 : !C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW
5873 : !C-----------------------------------------------------------------------
5874 0 : IF (ZR.LT.0.0D0) GO TO 300
5875 0 : KDFLG = 1
5876 0 : YR(I)=ZEROR
5877 0 : YI(I)=ZEROI
5878 0 : NZ=NZ+1
5879 0 : IF (I.EQ.1) GO TO 70
5880 0 : IF ((YR(I-1).EQ.ZEROR).AND.(YI(I-1).EQ.ZEROI)) GO TO 70
5881 0 : YR(I-1)=ZEROR
5882 0 : YI(I-1)=ZEROI
5883 0 : NZ=NZ+1
5884 0 : 70 CONTINUE
5885 0 : I = N
5886 : 75 CONTINUE
5887 0 : RAZR = 1.0D0/AZABS(ZRR,ZRI)
5888 0 : STR = ZRR*RAZR
5889 0 : STI = -ZRI*RAZR
5890 0 : RZR = (STR+STR)*RAZR
5891 0 : RZI = (STI+STI)*RAZR
5892 0 : CKR = FN*RZR
5893 0 : CKI = FN*RZI
5894 0 : IB = I + 1
5895 0 : IF (N.LT.IB) GO TO 160
5896 : !C-----------------------------------------------------------------------
5897 : !C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO
5898 : !C ON UNDERFLOW.
5899 : !C-----------------------------------------------------------------------
5900 0 : FN = FNU + DBLE(FLOAT(N-1))
5901 0 : IPARD = 1
5902 0 : IF (MR.NE.0) IPARD = 0
5903 0 : INITD = 0
5904 : CALL ZUNIK(ZRR, ZRI, FN, 2, IPARD, TOL, INITD, PHIDR, PHIDI, &
5905 : & ZET1DR, ZET1DI, ZET2DR, ZET2DI, SUMDR, SUMDI, CWRKR(1,3), &
5906 0 : & CWRKI(1,3))
5907 0 : IF (KODE.EQ.1) GO TO 80
5908 0 : STR = ZRR + ZET2DR
5909 0 : STI = ZRI + ZET2DI
5910 0 : RAST = FN/AZABS(STR,STI)
5911 0 : STR = STR*RAST*RAST
5912 0 : STI = -STI*RAST*RAST
5913 0 : S1R = ZET1DR - STR
5914 0 : S1I = ZET1DI - STI
5915 0 : GO TO 90
5916 : 80 CONTINUE
5917 0 : S1R = ZET1DR - ZET2DR
5918 0 : S1I = ZET1DI - ZET2DI
5919 : 90 CONTINUE
5920 0 : RS1 = S1R
5921 0 : IF (DABS(RS1).GT.ELIM) GO TO 95
5922 0 : IF (DABS(RS1).LT.ALIM) GO TO 100
5923 : !C----------------------------------------------------------------------------
5924 : !C REFINE ESTIMATE AND TEST
5925 : !C-------------------------------------------------------------------------
5926 0 : APHI = AZABS(PHIDR,PHIDI)
5927 0 : RS1 = RS1+DLOG(APHI)
5928 0 : IF (DABS(RS1).LT.ELIM) GO TO 100
5929 : 95 CONTINUE
5930 0 : IF (DABS(RS1).GT.0.0D0) GO TO 300
5931 : !C-----------------------------------------------------------------------
5932 : !C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW
5933 : !C-----------------------------------------------------------------------
5934 0 : IF (ZR.LT.0.0D0) GO TO 300
5935 0 : NZ = N
5936 0 : DO 96 I=1,N
5937 0 : YR(I) = ZEROR
5938 0 : YI(I) = ZEROI
5939 0 : 96 CONTINUE
5940 0 : RETURN
5941 : !C---------------------------------------------------------------------------
5942 : !C FORWARD RECUR FOR REMAINDER OF THE SEQUENCE
5943 : !C----------------------------------------------------------------------------
5944 : 100 CONTINUE
5945 0 : S1R = CYR(1)
5946 0 : S1I = CYI(1)
5947 0 : S2R = CYR(2)
5948 0 : S2I = CYI(2)
5949 0 : C1R = CSRR(KFLAG)
5950 0 : ASCLE = BRY(KFLAG)
5951 0 : DO 120 I=IB,N
5952 0 : C2R = S2R
5953 0 : C2I = S2I
5954 0 : S2R = CKR*C2R - CKI*C2I + S1R
5955 0 : S2I = CKR*C2I + CKI*C2R + S1I
5956 0 : S1R = C2R
5957 0 : S1I = C2I
5958 0 : CKR = CKR + RZR
5959 0 : CKI = CKI + RZI
5960 0 : C2R = S2R*C1R
5961 0 : C2I = S2I*C1R
5962 0 : YR(I) = C2R
5963 0 : YI(I) = C2I
5964 0 : IF (KFLAG.GE.3) GO TO 120
5965 0 : STR = DABS(C2R)
5966 0 : STI = DABS(C2I)
5967 0 : C2M = DMAX1(STR,STI)
5968 0 : IF (C2M.LE.ASCLE) GO TO 120
5969 0 : KFLAG = KFLAG + 1
5970 0 : ASCLE = BRY(KFLAG)
5971 0 : S1R = S1R*C1R
5972 0 : S1I = S1I*C1R
5973 : S2R = C2R
5974 : S2I = C2I
5975 0 : S1R = S1R*CSSR(KFLAG)
5976 0 : S1I = S1I*CSSR(KFLAG)
5977 0 : S2R = S2R*CSSR(KFLAG)
5978 0 : S2I = S2I*CSSR(KFLAG)
5979 0 : C1R = CSRR(KFLAG)
5980 0 : 120 CONTINUE
5981 : 160 CONTINUE
5982 0 : IF (MR.EQ.0) RETURN
5983 : !C-----------------------------------------------------------------------
5984 : !C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0
5985 : !C-----------------------------------------------------------------------
5986 0 : NZ = 0
5987 0 : FMR = DBLE(FLOAT(MR))
5988 0 : SGN = -DSIGN(PI,FMR)
5989 : !C-----------------------------------------------------------------------
5990 : !C CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP.
5991 : !C-----------------------------------------------------------------------
5992 0 : CSGNI = SGN
5993 0 : INU = INT(SNGL(FNU))
5994 0 : FNF = FNU - DBLE(FLOAT(INU))
5995 0 : IFN = INU + N - 1
5996 0 : ANG = FNF*SGN
5997 0 : CSPNR = DCOS(ANG)
5998 0 : CSPNI = DSIN(ANG)
5999 0 : IF (MOD(IFN,2).EQ.0) GO TO 170
6000 0 : CSPNR = -CSPNR
6001 0 : CSPNI = -CSPNI
6002 : 170 CONTINUE
6003 0 : ASC = BRY(1)
6004 0 : IUF = 0
6005 0 : KK = N
6006 0 : KDFLG = 1
6007 0 : IB = IB - 1
6008 0 : IC = IB - 1
6009 0 : DO 270 K=1,N
6010 0 : FN = FNU + DBLE(FLOAT(KK-1))
6011 : !C-----------------------------------------------------------------------
6012 : !C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K
6013 : !C FUNCTION ABOVE
6014 : !C-----------------------------------------------------------------------
6015 0 : M=3
6016 0 : IF (N.GT.2) GO TO 175
6017 : 172 CONTINUE
6018 0 : INITD = INIT(J)
6019 0 : PHIDR = PHIR(J)
6020 0 : PHIDI = PHII(J)
6021 0 : ZET1DR = ZETA1R(J)
6022 0 : ZET1DI = ZETA1I(J)
6023 0 : ZET2DR = ZETA2R(J)
6024 0 : ZET2DI = ZETA2I(J)
6025 0 : SUMDR = SUMR(J)
6026 0 : SUMDI = SUMI(J)
6027 0 : M = J
6028 0 : J = 3 - J
6029 0 : GO TO 180
6030 : 175 CONTINUE
6031 0 : IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 180
6032 0 : IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 172
6033 0 : INITD = 0
6034 : 180 CONTINUE
6035 : CALL ZUNIK(ZRR, ZRI, FN, 1, 0, TOL, INITD, PHIDR, PHIDI, &
6036 : & ZET1DR, ZET1DI, ZET2DR, ZET2DI, SUMDR, SUMDI, &
6037 0 : & CWRKR(1,M), CWRKI(1,M))
6038 0 : IF (KODE.EQ.1) GO TO 200
6039 0 : STR = ZRR + ZET2DR
6040 0 : STI = ZRI + ZET2DI
6041 0 : RAST = FN/AZABS(STR,STI)
6042 0 : STR = STR*RAST*RAST
6043 0 : STI = -STI*RAST*RAST
6044 0 : S1R = -ZET1DR + STR
6045 0 : S1I = -ZET1DI + STI
6046 0 : GO TO 210
6047 : 200 CONTINUE
6048 0 : S1R = -ZET1DR + ZET2DR
6049 0 : S1I = -ZET1DI + ZET2DI
6050 : 210 CONTINUE
6051 : !C-----------------------------------------------------------------------
6052 : !C TEST FOR UNDERFLOW AND OVERFLOW
6053 : !C-----------------------------------------------------------------------
6054 0 : RS1 = S1R
6055 0 : IF (DABS(RS1).GT.ELIM) GO TO 260
6056 0 : IF (KDFLG.EQ.1) IFLAG = 2
6057 0 : IF (DABS(RS1).LT.ALIM) GO TO 220
6058 : !C-----------------------------------------------------------------------
6059 : !C REFINE TEST AND SCALE
6060 : !C-----------------------------------------------------------------------
6061 0 : APHI = AZABS(PHIDR,PHIDI)
6062 0 : RS1 = RS1 + DLOG(APHI)
6063 0 : IF (DABS(RS1).GT.ELIM) GO TO 260
6064 0 : IF (KDFLG.EQ.1) IFLAG = 1
6065 0 : IF (RS1.LT.0.0D0) GO TO 220
6066 0 : IF (KDFLG.EQ.1) IFLAG = 3
6067 : 220 CONTINUE
6068 0 : STR = PHIDR*SUMDR - PHIDI*SUMDI
6069 0 : STI = PHIDR*SUMDI + PHIDI*SUMDR
6070 0 : S2R = -CSGNI*STI
6071 0 : S2I = CSGNI*STR
6072 0 : STR = DEXP(S1R)*CSSR(IFLAG)
6073 0 : S1R = STR*DCOS(S1I)
6074 0 : S1I = STR*DSIN(S1I)
6075 0 : STR = S2R*S1R - S2I*S1I
6076 0 : S2I = S2R*S1I + S2I*S1R
6077 0 : S2R = STR
6078 0 : IF (IFLAG.NE.1) GO TO 230
6079 0 : CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL)
6080 0 : IF (NW.EQ.0) GO TO 230
6081 0 : S2R = ZEROR
6082 0 : S2I = ZEROI
6083 : 230 CONTINUE
6084 0 : CYR(KDFLG) = S2R
6085 0 : CYI(KDFLG) = S2I
6086 0 : C2R = S2R
6087 0 : C2I = S2I
6088 0 : S2R = S2R*CSRR(IFLAG)
6089 0 : S2I = S2I*CSRR(IFLAG)
6090 : !C-----------------------------------------------------------------------
6091 : !C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N
6092 : !C-----------------------------------------------------------------------
6093 0 : S1R = YR(KK)
6094 0 : S1I = YI(KK)
6095 0 : IF (KODE.EQ.1) GO TO 250
6096 0 : CALL ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NW, ASC, ALIM, IUF)
6097 0 : NZ = NZ + NW
6098 : 250 CONTINUE
6099 0 : YR(KK) = S1R*CSPNR - S1I*CSPNI + S2R
6100 0 : YI(KK) = CSPNR*S1I + CSPNI*S1R + S2I
6101 0 : KK = KK - 1
6102 0 : CSPNR = -CSPNR
6103 0 : CSPNI = -CSPNI
6104 0 : IF (C2R.NE.0.0D0 .OR. C2I.NE.0.0D0) GO TO 255
6105 : KDFLG = 1
6106 0 : GO TO 270
6107 : 255 CONTINUE
6108 0 : IF (KDFLG.EQ.2) GO TO 275
6109 : KDFLG = 2
6110 0 : GO TO 270
6111 : 260 CONTINUE
6112 0 : IF (RS1.GT.0.0D0) GO TO 300
6113 0 : S2R = ZEROR
6114 0 : S2I = ZEROI
6115 0 : GO TO 230
6116 0 : 270 CONTINUE
6117 0 : K = N
6118 : 275 CONTINUE
6119 0 : IL = N - K
6120 0 : IF (IL.EQ.0) RETURN
6121 : !C-----------------------------------------------------------------------
6122 : !C RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE
6123 : !C K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP
6124 : !C INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES.
6125 : !C-----------------------------------------------------------------------
6126 0 : S1R = CYR(1)
6127 0 : S1I = CYI(1)
6128 0 : S2R = CYR(2)
6129 0 : S2I = CYI(2)
6130 0 : CSR = CSRR(IFLAG)
6131 0 : ASCLE = BRY(IFLAG)
6132 0 : FN = DBLE(FLOAT(INU+IL))
6133 0 : DO 290 I=1,IL
6134 0 : C2R = S2R
6135 0 : C2I = S2I
6136 0 : S2R = S1R + (FN+FNF)*(RZR*C2R-RZI*C2I)
6137 0 : S2I = S1I + (FN+FNF)*(RZR*C2I+RZI*C2R)
6138 0 : S1R = C2R
6139 0 : S1I = C2I
6140 0 : FN = FN - 1.0D0
6141 0 : C2R = S2R*CSR
6142 0 : C2I = S2I*CSR
6143 0 : CKR = C2R
6144 0 : CKI = C2I
6145 0 : C1R = YR(KK)
6146 0 : C1I = YI(KK)
6147 0 : IF (KODE.EQ.1) GO TO 280
6148 0 : CALL ZS1S2(ZRR, ZRI, C1R, C1I, C2R, C2I, NW, ASC, ALIM, IUF)
6149 0 : NZ = NZ + NW
6150 : 280 CONTINUE
6151 0 : YR(KK) = C1R*CSPNR - C1I*CSPNI + C2R
6152 0 : YI(KK) = C1R*CSPNI + C1I*CSPNR + C2I
6153 0 : KK = KK - 1
6154 0 : CSPNR = -CSPNR
6155 0 : CSPNI = -CSPNI
6156 0 : IF (IFLAG.GE.3) GO TO 290
6157 0 : C2R = DABS(CKR)
6158 0 : C2I = DABS(CKI)
6159 0 : C2M = DMAX1(C2R,C2I)
6160 0 : IF (C2M.LE.ASCLE) GO TO 290
6161 0 : IFLAG = IFLAG + 1
6162 0 : ASCLE = BRY(IFLAG)
6163 0 : S1R = S1R*CSR
6164 0 : S1I = S1I*CSR
6165 : S2R = CKR
6166 : S2I = CKI
6167 0 : S1R = S1R*CSSR(IFLAG)
6168 0 : S1I = S1I*CSSR(IFLAG)
6169 0 : S2R = S2R*CSSR(IFLAG)
6170 0 : S2I = S2I*CSSR(IFLAG)
6171 0 : CSR = CSRR(IFLAG)
6172 0 : 290 CONTINUE
6173 0 : RETURN
6174 : 300 CONTINUE
6175 0 : NZ = -1
6176 0 : RETURN
6177 : END SUBROUTINE ZUNK1
6178 :
6179 0 : SUBROUTINE ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, &
6180 : & ALIM)
6181 : !C***BEGIN PROLOGUE ZUNK2
6182 : !C***REFER TO ZBESK
6183 : !C
6184 : !C ZUNK2 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE
6185 : !C RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE
6186 : !C UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN)
6187 : !C WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR
6188 : !C -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z IF Z IS IN THE RIGHT
6189 : !C HALF PLANE OR ZR=-Z IF Z IS IN THE LEFT HALF PLANE. MR INDIC-
6190 : !C ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION.
6191 : !C NZ=-1 MEANS AN OVERFLOW WILL OCCUR
6192 : !C
6193 : !C***ROUTINES CALLED ZAIRY,ZKSCL,ZS1S2,ZUCHK,ZUNHJ,D1MACH,AZABS
6194 : !C***END PROLOGUE ZUNK2
6195 : !C COMPLEX AI,ARG,ARGD,ASUM,ASUMD,BSUM,BSUMD,CFN,CI,CIP,CK,CONE,CRSC,
6196 : !C *CR1,CR2,CS,CSCL,CSGN,CSPN,CSR,CSS,CY,CZERO,C1,C2,DAI,PHI,PHID,RZ,
6197 : !C *S1,S2,Y,Z,ZB,ZETA1,ZETA1D,ZETA2,ZETA2D,ZN,ZR
6198 : DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGDI, &
6199 : & ARGDR, ARGI, ARGR, ASC, ASCLE, ASUMDI, ASUMDR, ASUMI, ASUMR, &
6200 : & BRY, BSUMDI, BSUMDR, BSUMI, BSUMR, CAR, CIPI, CIPR, CKI, CKR, &
6201 : & CONER, CRSC, CR1I, CR1R, CR2I, CR2R, CSCL, CSGNI, CSI, &
6202 : & CSPNI, CSPNR, CSR, CSRR, CSSR, CYI, CYR, C1I, C1R, C2I, C2M, &
6203 : & C2R, DAII, DAIR, ELIM, FMR, FN, FNF, FNU, HPI, PHIDI, PHIDR, &
6204 : & PHII, PHIR, PI, PTI, PTR, RAST, RAZR, RS1, RZI, RZR, SAR, SGN, &
6205 : & STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, YY, ZBI, ZBR, ZEROI, &
6206 : & ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZET1DI, ZET1DR, ZET2DI, &
6207 : & ZET2DR, ZI, ZNI, ZNR, ZR, ZRI, ZRR!, D1MACH, AZABS
6208 : INTEGER I, IB, IFLAG, IFN, IL, IN, INU, IUF, K, KDFLG, KFLAG, KK, &
6209 : & KODE, MR, N, NAI, NDAI, NW, NZ, IDUM, J, IPARD, IC
6210 : DIMENSION BRY(3), YR(N), YI(N), ASUMR(2), ASUMI(2), BSUMR(2), &
6211 : & BSUMI(2), PHIR(2), PHII(2), ARGR(2), ARGI(2), ZETA1R(2), &
6212 : & ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2), CIPR(4), &
6213 : & CIPI(4), CSSR(3), CSRR(3)
6214 : DATA ZEROR,ZEROI,CONER,CR1R,CR1I,CR2R,CR2I / &
6215 : & 0.0D0, 0.0D0, 1.0D0, &
6216 : & 1.0D0,1.73205080756887729D0 , -0.5D0,-8.66025403784438647D-01 /
6217 : DATA HPI, PI, AIC / &
6218 : & 1.57079632679489662D+00, 3.14159265358979324D+00, &
6219 : & 1.26551212348464539D+00/
6220 : DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4), &
6221 : & CIPI(4) / &
6222 : & 1.0D0,0.0D0 , 0.0D0,-1.0D0 , -1.0D0,0.0D0 , 0.0D0,1.0D0 /
6223 : !C
6224 0 : KDFLG = 1
6225 0 : NZ = 0
6226 : !C-----------------------------------------------------------------------
6227 : !C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN
6228 : !C THE UNDERFLOW LIMIT
6229 : !C-----------------------------------------------------------------------
6230 0 : CSCL = 1.0D0/TOL
6231 0 : CRSC = TOL
6232 0 : CSSR(1) = CSCL
6233 0 : CSSR(2) = CONER
6234 0 : CSSR(3) = CRSC
6235 0 : CSRR(1) = CRSC
6236 0 : CSRR(2) = CONER
6237 0 : CSRR(3) = CSCL
6238 0 : BRY(1) = 1.0D+3*D1MACH(1)/TOL
6239 0 : BRY(2) = 1.0D0/BRY(1)
6240 0 : BRY(3) = D1MACH(2)
6241 0 : ZRR = ZR
6242 0 : ZRI = ZI
6243 0 : IF (ZR.GE.0.0D0) GO TO 10
6244 0 : ZRR = -ZR
6245 0 : ZRI = -ZI
6246 : 10 CONTINUE
6247 0 : YY = ZRI
6248 0 : ZNR = ZRI
6249 0 : ZNI = -ZRR
6250 0 : ZBR = ZRR
6251 0 : ZBI = ZRI
6252 0 : INU = INT(SNGL(FNU))
6253 0 : FNF = FNU - DBLE(FLOAT(INU))
6254 0 : ANG = -HPI*FNF
6255 0 : CAR = DCOS(ANG)
6256 0 : SAR = DSIN(ANG)
6257 0 : C2R = HPI*SAR
6258 0 : C2I = -HPI*CAR
6259 0 : KK = MOD(INU,4) + 1
6260 0 : STR = C2R*CIPR(KK) - C2I*CIPI(KK)
6261 0 : STI = C2R*CIPI(KK) + C2I*CIPR(KK)
6262 0 : CSR = CR1R*STR - CR1I*STI
6263 0 : CSI = CR1R*STI + CR1I*STR
6264 0 : IF (YY.GT.0.0D0) GO TO 20
6265 0 : ZNR = -ZNR
6266 0 : ZBI = -ZBI
6267 : 20 CONTINUE
6268 : !C-----------------------------------------------------------------------
6269 : !C K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST
6270 : !C QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY
6271 : !C CONJUGATION SINCE THE K FUNCTION IS REAL ON THE POSITIVE REAL AXIS
6272 : !C-----------------------------------------------------------------------
6273 0 : J = 2
6274 0 : DO 80 I=1,N
6275 : !C-----------------------------------------------------------------------
6276 : !C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J
6277 : !C-----------------------------------------------------------------------
6278 0 : J = 3 - J
6279 0 : FN = FNU + DBLE(FLOAT(I-1))
6280 : CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR(J), PHII(J), ARGR(J), &
6281 : & ARGI(J), ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), ASUMR(J), &
6282 0 : & ASUMI(J), BSUMR(J), BSUMI(J))
6283 0 : IF (KODE.EQ.1) GO TO 30
6284 0 : STR = ZBR + ZETA2R(J)
6285 0 : STI = ZBI + ZETA2I(J)
6286 0 : RAST = FN/AZABS(STR,STI)
6287 0 : STR = STR*RAST*RAST
6288 0 : STI = -STI*RAST*RAST
6289 0 : S1R = ZETA1R(J) - STR
6290 0 : S1I = ZETA1I(J) - STI
6291 0 : GO TO 40
6292 : 30 CONTINUE
6293 0 : S1R = ZETA1R(J) - ZETA2R(J)
6294 0 : S1I = ZETA1I(J) - ZETA2I(J)
6295 : 40 CONTINUE
6296 : !C-----------------------------------------------------------------------
6297 : !C TEST FOR UNDERFLOW AND OVERFLOW
6298 : !C-----------------------------------------------------------------------
6299 0 : RS1 = S1R
6300 0 : IF (DABS(RS1).GT.ELIM) GO TO 70
6301 0 : IF (KDFLG.EQ.1) KFLAG = 2
6302 0 : IF (DABS(RS1).LT.ALIM) GO TO 50
6303 : !C-----------------------------------------------------------------------
6304 : !C REFINE TEST AND SCALE
6305 : !C-----------------------------------------------------------------------
6306 0 : APHI = AZABS(PHIR(J),PHII(J))
6307 0 : AARG = AZABS(ARGR(J),ARGI(J))
6308 0 : RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC
6309 0 : IF (DABS(RS1).GT.ELIM) GO TO 70
6310 0 : IF (KDFLG.EQ.1) KFLAG = 1
6311 0 : IF (RS1.LT.0.0D0) GO TO 50
6312 0 : IF (KDFLG.EQ.1) KFLAG = 3
6313 : 50 CONTINUE
6314 : !C-----------------------------------------------------------------------
6315 : !C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR
6316 : !C EXPONENT EXTREMES
6317 : !C-----------------------------------------------------------------------
6318 0 : C2R = ARGR(J)*CR2R - ARGI(J)*CR2I
6319 0 : C2I = ARGR(J)*CR2I + ARGI(J)*CR2R
6320 0 : CALL ZAIRY(C2R, C2I, 0, 2, AIR, AII, NAI, IDUM)
6321 0 : CALL ZAIRY(C2R, C2I, 1, 2, DAIR, DAII, NDAI, IDUM)
6322 0 : STR = DAIR*BSUMR(J) - DAII*BSUMI(J)
6323 0 : STI = DAIR*BSUMI(J) + DAII*BSUMR(J)
6324 0 : PTR = STR*CR2R - STI*CR2I
6325 0 : PTI = STR*CR2I + STI*CR2R
6326 0 : STR = PTR + (AIR*ASUMR(J)-AII*ASUMI(J))
6327 0 : STI = PTI + (AIR*ASUMI(J)+AII*ASUMR(J))
6328 0 : PTR = STR*PHIR(J) - STI*PHII(J)
6329 0 : PTI = STR*PHII(J) + STI*PHIR(J)
6330 0 : S2R = PTR*CSR - PTI*CSI
6331 0 : S2I = PTR*CSI + PTI*CSR
6332 0 : STR = DEXP(S1R)*CSSR(KFLAG)
6333 0 : S1R = STR*DCOS(S1I)
6334 0 : S1I = STR*DSIN(S1I)
6335 0 : STR = S2R*S1R - S2I*S1I
6336 0 : S2I = S1R*S2I + S2R*S1I
6337 0 : S2R = STR
6338 0 : IF (KFLAG.NE.1) GO TO 60
6339 0 : CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL)
6340 0 : IF (NW.NE.0) GO TO 70
6341 : 60 CONTINUE
6342 0 : IF (YY.LE.0.0D0) S2I = -S2I
6343 0 : CYR(KDFLG) = S2R
6344 0 : CYI(KDFLG) = S2I
6345 0 : YR(I) = S2R*CSRR(KFLAG)
6346 0 : YI(I) = S2I*CSRR(KFLAG)
6347 0 : STR = CSI
6348 0 : CSI = -CSR
6349 0 : CSR = STR
6350 0 : IF (KDFLG.EQ.2) GO TO 85
6351 : KDFLG = 2
6352 0 : GO TO 80
6353 : 70 CONTINUE
6354 0 : IF (RS1.GT.0.0D0) GO TO 320
6355 : !C-----------------------------------------------------------------------
6356 : !C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW
6357 : !C-----------------------------------------------------------------------
6358 0 : IF (ZR.LT.0.0D0) GO TO 320
6359 0 : KDFLG = 1
6360 0 : YR(I)=ZEROR
6361 0 : YI(I)=ZEROI
6362 0 : NZ=NZ+1
6363 0 : STR = CSI
6364 0 : CSI =-CSR
6365 0 : CSR = STR
6366 0 : IF (I.EQ.1) GO TO 80
6367 0 : IF ((YR(I-1).EQ.ZEROR).AND.(YI(I-1).EQ.ZEROI)) GO TO 80
6368 0 : YR(I-1)=ZEROR
6369 0 : YI(I-1)=ZEROI
6370 0 : NZ=NZ+1
6371 0 : 80 CONTINUE
6372 0 : I = N
6373 : 85 CONTINUE
6374 0 : RAZR = 1.0D0/AZABS(ZRR,ZRI)
6375 0 : STR = ZRR*RAZR
6376 0 : STI = -ZRI*RAZR
6377 0 : RZR = (STR+STR)*RAZR
6378 0 : RZI = (STI+STI)*RAZR
6379 0 : CKR = FN*RZR
6380 0 : CKI = FN*RZI
6381 0 : IB = I + 1
6382 0 : IF (N.LT.IB) GO TO 180
6383 : !C-----------------------------------------------------------------------
6384 : !C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO
6385 : !C ON UNDERFLOW.
6386 : !C-----------------------------------------------------------------------
6387 0 : FN = FNU + DBLE(FLOAT(N-1))
6388 0 : IPARD = 1
6389 0 : IF (MR.NE.0) IPARD = 0
6390 : CALL ZUNHJ(ZNR, ZNI, FN, IPARD, TOL, PHIDR, PHIDI, ARGDR, ARGDI, &
6391 0 : & ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR, ASUMDI, BSUMDR, BSUMDI)
6392 0 : IF (KODE.EQ.1) GO TO 90
6393 0 : STR = ZBR + ZET2DR
6394 0 : STI = ZBI + ZET2DI
6395 0 : RAST = FN/AZABS(STR,STI)
6396 0 : STR = STR*RAST*RAST
6397 0 : STI = -STI*RAST*RAST
6398 0 : S1R = ZET1DR - STR
6399 0 : S1I = ZET1DI - STI
6400 0 : GO TO 100
6401 : 90 CONTINUE
6402 0 : S1R = ZET1DR - ZET2DR
6403 0 : S1I = ZET1DI - ZET2DI
6404 : 100 CONTINUE
6405 0 : RS1 = S1R
6406 0 : IF (DABS(RS1).GT.ELIM) GO TO 105
6407 0 : IF (DABS(RS1).LT.ALIM) GO TO 120
6408 : !C----------------------------------------------------------------------------
6409 : !C REFINE ESTIMATE AND TEST
6410 : !C-------------------------------------------------------------------------
6411 0 : APHI = AZABS(PHIDR,PHIDI)
6412 0 : RS1 = RS1+DLOG(APHI)
6413 0 : IF (DABS(RS1).LT.ELIM) GO TO 120
6414 : 105 CONTINUE
6415 0 : IF (RS1.GT.0.0D0) GO TO 320
6416 : !C-----------------------------------------------------------------------
6417 : !C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW
6418 : !C-----------------------------------------------------------------------
6419 0 : IF (ZR.LT.0.0D0) GO TO 320
6420 0 : NZ = N
6421 0 : DO 106 I=1,N
6422 0 : YR(I) = ZEROR
6423 0 : YI(I) = ZEROI
6424 0 : 106 CONTINUE
6425 0 : RETURN
6426 : 120 CONTINUE
6427 0 : S1R = CYR(1)
6428 0 : S1I = CYI(1)
6429 0 : S2R = CYR(2)
6430 0 : S2I = CYI(2)
6431 0 : C1R = CSRR(KFLAG)
6432 0 : ASCLE = BRY(KFLAG)
6433 0 : DO 130 I=IB,N
6434 0 : C2R = S2R
6435 0 : C2I = S2I
6436 0 : S2R = CKR*C2R - CKI*C2I + S1R
6437 0 : S2I = CKR*C2I + CKI*C2R + S1I
6438 0 : S1R = C2R
6439 0 : S1I = C2I
6440 0 : CKR = CKR + RZR
6441 0 : CKI = CKI + RZI
6442 0 : C2R = S2R*C1R
6443 0 : C2I = S2I*C1R
6444 0 : YR(I) = C2R
6445 0 : YI(I) = C2I
6446 0 : IF (KFLAG.GE.3) GO TO 130
6447 0 : STR = DABS(C2R)
6448 0 : STI = DABS(C2I)
6449 0 : C2M = DMAX1(STR,STI)
6450 0 : IF (C2M.LE.ASCLE) GO TO 130
6451 0 : KFLAG = KFLAG + 1
6452 0 : ASCLE = BRY(KFLAG)
6453 0 : S1R = S1R*C1R
6454 0 : S1I = S1I*C1R
6455 : S2R = C2R
6456 : S2I = C2I
6457 0 : S1R = S1R*CSSR(KFLAG)
6458 0 : S1I = S1I*CSSR(KFLAG)
6459 0 : S2R = S2R*CSSR(KFLAG)
6460 0 : S2I = S2I*CSSR(KFLAG)
6461 0 : C1R = CSRR(KFLAG)
6462 0 : 130 CONTINUE
6463 : 180 CONTINUE
6464 0 : IF (MR.EQ.0) RETURN
6465 : !C-----------------------------------------------------------------------
6466 : !C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0
6467 : !C-----------------------------------------------------------------------
6468 0 : NZ = 0
6469 0 : FMR = DBLE(FLOAT(MR))
6470 0 : SGN = -DSIGN(PI,FMR)
6471 : !C-----------------------------------------------------------------------
6472 : !C CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP.
6473 : !C-----------------------------------------------------------------------
6474 0 : CSGNI = SGN
6475 0 : IF (YY.LE.0.0D0) CSGNI = -CSGNI
6476 0 : IFN = INU + N - 1
6477 0 : ANG = FNF*SGN
6478 0 : CSPNR = DCOS(ANG)
6479 0 : CSPNI = DSIN(ANG)
6480 0 : IF (MOD(IFN,2).EQ.0) GO TO 190
6481 0 : CSPNR = -CSPNR
6482 0 : CSPNI = -CSPNI
6483 : 190 CONTINUE
6484 : !C-----------------------------------------------------------------------
6485 : !C CS=COEFF OF THE J FUNCTION TO GET THE I FUNCTION. I(FNU,Z) IS
6486 : !C COMPUTED FROM EXP(I*FNU*HPI)*J(FNU,-I*Z) WHERE Z IS IN THE FIRST
6487 : !C QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY
6488 : !C CONJUGATION SINCE THE I FUNCTION IS REAL ON THE POSITIVE REAL AXIS
6489 : !C-----------------------------------------------------------------------
6490 0 : CSR = SAR*CSGNI
6491 0 : CSI = CAR*CSGNI
6492 0 : IN = MOD(IFN,4) + 1
6493 0 : C2R = CIPR(IN)
6494 0 : C2I = CIPI(IN)
6495 0 : STR = CSR*C2R + CSI*C2I
6496 0 : CSI = -CSR*C2I + CSI*C2R
6497 0 : CSR = STR
6498 0 : ASC = BRY(1)
6499 0 : IUF = 0
6500 0 : KK = N
6501 0 : KDFLG = 1
6502 0 : IB = IB - 1
6503 0 : IC = IB - 1
6504 0 : DO 290 K=1,N
6505 0 : FN = FNU + DBLE(FLOAT(KK-1))
6506 : !C-----------------------------------------------------------------------
6507 : !C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K
6508 : !C FUNCTION ABOVE
6509 : !C-----------------------------------------------------------------------
6510 0 : IF (N.GT.2) GO TO 175
6511 : 172 CONTINUE
6512 0 : PHIDR = PHIR(J)
6513 0 : PHIDI = PHII(J)
6514 0 : ARGDR = ARGR(J)
6515 0 : ARGDI = ARGI(J)
6516 0 : ZET1DR = ZETA1R(J)
6517 0 : ZET1DI = ZETA1I(J)
6518 0 : ZET2DR = ZETA2R(J)
6519 0 : ZET2DI = ZETA2I(J)
6520 0 : ASUMDR = ASUMR(J)
6521 0 : ASUMDI = ASUMI(J)
6522 0 : BSUMDR = BSUMR(J)
6523 0 : BSUMDI = BSUMI(J)
6524 0 : J = 3 - J
6525 0 : GO TO 210
6526 : 175 CONTINUE
6527 0 : IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 210
6528 0 : IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 172
6529 : CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIDR, PHIDI, ARGDR, &
6530 : & ARGDI, ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR, &
6531 0 : & ASUMDI, BSUMDR, BSUMDI)
6532 : 210 CONTINUE
6533 0 : IF (KODE.EQ.1) GO TO 220
6534 0 : STR = ZBR + ZET2DR
6535 0 : STI = ZBI + ZET2DI
6536 0 : RAST = FN/AZABS(STR,STI)
6537 0 : STR = STR*RAST*RAST
6538 0 : STI = -STI*RAST*RAST
6539 0 : S1R = -ZET1DR + STR
6540 0 : S1I = -ZET1DI + STI
6541 0 : GO TO 230
6542 : 220 CONTINUE
6543 0 : S1R = -ZET1DR + ZET2DR
6544 0 : S1I = -ZET1DI + ZET2DI
6545 : 230 CONTINUE
6546 : !C-----------------------------------------------------------------------
6547 : !C TEST FOR UNDERFLOW AND OVERFLOW
6548 : !C-----------------------------------------------------------------------
6549 0 : RS1 = S1R
6550 0 : IF (DABS(RS1).GT.ELIM) GO TO 280
6551 0 : IF (KDFLG.EQ.1) IFLAG = 2
6552 0 : IF (DABS(RS1).LT.ALIM) GO TO 240
6553 : !C-----------------------------------------------------------------------
6554 : !C REFINE TEST AND SCALE
6555 : !C-----------------------------------------------------------------------
6556 0 : APHI = AZABS(PHIDR,PHIDI)
6557 0 : AARG = AZABS(ARGDR,ARGDI)
6558 0 : RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC
6559 0 : IF (DABS(RS1).GT.ELIM) GO TO 280
6560 0 : IF (KDFLG.EQ.1) IFLAG = 1
6561 0 : IF (RS1.LT.0.0D0) GO TO 240
6562 0 : IF (KDFLG.EQ.1) IFLAG = 3
6563 : 240 CONTINUE
6564 0 : CALL ZAIRY(ARGDR, ARGDI, 0, 2, AIR, AII, NAI, IDUM)
6565 0 : CALL ZAIRY(ARGDR, ARGDI, 1, 2, DAIR, DAII, NDAI, IDUM)
6566 0 : STR = DAIR*BSUMDR - DAII*BSUMDI
6567 0 : STI = DAIR*BSUMDI + DAII*BSUMDR
6568 0 : STR = STR + (AIR*ASUMDR-AII*ASUMDI)
6569 0 : STI = STI + (AIR*ASUMDI+AII*ASUMDR)
6570 0 : PTR = STR*PHIDR - STI*PHIDI
6571 0 : PTI = STR*PHIDI + STI*PHIDR
6572 0 : S2R = PTR*CSR - PTI*CSI
6573 0 : S2I = PTR*CSI + PTI*CSR
6574 0 : STR = DEXP(S1R)*CSSR(IFLAG)
6575 0 : S1R = STR*DCOS(S1I)
6576 0 : S1I = STR*DSIN(S1I)
6577 0 : STR = S2R*S1R - S2I*S1I
6578 0 : S2I = S2R*S1I + S2I*S1R
6579 0 : S2R = STR
6580 0 : IF (IFLAG.NE.1) GO TO 250
6581 0 : CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL)
6582 0 : IF (NW.EQ.0) GO TO 250
6583 0 : S2R = ZEROR
6584 0 : S2I = ZEROI
6585 : 250 CONTINUE
6586 0 : IF (YY.LE.0.0D0) S2I = -S2I
6587 0 : CYR(KDFLG) = S2R
6588 0 : CYI(KDFLG) = S2I
6589 0 : C2R = S2R
6590 0 : C2I = S2I
6591 0 : S2R = S2R*CSRR(IFLAG)
6592 0 : S2I = S2I*CSRR(IFLAG)
6593 : !C-----------------------------------------------------------------------
6594 : !C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N
6595 : !C-----------------------------------------------------------------------
6596 0 : S1R = YR(KK)
6597 0 : S1I = YI(KK)
6598 0 : IF (KODE.EQ.1) GO TO 270
6599 0 : CALL ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NW, ASC, ALIM, IUF)
6600 0 : NZ = NZ + NW
6601 : 270 CONTINUE
6602 0 : YR(KK) = S1R*CSPNR - S1I*CSPNI + S2R
6603 0 : YI(KK) = S1R*CSPNI + S1I*CSPNR + S2I
6604 0 : KK = KK - 1
6605 0 : CSPNR = -CSPNR
6606 0 : CSPNI = -CSPNI
6607 0 : STR = CSI
6608 0 : CSI = -CSR
6609 0 : CSR = STR
6610 0 : IF (C2R.NE.0.0D0 .OR. C2I.NE.0.0D0) GO TO 255
6611 : KDFLG = 1
6612 0 : GO TO 290
6613 : 255 CONTINUE
6614 0 : IF (KDFLG.EQ.2) GO TO 295
6615 : KDFLG = 2
6616 0 : GO TO 290
6617 : 280 CONTINUE
6618 0 : IF (RS1.GT.0.0D0) GO TO 320
6619 0 : S2R = ZEROR
6620 0 : S2I = ZEROI
6621 0 : GO TO 250
6622 0 : 290 CONTINUE
6623 0 : K = N
6624 : 295 CONTINUE
6625 0 : IL = N - K
6626 0 : IF (IL.EQ.0) RETURN
6627 : !C-----------------------------------------------------------------------
6628 : !C RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE
6629 : !C K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP
6630 : !C INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES.
6631 : !C-----------------------------------------------------------------------
6632 0 : S1R = CYR(1)
6633 0 : S1I = CYI(1)
6634 0 : S2R = CYR(2)
6635 0 : S2I = CYI(2)
6636 0 : CSR = CSRR(IFLAG)
6637 0 : ASCLE = BRY(IFLAG)
6638 0 : FN = DBLE(FLOAT(INU+IL))
6639 0 : DO 310 I=1,IL
6640 0 : C2R = S2R
6641 0 : C2I = S2I
6642 0 : S2R = S1R + (FN+FNF)*(RZR*C2R-RZI*C2I)
6643 0 : S2I = S1I + (FN+FNF)*(RZR*C2I+RZI*C2R)
6644 0 : S1R = C2R
6645 0 : S1I = C2I
6646 0 : FN = FN - 1.0D0
6647 0 : C2R = S2R*CSR
6648 0 : C2I = S2I*CSR
6649 0 : CKR = C2R
6650 0 : CKI = C2I
6651 0 : C1R = YR(KK)
6652 0 : C1I = YI(KK)
6653 0 : IF (KODE.EQ.1) GO TO 300
6654 0 : CALL ZS1S2(ZRR, ZRI, C1R, C1I, C2R, C2I, NW, ASC, ALIM, IUF)
6655 0 : NZ = NZ + NW
6656 : 300 CONTINUE
6657 0 : YR(KK) = C1R*CSPNR - C1I*CSPNI + C2R
6658 0 : YI(KK) = C1R*CSPNI + C1I*CSPNR + C2I
6659 0 : KK = KK - 1
6660 0 : CSPNR = -CSPNR
6661 0 : CSPNI = -CSPNI
6662 0 : IF (IFLAG.GE.3) GO TO 310
6663 0 : C2R = DABS(CKR)
6664 0 : C2I = DABS(CKI)
6665 0 : C2M = DMAX1(C2R,C2I)
6666 0 : IF (C2M.LE.ASCLE) GO TO 310
6667 0 : IFLAG = IFLAG + 1
6668 0 : ASCLE = BRY(IFLAG)
6669 0 : S1R = S1R*CSR
6670 0 : S1I = S1I*CSR
6671 : S2R = CKR
6672 : S2I = CKI
6673 0 : S1R = S1R*CSSR(IFLAG)
6674 0 : S1I = S1I*CSSR(IFLAG)
6675 0 : S2R = S2R*CSSR(IFLAG)
6676 0 : S2I = S2I*CSSR(IFLAG)
6677 0 : CSR = CSRR(IFLAG)
6678 0 : 310 CONTINUE
6679 0 : RETURN
6680 : 320 CONTINUE
6681 0 : NZ = -1
6682 0 : RETURN
6683 : END SUBROUTINE ZUNK2
6684 :
6685 : !----------------------------------------------------------------------
6686 :
6687 :
6688 : END MODULE m_bessel2
6689 : !!***
6690 :
|
