Branch data 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 : :
|
