Reinstate amos for now, since slatec is giving some trouble.

Makefile.extras

@@ -1,7 +1,7 @@
 OPENLIBM_HOME=$(abspath .)
 include ./Make.inc
 
-SUBDIRS = slatec Faddeeva
+SUBDIRS = amos Faddeeva
 
 define INC_template
 TEST=test

amos/.gitignore

@@ -0,0 +1,3 @@
+*.o
+/libamos.dylib
+/libamos.so

amos/Make.files

@@ -0,0 +1,5 @@
+$(CUR_SRCS) +=  d1mach.f zabs.f   zasyi.f  zbesk.f  zbknu.f  zexp.f   zmlt.f   zshch.f  zuni1.f  zunk2.f \
+	dgamln.f zacai.f  zbesh.f  zbesy.f  zbuni.f  zkscl.f  zrati.f  zsqrt.f  zuni2.f  zuoik.f \
+	i1mach.f zacon.f  zbesi.f  zbinu.f  zbunk.f  zlog.f   zs1s2.f  zuchk.f  zunik.f  zwrsk.f \
+	xerror.f zairy.f  zbesj.f  zbiry.f  zdiv.f   zmlri.f  zseri.f  zunhj.f  zunk1.f
+

amos/d1mach.f

@@ -0,0 +1,97 @@
+*DECK D1MACH
+      DOUBLE PRECISION FUNCTION D1MACH(I)
+C***BEGIN PROLOGUE  D1MACH
+C***DATE WRITTEN   750101   (YYMMDD)
+C***REVISION DATE  890213   (YYMMDD)
+C***CATEGORY NO.  R1
+C***KEYWORDS  LIBRARY=SLATEC,TYPE=DOUBLE PRECISION(R1MACH-S D1MACH-D),
+C             MACHINE CONSTANTS
+C***AUTHOR  FOX, P. A., (BELL LABS)
+C           HALL, A. D., (BELL LABS)
+C           SCHRYER, N. L., (BELL LABS)
+C***PURPOSE  Returns double precision machine dependent constants
+C***DESCRIPTION
+C
+C   D1MACH can be used to obtain machine-dependent parameters
+C   for the local machine environment.  It is a function
+C   subprogram with one (input) argument, and can be called
+C   as follows, for example
+C
+C        D = D1MACH(I)
+C
+C   where I=1,...,5.  The (output) value of D above is
+C   determined by the (input) value of I.  The results for
+C   various values of I are discussed below.
+C
+C   D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude.
+C   D1MACH( 2) = B**EMAX*(1 - B**(-T)), the largest magnitude.
+C   D1MACH( 3) = B**(-T), the smallest relative spacing.
+C   D1MACH( 4) = B**(1-T), the largest relative spacing.
+C   D1MACH( 5) = LOG10(B)
+C
+C   Assume double precision numbers are represented in the T-digit,
+C   base-B form
+C
+C              sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
+C
+C   where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and
+C   EMIN .LE. E .LE. EMAX.
+C
+C   The values of B, T, EMIN and EMAX are provided in I1MACH as
+C   follows:
+C   I1MACH(10) = B, the base.
+C   I1MACH(14) = T, the number of base-B digits.
+C   I1MACH(15) = EMIN, the smallest exponent E.
+C   I1MACH(16) = EMAX, the largest exponent E.
+C
+C   To alter this function for a particular environment,
+C   the desired set of DATA statements should be activated by
+C   removing the C from column 1.  Also, the values of
+C   D1MACH(1) - D1MACH(4) should be checked for consistency
+C   with the local operating system.
+C
+C***REFERENCES  FOX P.A., HALL A.D., SCHRYER N.L.,*FRAMEWORK FOR A
+C                 PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHEMATICAL
+C                 SOFTWARE, VOL. 4, NO. 2, JUNE 1978, PP. 177-188.
+C***ROUTINES CALLED  XERROR
+C***END PROLOGUE  D1MACH
+C
+      INTEGER SMALL(4)
+      INTEGER LARGE(4)
+      INTEGER RIGHT(4)
+      INTEGER DIVER(4)
+      INTEGER LOG10(4)
+C
+      DOUBLE PRECISION DMACH(5)
+      SAVE DMACH
+C
+C      EQUIVALENCE (DMACH(1),SMALL(1))
+C      EQUIVALENCE (DMACH(2),LARGE(1))
+C      EQUIVALENCE (DMACH(3),RIGHT(1))
+C      EQUIVALENCE (DMACH(4),DIVER(1))
+C      EQUIVALENCE (DMACH(5),LOG10(1))
+C
+C     MACHINE CONSTANTS FOR THE IBM PC
+C     ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION
+C     ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087.
+C
+      DATA DMACH(1) / 2.23D-308 /
+C      DATA SMALL(1),SMALL(2) /  2002288515,    1050897 /
+      DATA DMACH(2) / 1.79D-308 /
+C      DATA LARGE(1),LARGE(2) /  1487780761, 2146426097 /
+      DATA DMACH(3) / 1.11D-16 /
+C      DATA RIGHT(1),RIGHT(2) / -1209488034, 1017118298 /
+      DATA DMACH(4) / 2.22D-16 /
+C      DATA DIVER(1),DIVER(2) / -1209488034, 1018166874 /
+      DATA DMACH(5) / 0.3010299956639812 /
+C      DATA LOG10(1),LOG10(2) /  1352628735, 1070810131 /
+C
+C
+C***FIRST EXECUTABLE STATEMENT  D1MACH
+      IF (I .LT. 1  .OR.  I .GT. 5)
+     1   CALL XERROR ('D1MACH -- I OUT OF BOUNDS', 25, 1, 2)
+C
+      D1MACH = DMACH(I)
+      RETURN
+C
+      END

amos/dgamln.f

@@ -0,0 +1,189 @@
+      DOUBLE PRECISION FUNCTION DGAMLN(Z,IERR)
+C***BEGIN PROLOGUE  DGAMLN
+C***DATE WRITTEN   830501   (YYMMDD)
+C***REVISION DATE  830501   (YYMMDD)
+C***CATEGORY NO.  B5F
+C***KEYWORDS  GAMMA FUNCTION,LOGARITHM OF GAMMA FUNCTION
+C***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
+C***PURPOSE  TO COMPUTE THE LOGARITHM OF THE GAMMA FUNCTION
+C***DESCRIPTION
+C
+C               **** A DOUBLE PRECISION ROUTINE ****
+C         DGAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR
+C         Z.GT.0.  THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES
+C         GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION
+C         G(Z+1)=Z*G(Z) FOR Z.LE.ZMIN.  THE FUNCTION WAS MADE AS
+C         PORTABLE AS POSSIBLE BY COMPUTIMG ZMIN FROM THE NUMBER OF BASE
+C         10 DIGITS IN A WORD, RLN=AMAX1(-ALOG10(R1MACH(4)),0.5E-18)
+C         LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY.
+C
+C         SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100
+C         VALUES IS USED FOR SPEED OF EXECUTION.
+C
+C     DESCRIPTION OF ARGUMENTS
+C
+C         INPUT      Z IS D0UBLE PRECISION
+C           Z      - ARGUMENT, Z.GT.0.0D0
+C
+C         OUTPUT      DGAMLN IS DOUBLE PRECISION
+C           DGAMLN  - NATURAL LOG OF THE GAMMA FUNCTION AT Z.NE.0.0D0
+C           IERR    - ERROR FLAG
+C                     IERR=0, NORMAL RETURN, COMPUTATION COMPLETED
+C                     IERR=1, Z.LE.0.0D0,    NO COMPUTATION
+C
+C
+C***REFERENCES  COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
+C                 BY D. E. AMOS, SAND83-0083, MAY, 1983.
+C***ROUTINES CALLED  I1MACH,D1MACH
+C***END PROLOGUE  DGAMLN
+      DOUBLE PRECISION CF, CON, FLN, FZ, GLN, RLN, S, TLG, TRM, TST,
+     * T1, WDTOL, Z, ZDMY, ZINC, ZM, ZMIN, ZP, ZSQ, D1MACH
+      INTEGER I, IERR, I1M, K, MZ, NZ, I1MACH
+      DIMENSION CF(22), GLN(100)
+C           LNGAMMA(N), N=1,100
+      DATA GLN(1), GLN(2), GLN(3), GLN(4), GLN(5), GLN(6), GLN(7),
+     1     GLN(8), GLN(9), GLN(10), GLN(11), GLN(12), GLN(13), GLN(14),
+     2     GLN(15), GLN(16), GLN(17), GLN(18), GLN(19), GLN(20),
+     3     GLN(21), GLN(22)/
+     4     0.00000000000000000D+00,     0.00000000000000000D+00,
+     5     6.93147180559945309D-01,     1.79175946922805500D+00,
+     6     3.17805383034794562D+00,     4.78749174278204599D+00,
+     7     6.57925121201010100D+00,     8.52516136106541430D+00,
+     8     1.06046029027452502D+01,     1.28018274800814696D+01,
+     9     1.51044125730755153D+01,     1.75023078458738858D+01,
+     A     1.99872144956618861D+01,     2.25521638531234229D+01,
+     B     2.51912211827386815D+01,     2.78992713838408916D+01,
+     C     3.06718601060806728D+01,     3.35050734501368889D+01,
+     D     3.63954452080330536D+01,     3.93398841871994940D+01,
+     E     4.23356164607534850D+01,     4.53801388984769080D+01/
+      DATA GLN(23), GLN(24), GLN(25), GLN(26), GLN(27), GLN(28),
+     1     GLN(29), GLN(30), GLN(31), GLN(32), GLN(33), GLN(34),
+     2     GLN(35), GLN(36), GLN(37), GLN(38), GLN(39), GLN(40),
+     3     GLN(41), GLN(42), GLN(43), GLN(44)/
+     4     4.84711813518352239D+01,     5.16066755677643736D+01,
+     5     5.47847293981123192D+01,     5.80036052229805199D+01,
+     6     6.12617017610020020D+01,     6.45575386270063311D+01,
+     7     6.78897431371815350D+01,     7.12570389671680090D+01,
+     8     7.46582363488301644D+01,     7.80922235533153106D+01,
+     9     8.15579594561150372D+01,     8.50544670175815174D+01,
+     A     8.85808275421976788D+01,     9.21361756036870925D+01,
+     B     9.57196945421432025D+01,     9.93306124547874269D+01,
+     C     1.02968198614513813D+02,     1.06631760260643459D+02,
+     D     1.10320639714757395D+02,     1.14034211781461703D+02,
+     E     1.17771881399745072D+02,     1.21533081515438634D+02/
+      DATA GLN(45), GLN(46), GLN(47), GLN(48), GLN(49), GLN(50),
+     1     GLN(51), GLN(52), GLN(53), GLN(54), GLN(55), GLN(56),
+     2     GLN(57), GLN(58), GLN(59), GLN(60), GLN(61), GLN(62),
+     3     GLN(63), GLN(64), GLN(65), GLN(66)/
+     4     1.25317271149356895D+02,     1.29123933639127215D+02,
+     5     1.32952575035616310D+02,     1.36802722637326368D+02,
+     6     1.40673923648234259D+02,     1.44565743946344886D+02,
+     7     1.48477766951773032D+02,     1.52409592584497358D+02,
+     8     1.56360836303078785D+02,     1.60331128216630907D+02,
+     9     1.64320112263195181D+02,     1.68327445448427652D+02,
+     A     1.72352797139162802D+02,     1.76395848406997352D+02,
+     B     1.80456291417543771D+02,     1.84533828861449491D+02,
+     C     1.88628173423671591D+02,     1.92739047287844902D+02,
+     D     1.96866181672889994D+02,     2.01009316399281527D+02,
+     E     2.05168199482641199D+02,     2.09342586752536836D+02/
+      DATA GLN(67), GLN(68), GLN(69), GLN(70), GLN(71), GLN(72),
+     1     GLN(73), GLN(74), GLN(75), GLN(76), GLN(77), GLN(78),
+     2     GLN(79), GLN(80), GLN(81), GLN(82), GLN(83), GLN(84),
+     3     GLN(85), GLN(86), GLN(87), GLN(88)/
+     4     2.13532241494563261D+02,     2.17736934113954227D+02,
+     5     2.21956441819130334D+02,     2.26190548323727593D+02,
+     6     2.30439043565776952D+02,     2.34701723442818268D+02,
+     7     2.38978389561834323D+02,     2.43268849002982714D+02,
+     8     2.47572914096186884D+02,     2.51890402209723194D+02,
+     9     2.56221135550009525D+02,     2.60564940971863209D+02,
+     A     2.64921649798552801D+02,     2.69291097651019823D+02,
+     B     2.73673124285693704D+02,     2.78067573440366143D+02,
+     C     2.82474292687630396D+02,     2.86893133295426994D+02,
+     D     2.91323950094270308D+02,     2.95766601350760624D+02,
+     E     3.00220948647014132D+02,     3.04686856765668715D+02/
+      DATA GLN(89), GLN(90), GLN(91), GLN(92), GLN(93), GLN(94),
+     1     GLN(95), GLN(96), GLN(97), GLN(98), GLN(99), GLN(100)/
+     2     3.09164193580146922D+02,     3.13652829949879062D+02,
+     3     3.18152639620209327D+02,     3.22663499126726177D+02,
+     4     3.27185287703775217D+02,     3.31717887196928473D+02,
+     5     3.36261181979198477D+02,     3.40815058870799018D+02,
+     6     3.45379407062266854D+02,     3.49954118040770237D+02,
+     7     3.54539085519440809D+02,     3.59134205369575399D+02/
+C             COEFFICIENTS OF ASYMPTOTIC EXPANSION
+      DATA CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), CF(8),
+     1     CF(9), CF(10), CF(11), CF(12), CF(13), CF(14), CF(15),
+     2     CF(16), CF(17), CF(18), CF(19), CF(20), CF(21), CF(22)/
+     3     8.33333333333333333D-02,    -2.77777777777777778D-03,
+     4     7.93650793650793651D-04,    -5.95238095238095238D-04,
+     5     8.41750841750841751D-04,    -1.91752691752691753D-03,
+     6     6.41025641025641026D-03,    -2.95506535947712418D-02,
+     7     1.79644372368830573D-01,    -1.39243221690590112D+00,
+     8     1.34028640441683920D+01,    -1.56848284626002017D+02,
+     9     2.19310333333333333D+03,    -3.61087712537249894D+04,
+     A     6.91472268851313067D+05,    -1.52382215394074162D+07,
+     B     3.82900751391414141D+08,    -1.08822660357843911D+10,
+     C     3.47320283765002252D+11,    -1.23696021422692745D+13,
+     D     4.88788064793079335D+14,    -2.13203339609193739D+16/
+C
+C             LN(2*PI)
+      DATA CON                    /     1.83787706640934548D+00/
+C
+C***FIRST EXECUTABLE STATEMENT  DGAMLN
+      IERR=0
+      IF (Z.LE.0.0D0) GO TO 70
+      IF (Z.GT.101.0D0) GO TO 10
+      NZ = INT(SNGL(Z))
+      FZ = Z - FLOAT(NZ)
+      IF (FZ.GT.0.0D0) GO TO 10
+      IF (NZ.GT.100) GO TO 10
+      DGAMLN = GLN(NZ)
+      RETURN
+   10 CONTINUE
+      WDTOL = D1MACH(4)
+      WDTOL = DMAX1(WDTOL,0.5D-18)
+      I1M = I1MACH(14)
+      RLN = D1MACH(5)*FLOAT(I1M)
+      FLN = DMIN1(RLN,20.0D0)
+      FLN = DMAX1(FLN,3.0D0)
+      FLN = FLN - 3.0D0
+      ZM = 1.8000D0 + 0.3875D0*FLN
+      MZ = INT(SNGL(ZM)) + 1
+      ZMIN = FLOAT(MZ)
+      ZDMY = Z
+      ZINC = 0.0D0
+      IF (Z.GE.ZMIN) GO TO 20
+      ZINC = ZMIN - FLOAT(NZ)
+      ZDMY = Z + ZINC
+   20 CONTINUE
+      ZP = 1.0D0/ZDMY
+      T1 = CF(1)*ZP
+      S = T1
+      IF (ZP.LT.WDTOL) GO TO 40
+      ZSQ = ZP*ZP
+      TST = T1*WDTOL
+      DO 30 K=2,22
+        ZP = ZP*ZSQ
+        TRM = CF(K)*ZP
+        IF (DABS(TRM).LT.TST) GO TO 40
+        S = S + TRM
+   30 CONTINUE
+   40 CONTINUE
+      IF (ZINC.NE.0.0D0) GO TO 50
+      TLG = DLOG(Z)
+      DGAMLN = Z*(TLG-1.0D0) + 0.5D0*(CON-TLG) + S
+      RETURN
+   50 CONTINUE
+      ZP = 1.0D0
+      NZ = INT(SNGL(ZINC))
+      DO 60 I=1,NZ
+        ZP = ZP*(Z+FLOAT(I-1))
+   60 CONTINUE
+      TLG = DLOG(ZDMY)
+      DGAMLN = ZDMY*(TLG-1.0D0) - DLOG(ZP) + 0.5D0*(CON-TLG) + S
+      RETURN
+C
+C
+   70 CONTINUE
+      IERR=1
+      RETURN
+      END

amos/i1mach.f

@@ -0,0 +1,113 @@
+*DECK I1MACH
+      INTEGER FUNCTION I1MACH(I)
+C***BEGIN PROLOGUE  I1MACH
+C***DATE WRITTEN   750101   (YYMMDD)
+C***REVISION DATE  890213   (YYMMDD)
+C***CATEGORY NO.  R1
+C***KEYWORDS  LIBRARY=SLATEC,TYPE=INTEGER(I1MACH-I),MACHINE CONSTANTS
+C***AUTHOR  FOX, P. A., (BELL LABS)
+C           HALL, A. D., (BELL LABS)
+C           SCHRYER, N. L., (BELL LABS)
+C***PURPOSE  Returns integer machine dependent constants
+C***DESCRIPTION
+C
+C     I1MACH can be used to obtain machine-dependent parameters
+C     for the local machine environment.  It is a function
+C     subroutine with one (input) argument, and can be called
+C     as follows, for example
+C
+C          K = I1MACH(I)
+C
+C     where I=1,...,16.  The (output) value of K above is
+C     determined by the (input) value of I.  The results for
+C     various values of I are discussed below.
+C
+C  I/O unit numbers.
+C    I1MACH( 1) = the standard input unit.
+C    I1MACH( 2) = the standard output unit.
+C    I1MACH( 3) = the standard punch unit.
+C    I1MACH( 4) = the standard error message unit.
+C
+C  Words.
+C    I1MACH( 5) = the number of bits per integer storage unit.
+C    I1MACH( 6) = the number of characters per integer storage unit.
+C
+C  Integers.
+C    assume integers are represented in the S-digit, base-A form
+C
+C               sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
+C
+C               where 0 .LE. X(I) .LT. A for I=0,...,S-1.
+C    I1MACH( 7) = A, the base.
+C    I1MACH( 8) = S, the number of base-A digits.
+C    I1MACH( 9) = A**S - 1, the largest magnitude.
+C
+C  Floating-Point Numbers.
+C    Assume floating-point numbers are represented in the T-digit,
+C    base-B form
+C               sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
+C
+C               where 0 .LE. X(I) .LT. B for I=1,...,T,
+C               0 .LT. X(1), and EMIN .LE. E .LE. EMAX.
+C    I1MACH(10) = B, the base.
+C
+C  Single-Precision
+C    I1MACH(11) = T, the number of base-B digits.
+C    I1MACH(12) = EMIN, the smallest exponent E.
+C    I1MACH(13) = EMAX, the largest exponent E.
+C
+C  Double-Precision
+C    I1MACH(14) = T, the number of base-B digits.
+C    I1MACH(15) = EMIN, the smallest exponent E.
+C    I1MACH(16) = EMAX, the largest exponent E.
+C
+C  To alter this function for a particular environment,
+C  the desired set of DATA statements should be activated by
+C  removing the C from column 1.  Also, the values of
+C  I1MACH(1) - I1MACH(4) should be checked for consistency
+C  with the local operating system.
+C
+C***REFERENCES  FOX P.A., HALL A.D., SCHRYER N.L.,*FRAMEWORK FOR A
+C                 PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHEMATICAL
+C                 SOFTWARE, VOL. 4, NO. 2, JUNE 1978, PP. 177-188.
+C***ROUTINES CALLED  (NONE)
+C***END PROLOGUE  I1MACH
+C
+      INTEGER IMACH(16),OUTPUT
+      SAVE IMACH
+      EQUIVALENCE (IMACH(4),OUTPUT)
+C
+C     MACHINE CONSTANTS FOR THE IBM PC
+C
+      DATA IMACH( 1) /     5 /
+      DATA IMACH( 2) /     6 /
+      DATA IMACH( 3) /     0 /
+      DATA IMACH( 4) /     0 /
+      DATA IMACH( 5) /    32 /
+      DATA IMACH( 6) /     4 /
+      DATA IMACH( 7) /     2 /
+      DATA IMACH( 8) /    31 /
+      DATA IMACH( 9) / 2147483647 /
+      DATA IMACH(10) /     2 /
+      DATA IMACH(11) /    24 /
+      DATA IMACH(12) /  -125 /
+      DATA IMACH(13) /   127 /
+      DATA IMACH(14) /    53 /
+      DATA IMACH(15) / -1021 /
+      DATA IMACH(16) /  1023 /
+C
+C***FIRST EXECUTABLE STATEMENT  I1MACH
+      IF (I .LT. 1  .OR.  I .GT. 16) GO TO 10
+C
+      I1MACH = IMACH(I)
+      RETURN
+C
+   10 CONTINUE
+      WRITE (UNIT = OUTPUT, FMT = 9000)
+ 9000 FORMAT ('1ERROR    1 IN I1MACH - I OUT OF BOUNDS')
+C
+C     CALL FDUMP
+C
+C
+      STOP
+      END

amos/xerror.f

@@ -0,0 +1,22 @@
+      SUBROUTINE XERROR(MESS,NMESS,L1,L2)
+C
+C     THIS IS A DUMMY XERROR ROUTINE TO PRINT ERROR MESSAGES WITH NMESS
+C     CHARACTERS. L1 AND L2 ARE DUMMY PARAMETERS TO MAKE THIS CALL
+C     COMPATIBLE WITH THE SLATEC XERROR ROUTINE. THIS IS A FORTRAN 77
+C     ROUTINE.
+C
+      CHARACTER*(*) MESS
+      NN=NMESS/70
+      NR=NMESS-70*NN
+      IF(NR.NE.0) NN=NN+1
+      K=1
+      PRINT 900
+  900 FORMAT(/)
+      DO 10 I=1,NN
+        KMIN=MIN0(K+69,NMESS)
+        PRINT *, MESS(K:KMIN)
+        K=K+70
+   10 CONTINUE
+      PRINT 900
+      RETURN
+      END

amos/zabs.f

@@ -0,0 +1,29 @@
+      DOUBLE PRECISION FUNCTION ZABS(ZR, ZI)
+C***BEGIN PROLOGUE  ZABS
+C***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
+C
+C     ZABS COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE
+C     PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI)
+C
+C***ROUTINES CALLED  (NONE)
+C***END PROLOGUE  ZABS
+      DOUBLE PRECISION ZR, ZI, U, V, Q, S
+      U = DABS(ZR)
+      V = DABS(ZI)
+      S = U + V
+C-----------------------------------------------------------------------
+C     S*1.0D0 MAKES AN UNNORMALIZED UNDERFLOW ON CDC MACHINES INTO A
+C     TRUE FLOATING ZERO
+C-----------------------------------------------------------------------
+      S = S*1.0D+0
+      IF (S.EQ.0.0D+0) GO TO 20
+      IF (U.GT.V) GO TO 10
+      Q = U/V
+      ZABS = V*DSQRT(1.D+0+Q*Q)
+      RETURN
+   10 Q = V/U
+      ZABS = U*DSQRT(1.D+0+Q*Q)
+      RETURN
+   20 ZABS = 0.0D+0
+      RETURN
+      END

amos/zacai.f

@@ -0,0 +1,99 @@
+      SUBROUTINE ZACAI(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, TOL,
+     * ELIM, ALIM)
+C***BEGIN PROLOGUE  ZACAI
+C***REFER TO  ZAIRY
+C
+C     ZACAI APPLIES THE ANALYTIC CONTINUATION FORMULA
+C
+C         K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN)
+C                 MP=PI*MR*CMPLX(0.0,1.0)
+C
+C     TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT
+C     HALF Z PLANE FOR USE WITH ZAIRY WHERE FNU=1/3 OR 2/3 AND N=1.
+C     ZACAI IS THE SAME AS ZACON WITH THE PARTS FOR LARGER ORDERS AND
+C     RECURRENCE REMOVED. A RECURSIVE CALL TO ZACON CAN RESULT IF ZACON
+C     IS CALLED FROM ZAIRY.
+C
+C***ROUTINES CALLED  ZASYI,ZBKNU,ZMLRI,ZSERI,ZS1S2,D1MACH,ZABS
+C***END PROLOGUE  ZACAI
+C     COMPLEX CSGN,CSPN,C1,C2,Y,Z,ZN,CY
+      DOUBLE PRECISION ALIM, ARG, ASCLE, AZ, CSGNR, CSGNI, CSPNR,
+     * CSPNI, C1R, C1I, C2R, C2I, CYR, CYI, DFNU, ELIM, FMR, FNU, PI,
+     * RL, SGN, TOL, YY, YR, YI, ZR, ZI, ZNR, ZNI, D1MACH, ZABS
+      INTEGER INU, IUF, KODE, MR, N, NN, NW, NZ
+      DIMENSION YR(N), YI(N), CYR(2), CYI(2)
+      DATA PI / 3.14159265358979324D0 /
+      NZ = 0
+      ZNR = -ZR
+      ZNI = -ZI
+      AZ = ZABS(COMPLEX(ZR,ZI))
+      NN = N
+      DFNU = FNU + DBLE(FLOAT(N-1))
+      IF (AZ.LE.2.0D0) GO TO 10
+      IF (AZ*AZ*0.25D0.GT.DFNU+1.0D0) GO TO 20
+   10 CONTINUE
+C-----------------------------------------------------------------------
+C     POWER SERIES FOR THE I FUNCTION
+C-----------------------------------------------------------------------
+      CALL ZSERI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL, ELIM, ALIM)
+      GO TO 40
+   20 CONTINUE
+      IF (AZ.LT.RL) GO TO 30
+C-----------------------------------------------------------------------
+C     ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I FUNCTION
+C-----------------------------------------------------------------------
+      CALL ZASYI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, TOL, ELIM,
+     * ALIM)
+      IF (NW.LT.0) GO TO 80
+      GO TO 40
+   30 CONTINUE
+C-----------------------------------------------------------------------
+C     MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION
+C-----------------------------------------------------------------------
+      CALL ZMLRI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL)
+      IF(NW.LT.0) GO TO 80
+   40 CONTINUE
+C-----------------------------------------------------------------------
+C     ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION
+C-----------------------------------------------------------------------
+      CALL ZBKNU(ZNR, ZNI, FNU, KODE, 1, CYR, CYI, NW, TOL, ELIM, ALIM)
+      IF (NW.NE.0) GO TO 80
+      FMR = DBLE(FLOAT(MR))
+      SGN = -DSIGN(PI,FMR)
+      CSGNR = 0.0D0
+      CSGNI = SGN
+      IF (KODE.EQ.1) GO TO 50
+      YY = -ZNI
+      CSGNR = -CSGNI*DSIN(YY)
+      CSGNI = CSGNI*DCOS(YY)
+   50 CONTINUE
+C-----------------------------------------------------------------------
+C     CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
+C     WHEN FNU IS LARGE
+C-----------------------------------------------------------------------
+      INU = INT(SNGL(FNU))
+      ARG = (FNU-DBLE(FLOAT(INU)))*SGN
+      CSPNR = DCOS(ARG)
+      CSPNI = DSIN(ARG)
+      IF (MOD(INU,2).EQ.0) GO TO 60
+      CSPNR = -CSPNR
+      CSPNI = -CSPNI
+   60 CONTINUE
+      C1R = CYR(1)
+      C1I = CYI(1)
+      C2R = YR(1)
+      C2I = YI(1)
+      IF (KODE.EQ.1) GO TO 70
+      IUF = 0
+      ASCLE = 1.0D+3*D1MACH(1)/TOL
+      CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF)
+      NZ = NZ + NW
+   70 CONTINUE
+      YR(1) = CSPNR*C1R - CSPNI*C1I + CSGNR*C2R - CSGNI*C2I
+      YI(1) = CSPNR*C1I + CSPNI*C1R + CSGNR*C2I + CSGNI*C2R
+      RETURN
+   80 CONTINUE
+      NZ = -1
+      IF(NW.EQ.(-2)) NZ=-2
+      RETURN
+      END

amos/zacon.f

@@ -0,0 +1,203 @@
+      SUBROUTINE ZACON(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, FNUL,
+     * TOL, ELIM, ALIM)
+C***BEGIN PROLOGUE  ZACON
+C***REFER TO  ZBESK,ZBESH
+C
+C     ZACON APPLIES THE ANALYTIC CONTINUATION FORMULA
+C
+C         K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN)
+C                 MP=PI*MR*CMPLX(0.0,1.0)
+C
+C     TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT
+C     HALF Z PLANE
+C
+C***ROUTINES CALLED  ZBINU,ZBKNU,ZS1S2,D1MACH,ZABS,ZMLT
+C***END PROLOGUE  ZACON
+C     COMPLEX CK,CONE,CSCL,CSCR,CSGN,CSPN,CY,CZERO,C1,C2,RZ,SC1,SC2,ST,
+C    *S1,S2,Y,Z,ZN
+      DOUBLE PRECISION ALIM, ARG, ASCLE, AS2, AZN, BRY, BSCLE, CKI,
+     * CKR, CONER, CPN, CSCL, CSCR, CSGNI, CSGNR, CSPNI, CSPNR,
+     * CSR, CSRR, CSSR, CYI, CYR, C1I, C1M, C1R, C2I, C2R, ELIM, FMR,
+     * FN, FNU, FNUL, PI, PTI, PTR, RAZN, RL, RZI, RZR, SC1I, SC1R,
+     * SC2I, SC2R, SGN, SPN, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR,
+     * YY, ZEROR, ZI, ZNI, ZNR, ZR, D1MACH, ZABS
+      INTEGER I, INU, IUF, KFLAG, KODE, MR, N, NN, NW, NZ
+      DIMENSION YR(N), YI(N), CYR(2), CYI(2), CSSR(3), CSRR(3), BRY(3)
+      DATA PI / 3.14159265358979324D0 /
+      DATA ZEROR,CONER / 0.0D0,1.0D0 /
+      NZ = 0
+      ZNR = -ZR
+      ZNI = -ZI
+      NN = N
+      CALL ZBINU(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, FNUL, TOL,
+     * ELIM, ALIM)
+      IF (NW.LT.0) GO TO 90
+C-----------------------------------------------------------------------
+C     ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION
+C-----------------------------------------------------------------------
+      NN = MIN0(2,N)
+      CALL ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM)
+      IF (NW.NE.0) GO TO 90
+      S1R = CYR(1)
+      S1I = CYI(1)
+      FMR = DBLE(FLOAT(MR))
+      SGN = -DSIGN(PI,FMR)
+      CSGNR = ZEROR
+      CSGNI = SGN
+      IF (KODE.EQ.1) GO TO 10
+      YY = -ZNI
+      CPN = DCOS(YY)
+      SPN = DSIN(YY)
+      CALL ZMLT(CSGNR, CSGNI, CPN, SPN, CSGNR, CSGNI)
+   10 CONTINUE
+C-----------------------------------------------------------------------
+C     CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
+C     WHEN FNU IS LARGE
+C-----------------------------------------------------------------------
+      INU = INT(SNGL(FNU))
+      ARG = (FNU-DBLE(FLOAT(INU)))*SGN
+      CPN = DCOS(ARG)
+      SPN = DSIN(ARG)
+      CSPNR = CPN
+      CSPNI = SPN
+      IF (MOD(INU,2).EQ.0) GO TO 20
+      CSPNR = -CSPNR
+      CSPNI = -CSPNI
+   20 CONTINUE
+      IUF = 0
+      C1R = S1R
+      C1I = S1I
+      C2R = YR(1)
+      C2I = YI(1)
+      ASCLE = 1.0D+3*D1MACH(1)/TOL
+      IF (KODE.EQ.1) GO TO 30
+      CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF)
+      NZ = NZ + NW
+      SC1R = C1R
+      SC1I = C1I
+   30 CONTINUE
+      CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI)
+      CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI)
+      YR(1) = STR + PTR
+      YI(1) = STI + PTI
+      IF (N.EQ.1) RETURN
+      CSPNR = -CSPNR
+      CSPNI = -CSPNI
+      S2R = CYR(2)
+      S2I = CYI(2)
+      C1R = S2R
+      C1I = S2I
+      C2R = YR(2)
+      C2I = YI(2)
+      IF (KODE.EQ.1) GO TO 40
+      CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF)
+      NZ = NZ + NW
+      SC2R = C1R
+      SC2I = C1I
+   40 CONTINUE
+      CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI)
+      CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI)
+      YR(2) = STR + PTR
+      YI(2) = STI + PTI
+      IF (N.EQ.2) RETURN
+      CSPNR = -CSPNR
+      CSPNI = -CSPNI
+      AZN = ZABS(COMPLEX(ZNR,ZNI))
+      RAZN = 1.0D0/AZN
+      STR = ZNR*RAZN
+      STI = -ZNI*RAZN
+      RZR = (STR+STR)*RAZN
+      RZI = (STI+STI)*RAZN
+      FN = FNU + 1.0D0
+      CKR = FN*RZR
+      CKI = FN*RZI
+C-----------------------------------------------------------------------
+C     SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS
+C-----------------------------------------------------------------------
+      CSCL = 1.0D0/TOL
+      CSCR = TOL
+      CSSR(1) = CSCL
+      CSSR(2) = CONER
+      CSSR(3) = CSCR
+      CSRR(1) = CSCR
+      CSRR(2) = CONER
+      CSRR(3) = CSCL
+      BRY(1) = ASCLE
+      BRY(2) = 1.0D0/ASCLE
+      BRY(3) = D1MACH(2)
+      AS2 = ZABS(COMPLEX(S2R,S2I))
+      KFLAG = 2
+      IF (AS2.GT.BRY(1)) GO TO 50
+      KFLAG = 1
+      GO TO 60
+   50 CONTINUE
+      IF (AS2.LT.BRY(2)) GO TO 60
+      KFLAG = 3
+   60 CONTINUE
+      BSCLE = BRY(KFLAG)
+      S1R = S1R*CSSR(KFLAG)
+      S1I = S1I*CSSR(KFLAG)
+      S2R = S2R*CSSR(KFLAG)
+      S2I = S2I*CSSR(KFLAG)
+      CSR = CSRR(KFLAG)
+      DO 80 I=3,N
+        STR = S2R
+        STI = S2I
+        S2R = CKR*STR - CKI*STI + S1R
+        S2I = CKR*STI + CKI*STR + S1I
+        S1R = STR
+        S1I = STI
+        C1R = S2R*CSR
+        C1I = S2I*CSR
+        STR = C1R
+        STI = C1I
+        C2R = YR(I)
+        C2I = YI(I)
+        IF (KODE.EQ.1) GO TO 70
+        IF (IUF.LT.0) GO TO 70
+        CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF)
+        NZ = NZ + NW
+        SC1R = SC2R
+        SC1I = SC2I
+        SC2R = C1R
+        SC2I = C1I
+        IF (IUF.NE.3) GO TO 70
+        IUF = -4
+        S1R = SC1R*CSSR(KFLAG)
+        S1I = SC1I*CSSR(KFLAG)
+        S2R = SC2R*CSSR(KFLAG)
+        S2I = SC2I*CSSR(KFLAG)
+        STR = SC2R
+        STI = SC2I
+   70   CONTINUE
+        PTR = CSPNR*C1R - CSPNI*C1I
+        PTI = CSPNR*C1I + CSPNI*C1R
+        YR(I) = PTR + CSGNR*C2R - CSGNI*C2I
+        YI(I) = PTI + CSGNR*C2I + CSGNI*C2R
+        CKR = CKR + RZR
+        CKI = CKI + RZI
+        CSPNR = -CSPNR
+        CSPNI = -CSPNI
+        IF (KFLAG.GE.3) GO TO 80
+        PTR = DABS(C1R)
+        PTI = DABS(C1I)
+        C1M = DMAX1(PTR,PTI)
+        IF (C1M.LE.BSCLE) GO TO 80
+        KFLAG = KFLAG + 1
+        BSCLE = BRY(KFLAG)
+        S1R = S1R*CSR
+        S1I = S1I*CSR
+        S2R = STR
+        S2I = STI
+        S1R = S1R*CSSR(KFLAG)
+        S1I = S1I*CSSR(KFLAG)
+        S2R = S2R*CSSR(KFLAG)
+        S2I = S2I*CSSR(KFLAG)
+        CSR = CSRR(KFLAG)
+   80 CONTINUE
+      RETURN
+   90 CONTINUE
+      NZ = -1
+      IF(NW.EQ.(-2)) NZ=-2
+      RETURN
+      END

amos/zairy.f

@@ -0,0 +1,393 @@
+      SUBROUTINE ZAIRY(ZR, ZI, ID, KODE, AIR, AII, NZ, IERR)
+C***BEGIN PROLOGUE  ZAIRY
+C***DATE WRITTEN   830501   (YYMMDD)
+C***REVISION DATE  890801   (YYMMDD)
+C***CATEGORY NO.  B5K
+C***KEYWORDS  AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD
+C***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
+C***PURPOSE  TO COMPUTE AIRY FUNCTIONS AI(Z) AND DAI(Z) FOR COMPLEX Z
+C***DESCRIPTION
+C
+C                      ***A DOUBLE PRECISION ROUTINE***
+C         ON KODE=1, ZAIRY COMPUTES THE COMPLEX AIRY FUNCTION AI(Z) OR
+C         ITS DERIVATIVE DAI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON
+C         KODE=2, A SCALING OPTION CEXP(ZTA)*AI(Z) OR CEXP(ZTA)*
+C         DAI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL DECAY IN
+C         -PI/3.LT.ARG(Z).LT.PI/3 AND THE EXPONENTIAL GROWTH IN
+C         PI/3.LT.ABS(ARG(Z)).LT.PI WHERE ZTA=(2/3)*Z*CSQRT(Z).
+C
+C         WHILE THE AIRY FUNCTIONS AI(Z) AND DAI(Z)/DZ ARE ANALYTIC IN
+C         THE WHOLE Z PLANE, THE CORRESPONDING SCALED FUNCTIONS DEFINED
+C         FOR KODE=2 HAVE A CUT ALONG THE NEGATIVE REAL AXIS.
+C         DEFINTIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF
+C         MATHEMATICAL FUNCTIONS (REF. 1).
+C
+C         INPUT      ZR,ZI ARE DOUBLE PRECISION
+C           ZR,ZI  - Z=CMPLX(ZR,ZI)
+C           ID     - ORDER OF DERIVATIVE, ID=0 OR ID=1
+C           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION
+C                    KODE= 1  RETURNS
+C                             AI=AI(Z)                ON ID=0 OR
+C                             AI=DAI(Z)/DZ            ON ID=1
+C                        = 2  RETURNS
+C                             AI=CEXP(ZTA)*AI(Z)       ON ID=0 OR
+C                             AI=CEXP(ZTA)*DAI(Z)/DZ   ON ID=1 WHERE
+C                             ZTA=(2/3)*Z*CSQRT(Z)
+C
+C         OUTPUT     AIR,AII ARE DOUBLE PRECISION
+C           AIR,AII- COMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND
+C                    KODE
+C           NZ     - UNDERFLOW INDICATOR
+C                    NZ= 0   , NORMAL RETURN
+C                    NZ= 1   , AI=CMPLX(0.0D0,0.0D0) DUE TO UNDERFLOW IN
+C                              -PI/3.LT.ARG(Z).LT.PI/3 ON KODE=1
+C           IERR   - ERROR FLAG
+C                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
+C                    IERR=1, INPUT ERROR   - NO COMPUTATION
+C                    IERR=2, OVERFLOW      - NO COMPUTATION, REAL(ZTA)
+C                            TOO LARGE ON KODE=1
+C                    IERR=3, CABS(Z) LARGE      - COMPUTATION COMPLETED
+C                            LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION
+C                            PRODUCE LESS THAN HALF OF MACHINE ACCURACY
+C                    IERR=4, CABS(Z) TOO LARGE  - NO COMPUTATION
+C                            COMPLETE LOSS OF ACCURACY BY ARGUMENT
+C                            REDUCTION
+C                    IERR=5, ERROR              - NO COMPUTATION,
+C                            ALGORITHM TERMINATION CONDITION NOT MET
+C
+C***LONG DESCRIPTION
+C
+C         AI AND DAI ARE COMPUTED FOR CABS(Z).GT.1.0 FROM THE K BESSEL
+C         FUNCTIONS BY
+C
+C            AI(Z)=C*SQRT(Z)*K(1/3,ZTA) , DAI(Z)=-C*Z*K(2/3,ZTA)
+C                           C=1.0/(PI*SQRT(3.0))
+C                            ZTA=(2/3)*Z**(3/2)
+C
+C         WITH THE POWER SERIES FOR CABS(Z).LE.1.0.
+C
+C         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
+C         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES
+C         OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF
+C         THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR),
+C         THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR
+C         FLAG IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
+C         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
+C         ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN
+C         ALL SIGNIFICANCE IS LOST AND IERR=4. IN ORDER TO USE THE INT
+C         FUNCTION, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE
+C         LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA
+C         MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2,
+C         AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE
+C         PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE
+C         PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT-
+C         ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG-
+C         NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN
+C         DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN
+C         EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES,
+C         NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE
+C         PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER
+C         MACHINES.
+C
+C         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
+C         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
+C         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
+C         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
+C         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
+C         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
+C         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
+C         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
+C         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
+C         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
+C         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
+C         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
+C         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
+C         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
+C         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
+C         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
+C         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
+C         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
+C         OR -PI/2+P.
+C
+C***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
+C                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
+C                 COMMERCE, 1955.
+C
+C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
+C                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
+C
+C               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
+C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
+C                 1018, MAY, 1985
+C
+C               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
+C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
+C                 MATH. SOFTWARE, 1986
+C
+C***ROUTINES CALLED  ZACAI,ZBKNU,ZEXP,ZSQRT,I1MACH,D1MACH
+C***END PROLOGUE  ZAIRY
+C     COMPLEX AI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3
+      DOUBLE PRECISION AA, AD, AII, AIR, AK, ALIM, ATRM, AZ, AZ3, BK,
+     * CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2, DIG,
+     * DK, D1, D2, ELIM, FID, FNU, PTR, RL, R1M5, SFAC, STI, STR,
+     * S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I, TRM2R, TTH, ZEROI,
+     * ZEROR, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS, ALAZ, BB
+      INTEGER ID, IERR, IFLAG, K, KODE, K1, K2, MR, NN, NZ, I1MACH
+      DIMENSION CYR(1), CYI(1)
+      DATA TTH, C1, C2, COEF /6.66666666666666667D-01,
+     * 3.55028053887817240D-01,2.58819403792806799D-01,
+     * 1.83776298473930683D-01/
+      DATA ZEROR, ZEROI, CONER, CONEI /0.0D0,0.0D0,1.0D0,0.0D0/
+C***FIRST EXECUTABLE STATEMENT  ZAIRY
+      IERR = 0
+      NZ=0
+      IF (ID.LT.0 .OR. ID.GT.1) IERR=1
+      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
+      IF (IERR.NE.0) RETURN
+      AZ = ZABS(COMPLEX(ZR,ZI))
+      TOL = DMAX1(D1MACH(4),1.0D-18)
+      FID = DBLE(FLOAT(ID))
+      IF (AZ.GT.1.0D0) GO TO 70
+C-----------------------------------------------------------------------
+C     POWER SERIES FOR CABS(Z).LE.1.
+C-----------------------------------------------------------------------
+      S1R = CONER
+      S1I = CONEI
+      S2R = CONER
+      S2I = CONEI
+      IF (AZ.LT.TOL) GO TO 170
+      AA = AZ*AZ
+      IF (AA.LT.TOL/AZ) GO TO 40
+      TRM1R = CONER
+      TRM1I = CONEI
+      TRM2R = CONER
+      TRM2I = CONEI
+      ATRM = 1.0D0
+      STR = ZR*ZR - ZI*ZI
+      STI = ZR*ZI + ZI*ZR
+      Z3R = STR*ZR - STI*ZI
+      Z3I = STR*ZI + STI*ZR
+      AZ3 = AZ*AA
+      AK = 2.0D0 + FID
+      BK = 3.0D0 - FID - FID
+      CK = 4.0D0 - FID
+      DK = 3.0D0 + FID + FID
+      D1 = AK*DK
+      D2 = BK*CK
+      AD = DMIN1(D1,D2)
+      AK = 24.0D0 + 9.0D0*FID
+      BK = 30.0D0 - 9.0D0*FID
+      DO 30 K=1,25
+        STR = (TRM1R*Z3R-TRM1I*Z3I)/D1
+        TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1
+        TRM1R = STR
+        S1R = S1R + TRM1R
+        S1I = S1I + TRM1I
+        STR = (TRM2R*Z3R-TRM2I*Z3I)/D2
+        TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2
+        TRM2R = STR
+        S2R = S2R + TRM2R
+        S2I = S2I + TRM2I
+        ATRM = ATRM*AZ3/AD
+        D1 = D1 + AK
+        D2 = D2 + BK
+        AD = DMIN1(D1,D2)
+        IF (ATRM.LT.TOL*AD) GO TO 40
+        AK = AK + 18.0D0
+        BK = BK + 18.0D0
+   30 CONTINUE
+   40 CONTINUE
+      IF (ID.EQ.1) GO TO 50
+      AIR = S1R*C1 - C2*(ZR*S2R-ZI*S2I)
+      AII = S1I*C1 - C2*(ZR*S2I+ZI*S2R)
+      IF (KODE.EQ.1) RETURN
+      CALL ZSQRT(ZR, ZI, STR, STI)
+      ZTAR = TTH*(ZR*STR-ZI*STI)
+      ZTAI = TTH*(ZR*STI+ZI*STR)
+      CALL ZEXP(ZTAR, ZTAI, STR, STI)
+      PTR = AIR*STR - AII*STI
+      AII = AIR*STI + AII*STR
+      AIR = PTR
+      RETURN
+   50 CONTINUE
+      AIR = -S2R*C2
+      AII = -S2I*C2
+      IF (AZ.LE.TOL) GO TO 60
+      STR = ZR*S1R - ZI*S1I
+      STI = ZR*S1I + ZI*S1R
+      CC = C1/(1.0D0+FID)
+      AIR = AIR + CC*(STR*ZR-STI*ZI)
+      AII = AII + CC*(STR*ZI+STI*ZR)
+   60 CONTINUE
+      IF (KODE.EQ.1) RETURN
+      CALL ZSQRT(ZR, ZI, STR, STI)
+      ZTAR = TTH*(ZR*STR-ZI*STI)
+      ZTAI = TTH*(ZR*STI+ZI*STR)
+      CALL ZEXP(ZTAR, ZTAI, STR, STI)
+      PTR = STR*AIR - STI*AII
+      AII = STR*AII + STI*AIR
+      AIR = PTR
+      RETURN
+C-----------------------------------------------------------------------
+C     CASE FOR CABS(Z).GT.1.0
+C-----------------------------------------------------------------------
+   70 CONTINUE
+      FNU = (1.0D0+FID)/3.0D0
+C-----------------------------------------------------------------------
+C     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
+C     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0D-18.
+C     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
+C     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND
+C     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
+C     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
+C     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
+C     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
+C-----------------------------------------------------------------------
+      K1 = I1MACH(15)
+      K2 = I1MACH(16)
+      R1M5 = D1MACH(5)
+      K = MIN0(IABS(K1),IABS(K2))
+      ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
+      K1 = I1MACH(14) - 1
+      AA = R1M5*DBLE(FLOAT(K1))
+      DIG = DMIN1(AA,18.0D0)
+      AA = AA*2.303D0
+      ALIM = ELIM + DMAX1(-AA,-41.45D0)
+      RL = 1.2D0*DIG + 3.0D0
+      ALAZ = DLOG(AZ)
+C--------------------------------------------------------------------------
+C     TEST FOR PROPER RANGE
+C-----------------------------------------------------------------------
+      AA=0.5D0/TOL
+      BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
+      AA=DMIN1(AA,BB)
+      AA=AA**TTH
+      IF (AZ.GT.AA) GO TO 260
+      AA=DSQRT(AA)
+      IF (AZ.GT.AA) IERR=3
+      CALL ZSQRT(ZR, ZI, CSQR, CSQI)
+      ZTAR = TTH*(ZR*CSQR-ZI*CSQI)
+      ZTAI = TTH*(ZR*CSQI+ZI*CSQR)
+C-----------------------------------------------------------------------
+C     RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL
+C-----------------------------------------------------------------------
+      IFLAG = 0
+      SFAC = 1.0D0
+      AK = ZTAI
+      IF (ZR.GE.0.0D0) GO TO 80
+      BK = ZTAR
+      CK = -DABS(BK)
+      ZTAR = CK
+      ZTAI = AK
+   80 CONTINUE
+      IF (ZI.NE.0.0D0) GO TO 90
+      IF (ZR.GT.0.0D0) GO TO 90
+      ZTAR = 0.0D0
+      ZTAI = AK
+   90 CONTINUE
+      AA = ZTAR
+      IF (AA.GE.0.0D0 .AND. ZR.GT.0.0D0) GO TO 110
+      IF (KODE.EQ.2) GO TO 100
+C-----------------------------------------------------------------------
+C     OVERFLOW TEST
+C-----------------------------------------------------------------------
+      IF (AA.GT.(-ALIM)) GO TO 100
+      AA = -AA + 0.25D0*ALAZ
+      IFLAG = 1
+      SFAC = TOL
+      IF (AA.GT.ELIM) GO TO 270
+  100 CONTINUE
+C-----------------------------------------------------------------------
+C     CBKNU AND CACON RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2
+C-----------------------------------------------------------------------
+      MR = 1
+      IF (ZI.LT.0.0D0) MR = -1
+      CALL ZACAI(ZTAR, ZTAI, FNU, KODE, MR, 1, CYR, CYI, NN, RL, TOL,
+     * ELIM, ALIM)
+      IF (NN.LT.0) GO TO 280
+      NZ = NZ + NN
+      GO TO 130
+  110 CONTINUE
+      IF (KODE.EQ.2) GO TO 120
+C-----------------------------------------------------------------------
+C     UNDERFLOW TEST
+C-----------------------------------------------------------------------
+      IF (AA.LT.ALIM) GO TO 120
+      AA = -AA - 0.25D0*ALAZ
+      IFLAG = 2
+      SFAC = 1.0D0/TOL
+      IF (AA.LT.(-ELIM)) GO TO 210
+  120 CONTINUE
+      CALL ZBKNU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, TOL, ELIM,
+     * ALIM)
+  130 CONTINUE
+      S1R = CYR(1)*COEF
+      S1I = CYI(1)*COEF
+      IF (IFLAG.NE.0) GO TO 150
+      IF (ID.EQ.1) GO TO 140
+      AIR = CSQR*S1R - CSQI*S1I
+      AII = CSQR*S1I + CSQI*S1R
+      RETURN
+  140 CONTINUE
+      AIR = -(ZR*S1R-ZI*S1I)
+      AII = -(ZR*S1I+ZI*S1R)
+      RETURN
+  150 CONTINUE
+      S1R = S1R*SFAC
+      S1I = S1I*SFAC
+      IF (ID.EQ.1) GO TO 160
+      STR = S1R*CSQR - S1I*CSQI
+      S1I = S1R*CSQI + S1I*CSQR
+      S1R = STR
+      AIR = S1R/SFAC
+      AII = S1I/SFAC
+      RETURN
+  160 CONTINUE
+      STR = -(S1R*ZR-S1I*ZI)
+      S1I = -(S1R*ZI+S1I*ZR)
+      S1R = STR
+      AIR = S1R/SFAC
+      AII = S1I/SFAC
+      RETURN
+  170 CONTINUE
+      AA = 1.0D+3*D1MACH(1)
+      S1R = ZEROR
+      S1I = ZEROI
+      IF (ID.EQ.1) GO TO 190
+      IF (AZ.LE.AA) GO TO 180
+      S1R = C2*ZR
+      S1I = C2*ZI
+  180 CONTINUE
+      AIR = C1 - S1R
+      AII = -S1I
+      RETURN
+  190 CONTINUE
+      AIR = -C2
+      AII = 0.0D0
+      AA = DSQRT(AA)
+      IF (AZ.LE.AA) GO TO 200
+      S1R = 0.5D0*(ZR*ZR-ZI*ZI)
+      S1I = ZR*ZI
+  200 CONTINUE
+      AIR = AIR + C1*S1R
+      AII = AII + C1*S1I
+      RETURN
+  210 CONTINUE
+      NZ = 1
+      AIR = ZEROR
+      AII = ZEROI
+      RETURN
+  270 CONTINUE
+      NZ = 0
+      IERR=2
+      RETURN
+  280 CONTINUE
+      IF(NN.EQ.(-1)) GO TO 270
+      NZ=0
+      IERR=5
+      RETURN
+  260 CONTINUE
+      IERR=4
+      NZ=0
+      RETURN
+      END

amos/zasyi.f

@@ -0,0 +1,165 @@
+      SUBROUTINE ZASYI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, RL, TOL, ELIM,
+     * ALIM)
+C***BEGIN PROLOGUE  ZASYI
+C***REFER TO  ZBESI,ZBESK
+C
+C     ZASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY
+C     MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z) IN THE
+C     REGION CABS(Z).GT.MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL RETURN.
+C     NZ.LT.0 INDICATES AN OVERFLOW ON KODE=1.
+C
+C***ROUTINES CALLED  D1MACH,ZABS,ZDIV,ZEXP,ZMLT,ZSQRT
+C***END PROLOGUE  ZASYI
+C     COMPLEX AK1,CK,CONE,CS1,CS2,CZ,CZERO,DK,EZ,P1,RZ,S2,Y,Z
+      DOUBLE PRECISION AA, AEZ, AK, AK1I, AK1R, ALIM, ARG, ARM, ATOL,
+     * AZ, BB, BK, CKI, CKR, CONEI, CONER, CS1I, CS1R, CS2I, CS2R, CZI,
+     * CZR, DFNU, DKI, DKR, DNU2, ELIM, EZI, EZR, FDN, FNU, PI, P1I,
+     * P1R, RAZ, RL, RTPI, RTR1, RZI, RZR, S, SGN, SQK, STI, STR, S2I,
+     * S2R, TOL, TZI, TZR, YI, YR, ZEROI, ZEROR, ZI, ZR, D1MACH, ZABS
+      INTEGER I, IB, IL, INU, J, JL, K, KODE, KODED, M, N, NN, NZ
+      DIMENSION YR(N), YI(N)
+      DATA PI, RTPI  /3.14159265358979324D0 , 0.159154943091895336D0 /
+      DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
+C
+      NZ = 0
+      AZ = ZABS(COMPLEX(ZR,ZI))
+      ARM = 1.0D+3*D1MACH(1)
+      RTR1 = DSQRT(ARM)
+      IL = MIN0(2,N)
+      DFNU = FNU + DBLE(FLOAT(N-IL))
+C-----------------------------------------------------------------------
+C     OVERFLOW TEST
+C-----------------------------------------------------------------------
+      RAZ = 1.0D0/AZ
+      STR = ZR*RAZ
+      STI = -ZI*RAZ
+      AK1R = RTPI*STR*RAZ
+      AK1I = RTPI*STI*RAZ
+      CALL ZSQRT(AK1R, AK1I, AK1R, AK1I)
+      CZR = ZR
+      CZI = ZI
+      IF (KODE.NE.2) GO TO 10
+      CZR = ZEROR
+      CZI = ZI
+   10 CONTINUE
+      IF (DABS(CZR).GT.ELIM) GO TO 100
+      DNU2 = DFNU + DFNU
+      KODED = 1
+      IF ((DABS(CZR).GT.ALIM) .AND. (N.GT.2)) GO TO 20
+      KODED = 0
+      CALL ZEXP(CZR, CZI, STR, STI)
+      CALL ZMLT(AK1R, AK1I, STR, STI, AK1R, AK1I)
+   20 CONTINUE
+      FDN = 0.0D0
+      IF (DNU2.GT.RTR1) FDN = DNU2*DNU2
+      EZR = ZR*8.0D0
+      EZI = ZI*8.0D0
+C-----------------------------------------------------------------------
+C     WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO THE
+C     FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF THE
+C     EXPANSION FOR THE IMAGINARY PART.
+C-----------------------------------------------------------------------
+      AEZ = 8.0D0*AZ
+      S = TOL/AEZ
+      JL = INT(SNGL(RL+RL)) + 2
+      P1R = ZEROR
+      P1I = ZEROI
+      IF (ZI.EQ.0.0D0) GO TO 30
+C-----------------------------------------------------------------------
+C     CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF
+C     SIGNIFICANCE WHEN FNU OR N IS LARGE
+C-----------------------------------------------------------------------
+      INU = INT(SNGL(FNU))
+      ARG = (FNU-DBLE(FLOAT(INU)))*PI
+      INU = INU + N - IL
+      AK = -DSIN(ARG)
+      BK = DCOS(ARG)
+      IF (ZI.LT.0.0D0) BK = -BK
+      P1R = AK
+      P1I = BK
+      IF (MOD(INU,2).EQ.0) GO TO 30
+      P1R = -P1R
+      P1I = -P1I
+   30 CONTINUE
+      DO 70 K=1,IL
+        SQK = FDN - 1.0D0
+        ATOL = S*DABS(SQK)
+        SGN = 1.0D0
+        CS1R = CONER
+        CS1I = CONEI
+        CS2R = CONER
+        CS2I = CONEI
+        CKR = CONER
+        CKI = CONEI
+        AK = 0.0D0
+        AA = 1.0D0
+        BB = AEZ
+        DKR = EZR
+        DKI = EZI
+        DO 40 J=1,JL
+          CALL ZDIV(CKR, CKI, DKR, DKI, STR, STI)
+          CKR = STR*SQK
+          CKI = STI*SQK
+          CS2R = CS2R + CKR
+          CS2I = CS2I + CKI
+          SGN = -SGN
+          CS1R = CS1R + CKR*SGN
+          CS1I = CS1I + CKI*SGN
+          DKR = DKR + EZR
+          DKI = DKI + EZI
+          AA = AA*DABS(SQK)/BB
+          BB = BB + AEZ
+          AK = AK + 8.0D0
+          SQK = SQK - AK
+          IF (AA.LE.ATOL) GO TO 50
+   40   CONTINUE
+        GO TO 110
+   50   CONTINUE
+        S2R = CS1R
+        S2I = CS1I
+        IF (ZR+ZR.GE.ELIM) GO TO 60
+        TZR = ZR + ZR
+        TZI = ZI + ZI
+        CALL ZEXP(-TZR, -TZI, STR, STI)
+        CALL ZMLT(STR, STI, P1R, P1I, STR, STI)
+        CALL ZMLT(STR, STI, CS2R, CS2I, STR, STI)
+        S2R = S2R + STR
+        S2I = S2I + STI
+   60   CONTINUE
+        FDN = FDN + 8.0D0*DFNU + 4.0D0
+        P1R = -P1R
+        P1I = -P1I
+        M = N - IL + K
+        YR(M) = S2R*AK1R - S2I*AK1I
+        YI(M) = S2R*AK1I + S2I*AK1R
+   70 CONTINUE
+      IF (N.LE.2) RETURN
+      NN = N
+      K = NN - 2
+      AK = DBLE(FLOAT(K))
+      STR = ZR*RAZ
+      STI = -ZI*RAZ
+      RZR = (STR+STR)*RAZ
+      RZI = (STI+STI)*RAZ
+      IB = 3
+      DO 80 I=IB,NN
+        YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2)
+        YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2)
+        AK = AK - 1.0D0
+        K = K - 1
+   80 CONTINUE
+      IF (KODED.EQ.0) RETURN
+      CALL ZEXP(CZR, CZI, CKR, CKI)
+      DO 90 I=1,NN
+        STR = YR(I)*CKR - YI(I)*CKI
+        YI(I) = YR(I)*CKI + YI(I)*CKR
+        YR(I) = STR
+   90 CONTINUE
+      RETURN
+  100 CONTINUE
+      NZ = -1
+      RETURN
+  110 CONTINUE
+      NZ=-2
+      RETURN
+      END

amos/zbesh.f

@@ -0,0 +1,348 @@
+      SUBROUTINE ZBESH(ZR, ZI, FNU, KODE, M, N, CYR, CYI, NZ, IERR)
+C***BEGIN PROLOGUE  ZBESH
+C***DATE WRITTEN   830501   (YYMMDD)
+C***REVISION DATE  890801   (YYMMDD)
+C***CATEGORY NO.  B5K
+C***KEYWORDS  H-BESSEL FUNCTIONS,BESSEL FUNCTIONS OF COMPLEX ARGUMENT,
+C             BESSEL FUNCTIONS OF THIRD KIND,HANKEL FUNCTIONS
+C***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
+C***PURPOSE  TO COMPUTE THE H-BESSEL FUNCTIONS OF A COMPLEX ARGUMENT
+C***DESCRIPTION
+C
+C                      ***A DOUBLE PRECISION ROUTINE***
+C         ON KODE=1, ZBESH COMPUTES AN N MEMBER SEQUENCE OF COMPLEX
+C         HANKEL (BESSEL) FUNCTIONS CY(J)=H(M,FNU+J-1,Z) FOR KINDS M=1
+C         OR 2, REAL, NONNEGATIVE ORDERS FNU+J-1, J=1,...,N, AND COMPLEX
+C         Z.NE.CMPLX(0.0,0.0) IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI.
+C         ON KODE=2, ZBESH RETURNS THE SCALED HANKEL FUNCTIONS
+C
+C         CY(I)=EXP(-MM*Z*I)*H(M,FNU+J-1,Z)       MM=3-2*M,   I**2=-1.
+C
+C         WHICH REMOVES THE EXPONENTIAL BEHAVIOR IN BOTH THE UPPER AND
+C         LOWER HALF PLANES. DEFINITIONS AND NOTATION ARE FOUND IN THE
+C         NBS HANDBOOK OF MATHEMATICAL FUNCTIONS (REF. 1).
+C
+C         INPUT      ZR,ZI,FNU ARE DOUBLE PRECISION
+C           ZR,ZI  - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0),
+C                    -PT.LT.ARG(Z).LE.PI
+C           FNU    - ORDER OF INITIAL H FUNCTION, FNU.GE.0.0D0
+C           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION
+C                    KODE= 1  RETURNS
+C                             CY(J)=H(M,FNU+J-1,Z),   J=1,...,N
+C                        = 2  RETURNS
+C                             CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M))
+C                                  J=1,...,N  ,  I**2=-1
+C           M      - KIND OF HANKEL FUNCTION, M=1 OR 2
+C           N      - NUMBER OF MEMBERS IN THE SEQUENCE, N.GE.1
+C
+C         OUTPUT     CYR,CYI ARE DOUBLE PRECISION
+C           CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS
+C                    CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE
+C                    CY(J)=H(M,FNU+J-1,Z)  OR
+C                    CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M))  J=1,...,N
+C                    DEPENDING ON KODE, I**2=-1.
+C           NZ     - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW,
+C                    NZ= 0   , NORMAL RETURN
+C                    NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO DUE
+C                              TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0)
+C                              J=1,...,NZ WHEN Y.GT.0.0 AND M=1 OR
+C                              Y.LT.0.0 AND M=2. FOR THE COMPLMENTARY
+C                              HALF PLANES, NZ STATES ONLY THE NUMBER
+C                              OF UNDERFLOWS.
+C           IERR   - ERROR FLAG
+C                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
+C                    IERR=1, INPUT ERROR   - NO COMPUTATION
+C                    IERR=2, OVERFLOW      - NO COMPUTATION, FNU TOO
+C                            LARGE OR CABS(Z) TOO SMALL OR BOTH
+C                    IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
+C                            BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
+C                            REDUCTION PRODUCE LESS THAN HALF OF MACHINE
+C                            ACCURACY
+C                    IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
+C                            TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
+C                            CANCE BY ARGUMENT REDUCTION
+C                    IERR=5, ERROR              - NO COMPUTATION,
+C                            ALGORITHM TERMINATION CONDITION NOT MET
+C
+C***LONG DESCRIPTION
+C
+C         THE COMPUTATION IS CARRIED OUT BY THE RELATION
+C
+C         H(M,FNU,Z)=(1/MP)*EXP(-MP*FNU)*K(FNU,Z*EXP(-MP))
+C             MP=MM*HPI*I,  MM=3-2*M,  HPI=PI/2,  I**2=-1
+C
+C         FOR M=1 OR 2 WHERE THE K BESSEL FUNCTION IS COMPUTED FOR THE
+C         RIGHT HALF PLANE RE(Z).GE.0.0. THE K FUNCTION IS CONTINUED
+C         TO THE LEFT HALF PLANE BY THE RELATION
+C
+C         K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z)
+C         MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1
+C
+C         WHERE I(FNU,Z) IS THE I BESSEL FUNCTION.
+C
+C         EXPONENTIAL DECAY OF H(M,FNU,Z) OCCURS IN THE UPPER HALF Z
+C         PLANE FOR M=1 AND THE LOWER HALF Z PLANE FOR M=2.  EXPONENTIAL
+C         GROWTH OCCURS IN THE COMPLEMENTARY HALF PLANES.  SCALING
+C         BY EXP(-MM*Z*I) REMOVES THE EXPONENTIAL BEHAVIOR IN THE
+C         WHOLE Z PLANE FOR Z TO INFINITY.
+C
+C         FOR NEGATIVE ORDERS,THE FORMULAE
+C
+C               H(1,-FNU,Z) = H(1,FNU,Z)*CEXP( PI*FNU*I)
+C               H(2,-FNU,Z) = H(2,FNU,Z)*CEXP(-PI*FNU*I)
+C                         I**2=-1
+C
+C         CAN BE USED.
+C
+C         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
+C         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS
+C         LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.
+C         CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN
+C         LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG
+C         IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
+C         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
+C         IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS
+C         LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS
+C         MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE
+C         INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS
+C         RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
+C         ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
+C         ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
+C         ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
+C         THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
+C         TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
+C         IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
+C         SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
+C
+C         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
+C         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
+C         ROUNDOFF,1.0D-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
+C         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
+C         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
+C         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
+C         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
+C         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
+C         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
+C         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
+C         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
+C         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
+C         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
+C         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
+C         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
+C         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
+C         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
+C         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
+C         OR -PI/2+P.
+C
+C***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
+C                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
+C                 COMMERCE, 1955.
+C
+C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
+C                 BY D. E. AMOS, SAND83-0083, MAY, 1983.
+C
+C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
+C                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
+C
+C               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
+C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
+C                 1018, MAY, 1985
+C
+C               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
+C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
+C                 MATH. SOFTWARE, 1986
+C
+C***ROUTINES CALLED  ZACON,ZBKNU,ZBUNK,ZUOIK,ZABS,I1MACH,D1MACH
+C***END PROLOGUE  ZBESH
+C
+C     COMPLEX CY,Z,ZN,ZT,CSGN
+      DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM,
+     * FMM, FN, FNU, FNUL, HPI, RHPI, RL, R1M5, SGN, STR, TOL, UFL, ZI,
+     * ZNI, ZNR, ZR, ZTI, D1MACH, ZABS, BB, ASCLE, RTOL, ATOL, STI,
+     * CSGNR, CSGNI
+      INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, M,
+     * MM, MR, N, NN, NUF, NW, NZ, I1MACH
+      DIMENSION CYR(N), CYI(N)
+C
+      DATA HPI /1.57079632679489662D0/
+C
+C***FIRST EXECUTABLE STATEMENT  ZBESH
+      IERR = 0
+      NZ=0
+      IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1
+      IF (FNU.LT.0.0D0) IERR=1
+      IF (M.LT.1 .OR. M.GT.2) IERR=1
+      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
+      IF (N.LT.1) IERR=1
+      IF (IERR.NE.0) RETURN
+      NN = N
+C-----------------------------------------------------------------------
+C     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
+C     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
+C     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
+C     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND
+C     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
+C     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
+C     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
+C     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
+C     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU
+C-----------------------------------------------------------------------
+      TOL = DMAX1(D1MACH(4),1.0D-18)
+      K1 = I1MACH(15)
+      K2 = I1MACH(16)
+      R1M5 = D1MACH(5)
+      K = MIN0(IABS(K1),IABS(K2))
+      ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
+      K1 = I1MACH(14) - 1
+      AA = R1M5*DBLE(FLOAT(K1))
+      DIG = DMIN1(AA,18.0D0)
+      AA = AA*2.303D0
+      ALIM = ELIM + DMAX1(-AA,-41.45D0)
+      FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
+      RL = 1.2D0*DIG + 3.0D0
+      FN = FNU + DBLE(FLOAT(NN-1))
+      MM = 3 - M - M
+      FMM = DBLE(FLOAT(MM))
+      ZNR = FMM*ZI
+      ZNI = -FMM*ZR
+C-----------------------------------------------------------------------
+C     TEST FOR PROPER RANGE
+C-----------------------------------------------------------------------
+      AZ = ZABS(COMPLEX(ZR,ZI))
+      AA = 0.5D0/TOL
+      BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
+      AA = DMIN1(AA,BB)
+      IF (AZ.GT.AA) GO TO 260
+      IF (FN.GT.AA) GO TO 260
+      AA = DSQRT(AA)
+      IF (AZ.GT.AA) IERR=3
+      IF (FN.GT.AA) IERR=3
+C-----------------------------------------------------------------------
+C     OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE
+C-----------------------------------------------------------------------
+      UFL = D1MACH(1)*1.0D+3
+      IF (AZ.LT.UFL) GO TO 230
+      IF (FNU.GT.FNUL) GO TO 90
+      IF (FN.LE.1.0D0) GO TO 70
+      IF (FN.GT.2.0D0) GO TO 60
+      IF (AZ.GT.TOL) GO TO 70
+      ARG = 0.5D0*AZ
+      ALN = -FN*DLOG(ARG)
+      IF (ALN.GT.ELIM) GO TO 230
+      GO TO 70
+   60 CONTINUE
+      CALL ZUOIK(ZNR, ZNI, FNU, KODE, 2, NN, CYR, CYI, NUF, TOL, ELIM,
+     * ALIM)
+      IF (NUF.LT.0) GO TO 230
+      NZ = NZ + NUF
+      NN = NN - NUF
+C-----------------------------------------------------------------------
+C     HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK
+C     IF NUF=NN, THEN CY(I)=CZERO FOR ALL I
+C-----------------------------------------------------------------------
+      IF (NN.EQ.0) GO TO 140
+   70 CONTINUE
+      IF ((ZNR.LT.0.0D0) .OR. (ZNR.EQ.0.0D0 .AND. ZNI.LT.0.0D0 .AND.
+     * M.EQ.2)) GO TO 80
+C-----------------------------------------------------------------------
+C     RIGHT HALF PLANE COMPUTATION, XN.GE.0. .AND. (XN.NE.0. .OR.
+C     YN.GE.0. .OR. M=1)
+C-----------------------------------------------------------------------
+      CALL ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NZ, TOL, ELIM, ALIM)
+      GO TO 110
+C-----------------------------------------------------------------------
+C     LEFT HALF PLANE COMPUTATION
+C-----------------------------------------------------------------------
+   80 CONTINUE
+      MR = -MM
+      CALL ZACON(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL,
+     * TOL, ELIM, ALIM)
+      IF (NW.LT.0) GO TO 240
+      NZ=NW
+      GO TO 110
+   90 CONTINUE
+C-----------------------------------------------------------------------
+C     UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL
+C-----------------------------------------------------------------------
+      MR = 0
+      IF ((ZNR.GE.0.0D0) .AND. (ZNR.NE.0.0D0 .OR. ZNI.GE.0.0D0 .OR.
+     * M.NE.2)) GO TO 100
+      MR = -MM
+      IF (ZNR.NE.0.0D0 .OR. ZNI.GE.0.0D0) GO TO 100
+      ZNR = -ZNR
+      ZNI = -ZNI
+  100 CONTINUE
+      CALL ZBUNK(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM,
+     * ALIM)
+      IF (NW.LT.0) GO TO 240
+      NZ = NZ + NW
+  110 CONTINUE
+C-----------------------------------------------------------------------
+C     H(M,FNU,Z) = -FMM*(I/HPI)*(ZT**FNU)*K(FNU,-Z*ZT)
+C
+C     ZT=EXP(-FMM*HPI*I) = CMPLX(0.0,-FMM), FMM=3-2*M, M=1,2
+C-----------------------------------------------------------------------
+      SGN = DSIGN(HPI,-FMM)
+C-----------------------------------------------------------------------
+C     CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
+C     WHEN FNU IS LARGE
+C-----------------------------------------------------------------------
+      INU = INT(SNGL(FNU))
+      INUH = INU/2
+      IR = INU - 2*INUH
+      ARG = (FNU-DBLE(FLOAT(INU-IR)))*SGN
+      RHPI = 1.0D0/SGN
+C     ZNI = RHPI*DCOS(ARG)
+C     ZNR = -RHPI*DSIN(ARG)
+      CSGNI = RHPI*DCOS(ARG)
+      CSGNR = -RHPI*DSIN(ARG)
+      IF (MOD(INUH,2).EQ.0) GO TO 120
+C     ZNR = -ZNR
+C     ZNI = -ZNI
+      CSGNR = -CSGNR
+      CSGNI = -CSGNI
+  120 CONTINUE
+      ZTI = -FMM
+      RTOL = 1.0D0/TOL
+      ASCLE = UFL*RTOL
+      DO 130 I=1,NN
+C       STR = CYR(I)*ZNR - CYI(I)*ZNI
+C       CYI(I) = CYR(I)*ZNI + CYI(I)*ZNR
+C       CYR(I) = STR
+C       STR = -ZNI*ZTI
+C       ZNI = ZNR*ZTI
+C       ZNR = STR
+        AA = CYR(I)
+        BB = CYI(I)
+        ATOL = 1.0D0
+        IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 135
+          AA = AA*RTOL
+          BB = BB*RTOL
+          ATOL = TOL
+  135 CONTINUE
+      STR = AA*CSGNR - BB*CSGNI
+      STI = AA*CSGNI + BB*CSGNR
+      CYR(I) = STR*ATOL
+      CYI(I) = STI*ATOL
+      STR = -CSGNI*ZTI
+      CSGNI = CSGNR*ZTI
+      CSGNR = STR
+  130 CONTINUE
+      RETURN
+  140 CONTINUE
+      IF (ZNR.LT.0.0D0) GO TO 230
+      RETURN
+  230 CONTINUE
+      NZ=0
+      IERR=2
+      RETURN
+  240 CONTINUE
+      IF(NW.EQ.(-1)) GO TO 230
+      NZ=0
+      IERR=5
+      RETURN
+  260 CONTINUE
+      NZ=0
+      IERR=4
+      RETURN
+      END

amos/zbesi.f

@@ -0,0 +1,269 @@
+      SUBROUTINE ZBESI(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR)
+C***BEGIN PROLOGUE  ZBESI
+C***DATE WRITTEN   830501   (YYMMDD)
+C***REVISION DATE  890801   (YYMMDD)
+C***CATEGORY NO.  B5K
+C***KEYWORDS  I-BESSEL FUNCTION,COMPLEX BESSEL FUNCTION,
+C             MODIFIED BESSEL FUNCTION OF THE FIRST KIND
+C***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
+C***PURPOSE  TO COMPUTE I-BESSEL FUNCTIONS OF COMPLEX ARGUMENT
+C***DESCRIPTION
+C
+C                    ***A DOUBLE PRECISION ROUTINE***
+C         ON KODE=1, ZBESI COMPUTES AN N MEMBER SEQUENCE OF COMPLEX
+C         BESSEL FUNCTIONS CY(J)=I(FNU+J-1,Z) FOR REAL, NONNEGATIVE
+C         ORDERS FNU+J-1, J=1,...,N AND COMPLEX Z IN THE CUT PLANE
+C         -PI.LT.ARG(Z).LE.PI. ON KODE=2, ZBESI RETURNS THE SCALED
+C         FUNCTIONS
+C
+C         CY(J)=EXP(-ABS(X))*I(FNU+J-1,Z)   J = 1,...,N , X=REAL(Z)
+C
+C         WITH THE EXPONENTIAL GROWTH REMOVED IN BOTH THE LEFT AND
+C         RIGHT HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION
+C         ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS
+C         (REF. 1).
+C
+C         INPUT      ZR,ZI,FNU ARE DOUBLE PRECISION
+C           ZR,ZI  - Z=CMPLX(ZR,ZI),  -PI.LT.ARG(Z).LE.PI
+C           FNU    - ORDER OF INITIAL I FUNCTION, FNU.GE.0.0D0
+C           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION
+C                    KODE= 1  RETURNS
+C                             CY(J)=I(FNU+J-1,Z), J=1,...,N
+C                        = 2  RETURNS
+C                             CY(J)=I(FNU+J-1,Z)*EXP(-ABS(X)), J=1,...,N
+C           N      - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1
+C
+C         OUTPUT     CYR,CYI ARE DOUBLE PRECISION
+C           CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS
+C                    CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE
+C                    CY(J)=I(FNU+J-1,Z)  OR
+C                    CY(J)=I(FNU+J-1,Z)*EXP(-ABS(X))  J=1,...,N
+C                    DEPENDING ON KODE, X=REAL(Z)
+C           NZ     - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW,
+C                    NZ= 0   , NORMAL RETURN
+C                    NZ.GT.0 , LAST NZ COMPONENTS OF CY SET TO ZERO
+C                              TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0)
+C                              J = N-NZ+1,...,N
+C           IERR   - ERROR FLAG
+C                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
+C                    IERR=1, INPUT ERROR   - NO COMPUTATION
+C                    IERR=2, OVERFLOW      - NO COMPUTATION, REAL(Z) TOO
+C                            LARGE ON KODE=1
+C                    IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
+C                            BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
+C                            REDUCTION PRODUCE LESS THAN HALF OF MACHINE
+C                            ACCURACY
+C                    IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
+C                            TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
+C                            CANCE BY ARGUMENT REDUCTION
+C                    IERR=5, ERROR              - NO COMPUTATION,
+C                            ALGORITHM TERMINATION CONDITION NOT MET
+C
+C***LONG DESCRIPTION
+C
+C         THE COMPUTATION IS CARRIED OUT BY THE POWER SERIES FOR
+C         SMALL CABS(Z), THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z),
+C         THE MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN AND A
+C         NEUMANN SERIES FOR IMTERMEDIATE MAGNITUDES, AND THE
+C         UNIFORM ASYMPTOTIC EXPANSIONS FOR I(FNU,Z) AND J(FNU,Z)
+C         FOR LARGE ORDERS. BACKWARD RECURRENCE IS USED TO GENERATE
+C         SEQUENCES OR REDUCE ORDERS WHEN NECESSARY.
+C
+C         THE CALCULATIONS ABOVE ARE DONE IN THE RIGHT HALF PLANE AND
+C         CONTINUED INTO THE LEFT HALF PLANE BY THE FORMULA
+C
+C         I(FNU,Z*EXP(M*PI)) = EXP(M*PI*FNU)*I(FNU,Z)  REAL(Z).GT.0.0
+C                       M = +I OR -I,  I**2=-1
+C
+C         FOR NEGATIVE ORDERS,THE FORMULA
+C
+C              I(-FNU,Z) = I(FNU,Z) + (2/PI)*SIN(PI*FNU)*K(FNU,Z)
+C
+C         CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO INTEGERS, THE
+C         THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE POSITIVE
+C         INTEGER,THE MAGNITUDE OF I(-FNU,Z)=I(FNU,Z) IS A LARGE
+C         NEGATIVE POWER OF TEN. BUT WHEN FNU IS NOT AN INTEGER,
+C         K(FNU,Z) DOMINATES IN MAGNITUDE WITH A LARGE POSITIVE POWER OF
+C         TEN AND THE MOST THAT THE SECOND TERM CAN BE REDUCED IS BY
+C         UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, WIDE CHANGES CAN
+C         OCCUR WITHIN UNIT ROUNDOFF OF A LARGE INTEGER FOR FNU. HERE,
+C         LARGE MEANS FNU.GT.CABS(Z).
+C
+C         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
+C         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS
+C         LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.
+C         CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN
+C         LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG
+C         IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
+C         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
+C         IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS
+C         LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS
+C         MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE
+C         INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS
+C         RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
+C         ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
+C         ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
+C         ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
+C         THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
+C         TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
+C         IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
+C         SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
+C
+C         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
+C         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
+C         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
+C         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
+C         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
+C         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
+C         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
+C         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
+C         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
+C         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
+C         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
+C         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
+C         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
+C         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
+C         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
+C         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
+C         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
+C         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
+C         OR -PI/2+P.
+C
+C***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
+C                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
+C                 COMMERCE, 1955.
+C
+C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
+C                 BY D. E. AMOS, SAND83-0083, MAY, 1983.
+C
+C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
+C                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
+C
+C               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
+C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
+C                 1018, MAY, 1985
+C
+C               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
+C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
+C                 MATH. SOFTWARE, 1986
+C
+C***ROUTINES CALLED  ZBINU,I1MACH,D1MACH
+C***END PROLOGUE  ZBESI
+C     COMPLEX CONE,CSGN,CW,CY,CZERO,Z,ZN
+      DOUBLE PRECISION AA, ALIM, ARG, CONEI, CONER, CSGNI, CSGNR, CYI,
+     * CYR, DIG, ELIM, FNU, FNUL, PI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR,
+     * ZR, D1MACH, AZ, BB, FN, ZABS, ASCLE, RTOL, ATOL, STI
+      INTEGER I, IERR, INU, K, KODE, K1,K2,N,NZ,NN, I1MACH
+      DIMENSION CYR(N), CYI(N)
+      DATA PI /3.14159265358979324D0/
+      DATA CONER, CONEI /1.0D0,0.0D0/
+C
+C***FIRST EXECUTABLE STATEMENT  ZBESI
+      IERR = 0
+      NZ=0
+      IF (FNU.LT.0.0D0) IERR=1
+      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
+      IF (N.LT.1) IERR=1
+      IF (IERR.NE.0) RETURN
+C-----------------------------------------------------------------------
+C     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
+C     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
+C     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
+C     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND
+C     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
+C     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
+C     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
+C     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
+C     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU.
+C-----------------------------------------------------------------------
+      TOL = DMAX1(D1MACH(4),1.0D-18)
+      K1 = I1MACH(15)
+      K2 = I1MACH(16)
+      R1M5 = D1MACH(5)
+      K = MIN0(IABS(K1),IABS(K2))
+      ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
+      K1 = I1MACH(14) - 1
+      AA = R1M5*DBLE(FLOAT(K1))
+      DIG = DMIN1(AA,18.0D0)
+      AA = AA*2.303D0
+      ALIM = ELIM + DMAX1(-AA,-41.45D0)
+      RL = 1.2D0*DIG + 3.0D0
+      FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
+C-----------------------------------------------------------------------------
+C     TEST FOR PROPER RANGE
+C-----------------------------------------------------------------------
+      AZ = ZABS(COMPLEX(ZR,ZI))
+      FN = FNU+DBLE(FLOAT(N-1))
+      AA = 0.5D0/TOL
+      BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
+      AA = DMIN1(AA,BB)
+      IF (AZ.GT.AA) GO TO 260
+      IF (FN.GT.AA) GO TO 260
+      AA = DSQRT(AA)
+      IF (AZ.GT.AA) IERR=3
+      IF (FN.GT.AA) IERR=3
+      ZNR = ZR
+      ZNI = ZI
+      CSGNR = CONER
+      CSGNI = CONEI
+      IF (ZR.GE.0.0D0) GO TO 40
+      ZNR = -ZR
+      ZNI = -ZI
+C-----------------------------------------------------------------------
+C     CALCULATE CSGN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
+C     WHEN FNU IS LARGE
+C-----------------------------------------------------------------------
+      INU = INT(SNGL(FNU))
+      ARG = (FNU-DBLE(FLOAT(INU)))*PI
+      IF (ZI.LT.0.0D0) ARG = -ARG
+      CSGNR = DCOS(ARG)
+      CSGNI = DSIN(ARG)
+      IF (MOD(INU,2).EQ.0) GO TO 40
+      CSGNR = -CSGNR
+      CSGNI = -CSGNI
+   40 CONTINUE
+      CALL ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL,
+     * ELIM, ALIM)
+      IF (NZ.LT.0) GO TO 120
+      IF (ZR.GE.0.0D0) RETURN
+C-----------------------------------------------------------------------
+C     ANALYTIC CONTINUATION TO THE LEFT HALF PLANE
+C-----------------------------------------------------------------------
+      NN = N - NZ
+      IF (NN.EQ.0) RETURN
+      RTOL = 1.0D0/TOL
+      ASCLE = D1MACH(1)*RTOL*1.0D+3
+      DO 50 I=1,NN
+C       STR = CYR(I)*CSGNR - CYI(I)*CSGNI
+C       CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR
+C       CYR(I) = STR
+        AA = CYR(I)
+        BB = CYI(I)
+        ATOL = 1.0D0
+        IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 55
+          AA = AA*RTOL
+          BB = BB*RTOL
+          ATOL = TOL
+   55   CONTINUE
+        STR = AA*CSGNR - BB*CSGNI
+        STI = AA*CSGNI + BB*CSGNR
+        CYR(I) = STR*ATOL
+        CYI(I) = STI*ATOL
+        CSGNR = -CSGNR
+        CSGNI = -CSGNI
+   50 CONTINUE
+      RETURN
+  120 CONTINUE
+      IF(NZ.EQ.(-2)) GO TO 130
+      NZ = 0
+      IERR=2
+      RETURN
+  130 CONTINUE
+      NZ=0
+      IERR=5
+      RETURN
+  260 CONTINUE
+      NZ=0
+      IERR=4
+      RETURN
+      END

amos/zbesj.f

@@ -0,0 +1,266 @@
+      SUBROUTINE ZBESJ(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR)
+C***BEGIN PROLOGUE  ZBESJ
+C***DATE WRITTEN   830501   (YYMMDD)
+C***REVISION DATE  890801   (YYMMDD)
+C***CATEGORY NO.  B5K
+C***KEYWORDS  J-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT,
+C             BESSEL FUNCTION OF FIRST KIND
+C***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
+C***PURPOSE  TO COMPUTE THE J-BESSEL FUNCTION OF A COMPLEX ARGUMENT
+C***DESCRIPTION
+C
+C                      ***A DOUBLE PRECISION ROUTINE***
+C         ON KODE=1, CBESJ COMPUTES AN N MEMBER  SEQUENCE OF COMPLEX
+C         BESSEL FUNCTIONS CY(I)=J(FNU+I-1,Z) FOR REAL, NONNEGATIVE
+C         ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE
+C         -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESJ RETURNS THE SCALED
+C         FUNCTIONS
+C
+C         CY(I)=EXP(-ABS(Y))*J(FNU+I-1,Z)   I = 1,...,N , Y=AIMAG(Z)
+C
+C         WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND
+C         LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION
+C         ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS
+C         (REF. 1).
+C
+C         INPUT      ZR,ZI,FNU ARE DOUBLE PRECISION
+C           ZR,ZI  - Z=CMPLX(ZR,ZI),  -PI.LT.ARG(Z).LE.PI
+C           FNU    - ORDER OF INITIAL J FUNCTION, FNU.GE.0.0D0
+C           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION
+C                    KODE= 1  RETURNS
+C                             CY(I)=J(FNU+I-1,Z), I=1,...,N
+C                        = 2  RETURNS
+C                             CY(I)=J(FNU+I-1,Z)EXP(-ABS(Y)), I=1,...,N
+C           N      - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1
+C
+C         OUTPUT     CYR,CYI ARE DOUBLE PRECISION
+C           CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS
+C                    CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE
+C                    CY(I)=J(FNU+I-1,Z)  OR
+C                    CY(I)=J(FNU+I-1,Z)EXP(-ABS(Y))  I=1,...,N
+C                    DEPENDING ON KODE, Y=AIMAG(Z).
+C           NZ     - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW,
+C                    NZ= 0   , NORMAL RETURN
+C                    NZ.GT.0 , LAST NZ COMPONENTS OF CY SET  ZERO DUE
+C                              TO UNDERFLOW, CY(I)=CMPLX(0.0D0,0.0D0),
+C                              I = N-NZ+1,...,N
+C           IERR   - ERROR FLAG
+C                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
+C                    IERR=1, INPUT ERROR   - NO COMPUTATION
+C                    IERR=2, OVERFLOW      - NO COMPUTATION, AIMAG(Z)
+C                            TOO LARGE ON KODE=1
+C                    IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
+C                            BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
+C                            REDUCTION PRODUCE LESS THAN HALF OF MACHINE
+C                            ACCURACY
+C                    IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
+C                            TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
+C                            CANCE BY ARGUMENT REDUCTION
+C                    IERR=5, ERROR              - NO COMPUTATION,
+C                            ALGORITHM TERMINATION CONDITION NOT MET
+C
+C***LONG DESCRIPTION
+C
+C         THE COMPUTATION IS CARRIED OUT BY THE FORMULA
+C
+C         J(FNU,Z)=EXP( FNU*PI*I/2)*I(FNU,-I*Z)    AIMAG(Z).GE.0.0
+C
+C         J(FNU,Z)=EXP(-FNU*PI*I/2)*I(FNU, I*Z)    AIMAG(Z).LT.0.0
+C
+C         WHERE I**2 = -1 AND I(FNU,Z) IS THE I BESSEL FUNCTION.
+C
+C         FOR NEGATIVE ORDERS,THE FORMULA
+C
+C              J(-FNU,Z) = J(FNU,Z)*COS(PI*FNU) - Y(FNU,Z)*SIN(PI*FNU)
+C
+C         CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO INTEGERS, THE
+C         THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE POSITIVE
+C         INTEGER,THE MAGNITUDE OF J(-FNU,Z)=J(FNU,Z)*COS(PI*FNU) IS A
+C         LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS NOT AN INTEGER,
+C         Y(FNU,Z) DOMINATES IN MAGNITUDE WITH A LARGE POSITIVE POWER OF
+C         TEN AND THE MOST THAT THE SECOND TERM CAN BE REDUCED IS BY
+C         UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, WIDE CHANGES CAN
+C         OCCUR WITHIN UNIT ROUNDOFF OF A LARGE INTEGER FOR FNU. HERE,
+C         LARGE MEANS FNU.GT.CABS(Z).
+C
+C         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
+C         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS
+C         LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.
+C         CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN
+C         LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG
+C         IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
+C         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
+C         IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS
+C         LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS
+C         MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE
+C         INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS
+C         RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
+C         ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
+C         ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
+C         ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
+C         THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
+C         TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
+C         IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
+C         SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
+C
+C         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
+C         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
+C         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
+C         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
+C         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
+C         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
+C         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
+C         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
+C         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
+C         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
+C         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
+C         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
+C         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
+C         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
+C         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
+C         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
+C         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
+C         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
+C         OR -PI/2+P.
+C
+C***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
+C                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
+C                 COMMERCE, 1955.
+C
+C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
+C                 BY D. E. AMOS, SAND83-0083, MAY, 1983.
+C
+C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
+C                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
+C
+C               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
+C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
+C                 1018, MAY, 1985
+C
+C               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
+C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
+C                 MATH. SOFTWARE, 1986
+C
+C***ROUTINES CALLED  ZBINU,I1MACH,D1MACH
+C***END PROLOGUE  ZBESJ
+C
+C     COMPLEX CI,CSGN,CY,Z,ZN
+      DOUBLE PRECISION AA, ALIM, ARG, CII, CSGNI, CSGNR, CYI, CYR, DIG,
+     * ELIM, FNU, FNUL, HPI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR, ZR,
+     * D1MACH, BB, FN, AZ, ZABS, ASCLE, RTOL, ATOL, STI
+      INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, N, NL, NZ, I1MACH
+      DIMENSION CYR(N), CYI(N)
+      DATA HPI /1.57079632679489662D0/
+C
+C***FIRST EXECUTABLE STATEMENT  ZBESJ
+      IERR = 0
+      NZ=0
+      IF (FNU.LT.0.0D0) IERR=1
+      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
+      IF (N.LT.1) IERR=1
+      IF (IERR.NE.0) RETURN
+C-----------------------------------------------------------------------
+C     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
+C     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
+C     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
+C     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND
+C     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
+C     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
+C     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
+C     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
+C     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU.
+C-----------------------------------------------------------------------
+      TOL = DMAX1(D1MACH(4),1.0D-18)
+      K1 = I1MACH(15)
+      K2 = I1MACH(16)
+      R1M5 = D1MACH(5)
+      K = MIN0(IABS(K1),IABS(K2))
+      ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
+      K1 = I1MACH(14) - 1
+      AA = R1M5*DBLE(FLOAT(K1))
+      DIG = DMIN1(AA,18.0D0)
+      AA = AA*2.303D0
+      ALIM = ELIM + DMAX1(-AA,-41.45D0)
+      RL = 1.2D0*DIG + 3.0D0
+      FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
+C-----------------------------------------------------------------------
+C     TEST FOR PROPER RANGE
+C-----------------------------------------------------------------------
+      AZ = ZABS(COMPLEX(ZR,ZI))
+      FN = FNU+DBLE(FLOAT(N-1))
+      AA = 0.5D0/TOL
+      BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
+      AA = DMIN1(AA,BB)
+      IF (AZ.GT.AA) GO TO 260
+      IF (FN.GT.AA) GO TO 260
+      AA = DSQRT(AA)
+      IF (AZ.GT.AA) IERR=3
+      IF (FN.GT.AA) IERR=3
+C-----------------------------------------------------------------------
+C     CALCULATE CSGN=EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
+C     WHEN FNU IS LARGE
+C-----------------------------------------------------------------------
+      CII = 1.0D0
+      INU = INT(SNGL(FNU))
+      INUH = INU/2
+      IR = INU - 2*INUH
+      ARG = (FNU-DBLE(FLOAT(INU-IR)))*HPI
+      CSGNR = DCOS(ARG)
+      CSGNI = DSIN(ARG)
+      IF (MOD(INUH,2).EQ.0) GO TO 40
+      CSGNR = -CSGNR
+      CSGNI = -CSGNI
+   40 CONTINUE
+C-----------------------------------------------------------------------
+C     ZN IS IN THE RIGHT HALF PLANE
+C-----------------------------------------------------------------------
+      ZNR = ZI
+      ZNI = -ZR
+      IF (ZI.GE.0.0D0) GO TO 50
+      ZNR = -ZNR
+      ZNI = -ZNI
+      CSGNI = -CSGNI
+      CII = -CII
+   50 CONTINUE
+      CALL ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL,
+     * ELIM, ALIM)
+      IF (NZ.LT.0) GO TO 130
+      NL = N - NZ
+      IF (NL.EQ.0) RETURN
+      RTOL = 1.0D0/TOL
+      ASCLE = D1MACH(1)*RTOL*1.0D+3
+      DO 60 I=1,NL
+C       STR = CYR(I)*CSGNR - CYI(I)*CSGNI
+C       CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR
+C       CYR(I) = STR
+        AA = CYR(I)
+        BB = CYI(I)
+        ATOL = 1.0D0
+        IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 55
+          AA = AA*RTOL
+          BB = BB*RTOL
+          ATOL = TOL
+   55   CONTINUE
+        STR = AA*CSGNR - BB*CSGNI
+        STI = AA*CSGNI + BB*CSGNR
+        CYR(I) = STR*ATOL
+        CYI(I) = STI*ATOL
+        STR = -CSGNI*CII
+        CSGNI = CSGNR*CII
+        CSGNR = STR
+   60 CONTINUE
+      RETURN
+  130 CONTINUE
+      IF(NZ.EQ.(-2)) GO TO 140
+      NZ = 0
+      IERR = 2
+      RETURN
+  140 CONTINUE
+      NZ=0
+      IERR=5
+      RETURN
+  260 CONTINUE
+      NZ=0
+      IERR=4
+      RETURN
+      END

amos/zbesk.f

@@ -0,0 +1,281 @@
+      SUBROUTINE ZBESK(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR)
+C***BEGIN PROLOGUE  ZBESK
+C***DATE WRITTEN   830501   (YYMMDD)
+C***REVISION DATE  890801   (YYMMDD)
+C***CATEGORY NO.  B5K
+C***KEYWORDS  K-BESSEL FUNCTION,COMPLEX BESSEL FUNCTION,
+C             MODIFIED BESSEL FUNCTION OF THE SECOND KIND,
+C             BESSEL FUNCTION OF THE THIRD KIND
+C***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
+C***PURPOSE  TO COMPUTE K-BESSEL FUNCTIONS OF COMPLEX ARGUMENT
+C***DESCRIPTION
+C
+C                      ***A DOUBLE PRECISION ROUTINE***
+C
+C         ON KODE=1, CBESK COMPUTES AN N MEMBER SEQUENCE OF COMPLEX
+C         BESSEL FUNCTIONS CY(J)=K(FNU+J-1,Z) FOR REAL, NONNEGATIVE
+C         ORDERS FNU+J-1, J=1,...,N AND COMPLEX Z.NE.CMPLX(0.0,0.0)
+C         IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESK
+C         RETURNS THE SCALED K FUNCTIONS,
+C
+C         CY(J)=EXP(Z)*K(FNU+J-1,Z) , J=1,...,N,
+C
+C         WHICH REMOVE THE EXPONENTIAL BEHAVIOR IN BOTH THE LEFT AND
+C         RIGHT HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND
+C         NOTATION ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL
+C         FUNCTIONS (REF. 1).
+C
+C         INPUT      ZR,ZI,FNU ARE DOUBLE PRECISION
+C           ZR,ZI  - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0),
+C                    -PI.LT.ARG(Z).LE.PI
+C           FNU    - ORDER OF INITIAL K FUNCTION, FNU.GE.0.0D0
+C           N      - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1
+C           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION
+C                    KODE= 1  RETURNS
+C                             CY(I)=K(FNU+I-1,Z), I=1,...,N
+C                        = 2  RETURNS
+C                             CY(I)=K(FNU+I-1,Z)*EXP(Z), I=1,...,N
+C
+C         OUTPUT     CYR,CYI ARE DOUBLE PRECISION
+C           CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS
+C                    CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE
+C                    CY(I)=K(FNU+I-1,Z), I=1,...,N OR
+C                    CY(I)=K(FNU+I-1,Z)*EXP(Z), I=1,...,N
+C                    DEPENDING ON KODE
+C           NZ     - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW.
+C                    NZ= 0   , NORMAL RETURN
+C                    NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO DUE
+C                              TO UNDERFLOW, CY(I)=CMPLX(0.0D0,0.0D0),
+C                              I=1,...,N WHEN X.GE.0.0. WHEN X.LT.0.0
+C                              NZ STATES ONLY THE NUMBER OF UNDERFLOWS
+C                              IN THE SEQUENCE.
+C
+C           IERR   - ERROR FLAG
+C                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
+C                    IERR=1, INPUT ERROR   - NO COMPUTATION
+C                    IERR=2, OVERFLOW      - NO COMPUTATION, FNU IS
+C                            TOO LARGE OR CABS(Z) IS TOO SMALL OR BOTH
+C                    IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
+C                            BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
+C                            REDUCTION PRODUCE LESS THAN HALF OF MACHINE
+C                            ACCURACY
+C                    IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
+C                            TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
+C                            CANCE BY ARGUMENT REDUCTION
+C                    IERR=5, ERROR              - NO COMPUTATION,
+C                            ALGORITHM TERMINATION CONDITION NOT MET
+C
+C***LONG DESCRIPTION
+C
+C         EQUATIONS OF THE REFERENCE ARE IMPLEMENTED FOR SMALL ORDERS
+C         DNU AND DNU+1.0 IN THE RIGHT HALF PLANE X.GE.0.0. FORWARD
+C         RECURRENCE GENERATES HIGHER ORDERS. K IS CONTINUED TO THE LEFT
+C         HALF PLANE BY THE RELATION
+C
+C         K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z)
+C         MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1
+C
+C         WHERE I(FNU,Z) IS THE I BESSEL FUNCTION.
+C
+C         FOR LARGE ORDERS, FNU.GT.FNUL, THE K FUNCTION IS COMPUTED
+C         BY MEANS OF ITS UNIFORM ASYMPTOTIC EXPANSIONS.
+C
+C         FOR NEGATIVE ORDERS, THE FORMULA
+C
+C                       K(-FNU,Z) = K(FNU,Z)
+C
+C         CAN BE USED.
+C
+C         CBESK ASSUMES THAT A SIGNIFICANT DIGIT SINH(X) FUNCTION IS
+C         AVAILABLE.
+C
+C         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
+C         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS
+C         LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.
+C         CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN
+C         LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG
+C         IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
+C         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
+C         IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS
+C         LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS
+C         MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE
+C         INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS
+C         RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
+C         ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
+C         ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
+C         ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
+C         THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
+C         TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
+C         IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
+C         SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
+C
+C         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
+C         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
+C         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
+C         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
+C         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
+C         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
+C         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
+C         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
+C         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
+C         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
+C         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
+C         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
+C         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
+C         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
+C         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
+C         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
+C         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
+C         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
+C         OR -PI/2+P.
+C
+C***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
+C                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
+C                 COMMERCE, 1955.
+C
+C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
+C                 BY D. E. AMOS, SAND83-0083, MAY, 1983.
+C
+C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
+C                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983.
+C
+C               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
+C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
+C                 1018, MAY, 1985
+C
+C               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
+C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
+C                 MATH. SOFTWARE, 1986
+C
+C***ROUTINES CALLED  ZACON,ZBKNU,ZBUNK,ZUOIK,ZABS,I1MACH,D1MACH
+C***END PROLOGUE  ZBESK
+C
+C     COMPLEX CY,Z
+      DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM, FN,
+     * FNU, FNUL, RL, R1M5, TOL, UFL, ZI, ZR, D1MACH, ZABS, BB
+      INTEGER IERR, K, KODE, K1, K2, MR, N, NN, NUF, NW, NZ, I1MACH
+      DIMENSION CYR(N), CYI(N)
+C***FIRST EXECUTABLE STATEMENT  ZBESK
+      IERR = 0
+      NZ=0
+      IF (ZI.EQ.0.0E0 .AND. ZR.EQ.0.0E0) IERR=1
+      IF (FNU.LT.0.0D0) IERR=1
+      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
+      IF (N.LT.1) IERR=1
+      IF (IERR.NE.0) RETURN
+      NN = N
+C-----------------------------------------------------------------------
+C     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
+C     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
+C     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
+C     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND
+C     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
+C     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
+C     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
+C     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
+C     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU
+C-----------------------------------------------------------------------
+      TOL = DMAX1(D1MACH(4),1.0D-18)
+      K1 = I1MACH(15)
+      K2 = I1MACH(16)
+      R1M5 = D1MACH(5)
+      K = MIN0(IABS(K1),IABS(K2))
+      ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
+      K1 = I1MACH(14) - 1
+      AA = R1M5*DBLE(FLOAT(K1))
+      DIG = DMIN1(AA,18.0D0)
+      AA = AA*2.303D0
+      ALIM = ELIM + DMAX1(-AA,-41.45D0)
+      FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
+      RL = 1.2D0*DIG + 3.0D0
+C-----------------------------------------------------------------------------
+C     TEST FOR PROPER RANGE
+C-----------------------------------------------------------------------
+      AZ = ZABS(COMPLEX(ZR,ZI))
+      FN = FNU + DBLE(FLOAT(NN-1))
+      AA = 0.5D0/TOL
+      BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
+      AA = DMIN1(AA,BB)
+      IF (AZ.GT.AA) GO TO 260
+      IF (FN.GT.AA) GO TO 260
+      AA = DSQRT(AA)
+      IF (AZ.GT.AA) IERR=3
+      IF (FN.GT.AA) IERR=3
+C-----------------------------------------------------------------------
+C     OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE
+C-----------------------------------------------------------------------
+C     UFL = DEXP(-ELIM)
+      UFL = D1MACH(1)*1.0D+3
+      IF (AZ.LT.UFL) GO TO 180
+      IF (FNU.GT.FNUL) GO TO 80
+      IF (FN.LE.1.0D0) GO TO 60
+      IF (FN.GT.2.0D0) GO TO 50
+      IF (AZ.GT.TOL) GO TO 60
+      ARG = 0.5D0*AZ
+      ALN = -FN*DLOG(ARG)
+      IF (ALN.GT.ELIM) GO TO 180
+      GO TO 60
+   50 CONTINUE
+      CALL ZUOIK(ZR, ZI, FNU, KODE, 2, NN, CYR, CYI, NUF, TOL, ELIM,
+     * ALIM)
+      IF (NUF.LT.0) GO TO 180
+      NZ = NZ + NUF
+      NN = NN - NUF
+C-----------------------------------------------------------------------
+C     HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK
+C     IF NUF=NN, THEN CY(I)=CZERO FOR ALL I
+C-----------------------------------------------------------------------
+      IF (NN.EQ.0) GO TO 100
+   60 CONTINUE
+      IF (ZR.LT.0.0D0) GO TO 70
+C-----------------------------------------------------------------------
+C     RIGHT HALF PLANE COMPUTATION, REAL(Z).GE.0.
+C-----------------------------------------------------------------------
+      CALL ZBKNU(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM)
+      IF (NW.LT.0) GO TO 200
+      NZ=NW
+      RETURN
+C-----------------------------------------------------------------------
+C     LEFT HALF PLANE COMPUTATION
+C     PI/2.LT.ARG(Z).LE.PI AND -PI.LT.ARG(Z).LT.-PI/2.
+C-----------------------------------------------------------------------
+   70 CONTINUE
+      IF (NZ.NE.0) GO TO 180
+      MR = 1
+      IF (ZI.LT.0.0D0) MR = -1
+      CALL ZACON(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL,
+     * TOL, ELIM, ALIM)
+      IF (NW.LT.0) GO TO 200
+      NZ=NW
+      RETURN
+C-----------------------------------------------------------------------
+C     UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL
+C-----------------------------------------------------------------------
+   80 CONTINUE
+      MR = 0
+      IF (ZR.GE.0.0D0) GO TO 90
+      MR = 1
+      IF (ZI.LT.0.0D0) MR = -1
+   90 CONTINUE
+      CALL ZBUNK(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM,
+     * ALIM)
+      IF (NW.LT.0) GO TO 200
+      NZ = NZ + NW
+      RETURN
+  100 CONTINUE
+      IF (ZR.LT.0.0D0) GO TO 180
+      RETURN
+  180 CONTINUE
+      NZ = 0
+      IERR=2
+      RETURN
+  200 CONTINUE
+      IF(NW.EQ.(-1)) GO TO 180
+      NZ=0
+      IERR=5
+      RETURN
+  260 CONTINUE
+      NZ=0
+      IERR=4
+      RETURN
+      END

amos/zbesy.f

@@ -0,0 +1,244 @@
+      SUBROUTINE ZBESY(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, CWRKR, CWRKI,
+     *                 IERR)
+C***BEGIN PROLOGUE  ZBESY
+C***DATE WRITTEN   830501   (YYMMDD)
+C***REVISION DATE  890801   (YYMMDD)
+C***CATEGORY NO.  B5K
+C***KEYWORDS  Y-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT,
+C             BESSEL FUNCTION OF SECOND KIND
+C***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
+C***PURPOSE  TO COMPUTE THE Y-BESSEL FUNCTION OF A COMPLEX ARGUMENT
+C***DESCRIPTION
+C
+C                      ***A DOUBLE PRECISION ROUTINE***
+C
+C         ON KODE=1, CBESY COMPUTES AN N MEMBER SEQUENCE OF COMPLEX
+C         BESSEL FUNCTIONS CY(I)=Y(FNU+I-1,Z) FOR REAL, NONNEGATIVE
+C         ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE
+C         -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESY RETURNS THE SCALED
+C         FUNCTIONS
+C
+C         CY(I)=EXP(-ABS(Y))*Y(FNU+I-1,Z)   I = 1,...,N , Y=AIMAG(Z)
+C
+C         WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND
+C         LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION
+C         ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS
+C         (REF. 1).
+C
+C         INPUT      ZR,ZI,FNU ARE DOUBLE PRECISION
+C           ZR,ZI  - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0),
+C                    -PI.LT.ARG(Z).LE.PI
+C           FNU    - ORDER OF INITIAL Y FUNCTION, FNU.GE.0.0D0
+C           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION
+C                    KODE= 1  RETURNS
+C                             CY(I)=Y(FNU+I-1,Z), I=1,...,N
+C                        = 2  RETURNS
+C                             CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y)), I=1,...,N
+C                             WHERE Y=AIMAG(Z)
+C           N      - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1
+C           CWRKR, - DOUBLE PRECISION WORK VECTORS OF DIMENSION AT
+C           CWRKI    AT LEAST N
+C
+C         OUTPUT     CYR,CYI ARE DOUBLE PRECISION
+C           CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS
+C                    CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE
+C                    CY(I)=Y(FNU+I-1,Z)  OR
+C                    CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y))  I=1,...,N
+C                    DEPENDING ON KODE.
+C           NZ     - NZ=0 , A NORMAL RETURN
+C                    NZ.GT.0 , NZ COMPONENTS OF CY SET TO ZERO DUE TO
+C                    UNDERFLOW (GENERALLY ON KODE=2)
+C           IERR   - ERROR FLAG
+C                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
+C                    IERR=1, INPUT ERROR   - NO COMPUTATION
+C                    IERR=2, OVERFLOW      - NO COMPUTATION, FNU IS
+C                            TOO LARGE OR CABS(Z) IS TOO SMALL OR BOTH
+C                    IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
+C                            BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
+C                            REDUCTION PRODUCE LESS THAN HALF OF MACHINE
+C                            ACCURACY
+C                    IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
+C                            TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
+C                            CANCE BY ARGUMENT REDUCTION
+C                    IERR=5, ERROR              - NO COMPUTATION,
+C                            ALGORITHM TERMINATION CONDITION NOT MET
+C
+C***LONG DESCRIPTION
+C
+C         THE COMPUTATION IS CARRIED OUT BY THE FORMULA
+C
+C         Y(FNU,Z)=0.5*(H(1,FNU,Z)-H(2,FNU,Z))/I
+C
+C         WHERE I**2 = -1 AND THE HANKEL BESSEL FUNCTIONS H(1,FNU,Z)
+C         AND H(2,FNU,Z) ARE CALCULATED IN CBESH.
+C
+C         FOR NEGATIVE ORDERS,THE FORMULA
+C
+C              Y(-FNU,Z) = Y(FNU,Z)*COS(PI*FNU) + J(FNU,Z)*SIN(PI*FNU)
+C
+C         CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO HALF ODD
+C         INTEGERS THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE
+C         POSITIVE HALF ODD INTEGER,THE MAGNITUDE OF Y(-FNU,Z)=J(FNU,Z)*
+C         SIN(PI*FNU) IS A LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS
+C         NOT A HALF ODD INTEGER, Y(FNU,Z) DOMINATES IN MAGNITUDE WITH A
+C         LARGE POSITIVE POWER OF TEN AND THE MOST THAT THE SECOND TERM
+C         CAN BE REDUCED IS BY UNIT ROUNDOFF FROM THE COEFFICIENT. THUS,
+C         WIDE CHANGES CAN OCCUR WITHIN UNIT ROUNDOFF OF A LARGE HALF
+C         ODD INTEGER. HERE, LARGE MEANS FNU.GT.CABS(Z).
+C
+C         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
+C         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS
+C         LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.
+C         CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN
+C         LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG
+C         IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
+C         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
+C         IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS
+C         LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS
+C         MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE
+C         INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS
+C         RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
+C         ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
+C         ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
+C         ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
+C         THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
+C         TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
+C         IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
+C         SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
+C
+C         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
+C         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
+C         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
+C         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
+C         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
+C         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
+C         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
+C         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
+C         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
+C         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
+C         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
+C         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
+C         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
+C         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
+C         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
+C         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
+C         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
+C         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
+C         OR -PI/2+P.
+C
+C***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
+C                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
+C                 COMMERCE, 1955.
+C
+C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
+C                 BY D. E. AMOS, SAND83-0083, MAY, 1983.
+C
+C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
+C                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
+C
+C               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
+C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
+C                 1018, MAY, 1985
+C
+C               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
+C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
+C                 MATH. SOFTWARE, 1986
+C
+C***ROUTINES CALLED  ZBESH,I1MACH,D1MACH
+C***END PROLOGUE  ZBESY
+C
+C     COMPLEX CWRK,CY,C1,C2,EX,HCI,Z,ZU,ZV
+      DOUBLE PRECISION CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2R,
+     * ELIM, EXI, EXR, EY, FNU, HCII, STI, STR, TAY, ZI, ZR, DEXP,
+     * D1MACH, ASCLE, RTOL, ATOL, AA, BB, TOL
+      INTEGER I, IERR, K, KODE, K1, K2, N, NZ, NZ1, NZ2, I1MACH
+      DIMENSION CYR(N), CYI(N), CWRKR(N), CWRKI(N)
+C***FIRST EXECUTABLE STATEMENT  ZBESY
+      IERR = 0
+      NZ=0
+      IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1
+      IF (FNU.LT.0.0D0) IERR=1
+      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
+      IF (N.LT.1) IERR=1
+      IF (IERR.NE.0) RETURN
+      HCII = 0.5D0
+      CALL ZBESH(ZR, ZI, FNU, KODE, 1, N, CYR, CYI, NZ1, IERR)
+      IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170
+      CALL ZBESH(ZR, ZI, FNU, KODE, 2, N, CWRKR, CWRKI, NZ2, IERR)
+      IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170
+      NZ = MIN0(NZ1,NZ2)
+      IF (KODE.EQ.2) GO TO 60
+      DO 50 I=1,N
+        STR = CWRKR(I) - CYR(I)
+        STI = CWRKI(I) - CYI(I)
+        CYR(I) = -STI*HCII
+        CYI(I) = STR*HCII
+   50 CONTINUE
+      RETURN
+   60 CONTINUE
+      TOL = DMAX1(D1MACH(4),1.0D-18)
+      K1 = I1MACH(15)
+      K2 = I1MACH(16)
+      K = MIN0(IABS(K1),IABS(K2))
+      R1M5 = D1MACH(5)
+C-----------------------------------------------------------------------
+C     ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT
+C-----------------------------------------------------------------------
+      ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
+      EXR = DCOS(ZR)
+      EXI = DSIN(ZR)
+      EY = 0.0D0
+      TAY = DABS(ZI+ZI)
+      IF (TAY.LT.ELIM) EY = DEXP(-TAY)
+      IF (ZI.LT.0.0D0) GO TO 90
+      C1R = EXR*EY
+      C1I = EXI*EY
+      C2R = EXR
+      C2I = -EXI
+   70 CONTINUE
+      NZ = 0
+      RTOL = 1.0D0/TOL
+      ASCLE = D1MACH(1)*RTOL*1.0D+3
+      DO 80 I=1,N
+C       STR = C1R*CYR(I) - C1I*CYI(I)
+C       STI = C1R*CYI(I) + C1I*CYR(I)
+C       STR = -STR + C2R*CWRKR(I) - C2I*CWRKI(I)
+C       STI = -STI + C2R*CWRKI(I) + C2I*CWRKR(I)
+C       CYR(I) = -STI*HCII
+C       CYI(I) = STR*HCII
+        AA = CWRKR(I)
+        BB = CWRKI(I)
+        ATOL = 1.0D0
+        IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 75
+          AA = AA*RTOL
+          BB = BB*RTOL
+          ATOL = TOL
+   75   CONTINUE
+        STR = (AA*C2R - BB*C2I)*ATOL
+        STI = (AA*C2I + BB*C2R)*ATOL
+        AA = CYR(I)
+        BB = CYI(I)
+        ATOL = 1.0D0
+        IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 85
+          AA = AA*RTOL
+          BB = BB*RTOL
+          ATOL = TOL
+   85   CONTINUE
+        STR = STR - (AA*C1R - BB*C1I)*ATOL
+        STI = STI - (AA*C1I + BB*C1R)*ATOL
+        CYR(I) = -STI*HCII
+        CYI(I) =  STR*HCII
+        IF (STR.EQ.0.0D0 .AND. STI.EQ.0.0D0 .AND. EY.EQ.0.0D0) NZ = NZ
+     *   + 1
+   80 CONTINUE
+      RETURN
+   90 CONTINUE
+      C1R = EXR
+      C1I = EXI
+      C2R = EXR*EY
+      C2I = -EXI*EY
+      GO TO 70
+  170 CONTINUE
+      NZ = 0
+      RETURN
+      END

amos/zbinu.f

@@ -0,0 +1,110 @@
+      SUBROUTINE ZBINU(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL,
+     * TOL, ELIM, ALIM)
+C***BEGIN PROLOGUE  ZBINU
+C***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZAIRY,ZBIRY
+C
+C     ZBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE
+C
+C***ROUTINES CALLED  ZABS,ZASYI,ZBUNI,ZMLRI,ZSERI,ZUOIK,ZWRSK
+C***END PROLOGUE  ZBINU
+      DOUBLE PRECISION ALIM, AZ, CWI, CWR, CYI, CYR, DFNU, ELIM, FNU,
+     * FNUL, RL, TOL, ZEROI, ZEROR, ZI, ZR, ZABS
+      INTEGER I, INW, KODE, N, NLAST, NN, NUI, NW, NZ
+      DIMENSION CYR(N), CYI(N), CWR(2), CWI(2)
+      DATA ZEROR,ZEROI / 0.0D0, 0.0D0 /
+C
+      NZ = 0
+      AZ = ZABS(COMPLEX(ZR,ZI))
+      NN = N
+      DFNU = FNU + DBLE(FLOAT(N-1))
+      IF (AZ.LE.2.0D0) GO TO 10
+      IF (AZ*AZ*0.25D0.GT.DFNU+1.0D0) GO TO 20
+   10 CONTINUE
+C-----------------------------------------------------------------------
+C     POWER SERIES
+C-----------------------------------------------------------------------
+      CALL ZSERI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM)
+      INW = IABS(NW)
+      NZ = NZ + INW
+      NN = NN - INW
+      IF (NN.EQ.0) RETURN
+      IF (NW.GE.0) GO TO 120
+      DFNU = FNU + DBLE(FLOAT(NN-1))
+   20 CONTINUE
+      IF (AZ.LT.RL) GO TO 40
+      IF (DFNU.LE.1.0D0) GO TO 30
+      IF (AZ+AZ.LT.DFNU*DFNU) GO TO 50
+C-----------------------------------------------------------------------
+C     ASYMPTOTIC EXPANSION FOR LARGE Z
+C-----------------------------------------------------------------------
+   30 CONTINUE
+      CALL ZASYI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, RL, TOL, ELIM,
+     * ALIM)
+      IF (NW.LT.0) GO TO 130
+      GO TO 120
+   40 CONTINUE
+      IF (DFNU.LE.1.0D0) GO TO 70
+   50 CONTINUE
+C-----------------------------------------------------------------------
+C     OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM
+C-----------------------------------------------------------------------
+      CALL ZUOIK(ZR, ZI, FNU, KODE, 1, NN, CYR, CYI, NW, TOL, ELIM,
+     * ALIM)
+      IF (NW.LT.0) GO TO 130
+      NZ = NZ + NW
+      NN = NN - NW
+      IF (NN.EQ.0) RETURN
+      DFNU = FNU+DBLE(FLOAT(NN-1))
+      IF (DFNU.GT.FNUL) GO TO 110
+      IF (AZ.GT.FNUL) GO TO 110
+   60 CONTINUE
+      IF (AZ.GT.RL) GO TO 80
+   70 CONTINUE
+C-----------------------------------------------------------------------
+C     MILLER ALGORITHM NORMALIZED BY THE SERIES
+C-----------------------------------------------------------------------
+      CALL ZMLRI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL)
+      IF(NW.LT.0) GO TO 130
+      GO TO 120
+   80 CONTINUE
+C-----------------------------------------------------------------------
+C     MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN
+C-----------------------------------------------------------------------
+C-----------------------------------------------------------------------
+C     OVERFLOW TEST ON K FUNCTIONS USED IN WRONSKIAN
+C-----------------------------------------------------------------------
+      CALL ZUOIK(ZR, ZI, FNU, KODE, 2, 2, CWR, CWI, NW, TOL, ELIM,
+     * ALIM)
+      IF (NW.GE.0) GO TO 100
+      NZ = NN
+      DO 90 I=1,NN
+        CYR(I) = ZEROR
+        CYI(I) = ZEROI
+   90 CONTINUE
+      RETURN
+  100 CONTINUE
+      IF (NW.GT.0) GO TO 130
+      CALL ZWRSK(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, CWR, CWI, TOL,
+     * ELIM, ALIM)
+      IF (NW.LT.0) GO TO 130
+      GO TO 120
+  110 CONTINUE
+C-----------------------------------------------------------------------
+C     INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD
+C-----------------------------------------------------------------------
+      NUI = INT(SNGL(FNUL-DFNU)) + 1
+      NUI = MAX0(NUI,0)
+      CALL ZBUNI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, NUI, NLAST, FNUL,
+     * TOL, ELIM, ALIM)
+      IF (NW.LT.0) GO TO 130
+      NZ = NZ + NW
+      IF (NLAST.EQ.0) GO TO 120
+      NN = NLAST
+      GO TO 60
+  120 CONTINUE
+      RETURN
+  130 CONTINUE
+      NZ = -1
+      IF(NW.EQ.(-2)) NZ=-2
+      RETURN
+      END

amos/zbiry.f

@@ -0,0 +1,364 @@
+      SUBROUTINE ZBIRY(ZR, ZI, ID, KODE, BIR, BII, IERR)
+C***BEGIN PROLOGUE  ZBIRY
+C***DATE WRITTEN   830501   (YYMMDD)
+C***REVISION DATE  890801   (YYMMDD)
+C***CATEGORY NO.  B5K
+C***KEYWORDS  AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD
+C***AUTHOR  AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
+C***PURPOSE  TO COMPUTE AIRY FUNCTIONS BI(Z) AND DBI(Z) FOR COMPLEX Z
+C***DESCRIPTION
+C
+C                      ***A DOUBLE PRECISION ROUTINE***
+C         ON KODE=1, CBIRY COMPUTES THE COMPLEX AIRY FUNCTION BI(Z) OR
+C         ITS DERIVATIVE DBI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON
+C         KODE=2, A SCALING OPTION CEXP(-AXZTA)*BI(Z) OR CEXP(-AXZTA)*
+C         DBI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL BEHAVIOR IN
+C         BOTH THE LEFT AND RIGHT HALF PLANES WHERE
+C         ZTA=(2/3)*Z*CSQRT(Z)=CMPLX(XZTA,YZTA) AND AXZTA=ABS(XZTA).
+C         DEFINTIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF
+C         MATHEMATICAL FUNCTIONS (REF. 1).
+C
+C         INPUT      ZR,ZI ARE DOUBLE PRECISION
+C           ZR,ZI  - Z=CMPLX(ZR,ZI)
+C           ID     - ORDER OF DERIVATIVE, ID=0 OR ID=1
+C           KODE   - A PARAMETER TO INDICATE THE SCALING OPTION
+C                    KODE= 1  RETURNS
+C                             BI=BI(Z)                 ON ID=0 OR
+C                             BI=DBI(Z)/DZ             ON ID=1
+C                        = 2  RETURNS
+C                             BI=CEXP(-AXZTA)*BI(Z)     ON ID=0 OR
+C                             BI=CEXP(-AXZTA)*DBI(Z)/DZ ON ID=1 WHERE
+C                             ZTA=(2/3)*Z*CSQRT(Z)=CMPLX(XZTA,YZTA)
+C                             AND AXZTA=ABS(XZTA)
+C
+C         OUTPUT     BIR,BII ARE DOUBLE PRECISION
+C           BIR,BII- COMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND
+C                    KODE
+C           IERR   - ERROR FLAG
+C                    IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
+C                    IERR=1, INPUT ERROR   - NO COMPUTATION
+C                    IERR=2, OVERFLOW      - NO COMPUTATION, REAL(Z)
+C                            TOO LARGE ON KODE=1
+C                    IERR=3, CABS(Z) LARGE      - COMPUTATION COMPLETED
+C                            LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION
+C                            PRODUCE LESS THAN HALF OF MACHINE ACCURACY
+C                    IERR=4, CABS(Z) TOO LARGE  - NO COMPUTATION
+C                            COMPLETE LOSS OF ACCURACY BY ARGUMENT
+C                            REDUCTION
+C                    IERR=5, ERROR              - NO COMPUTATION,
+C                            ALGORITHM TERMINATION CONDITION NOT MET
+C
+C***LONG DESCRIPTION
+C
+C         BI AND DBI ARE COMPUTED FOR CABS(Z).GT.1.0 FROM THE I BESSEL
+C         FUNCTIONS BY
+C
+C                BI(Z)=C*SQRT(Z)*( I(-1/3,ZTA) + I(1/3,ZTA) )
+C               DBI(Z)=C *  Z  * ( I(-2/3,ZTA) + I(2/3,ZTA) )
+C                               C=1.0/SQRT(3.0)
+C                             ZTA=(2/3)*Z**(3/2)
+C
+C         WITH THE POWER SERIES FOR CABS(Z).LE.1.0.
+C
+C         IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
+C         MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES
+C         OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF
+C         THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR),
+C         THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR
+C         FLAG IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
+C         DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
+C         ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN
+C         ALL SIGNIFICANCE IS LOST AND IERR=4. IN ORDER TO USE THE INT
+C         FUNCTION, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE
+C         LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA
+C         MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2,
+C         AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE
+C         PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE
+C         PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT-
+C         ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG-
+C         NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN
+C         DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN
+C         EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES,
+C         NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE
+C         PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER
+C         MACHINES.
+C
+C         THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
+C         BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
+C         ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
+C         SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
+C         ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
+C         ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
+C         CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
+C         HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
+C         ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
+C         SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
+C         THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
+C         0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
+C         THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
+C         COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
+C         BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
+C         COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
+C         MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
+C         THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
+C         OR -PI/2+P.
+C
+C***REFERENCES  HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
+C                 AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
+C                 COMMERCE, 1955.
+C
+C               COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
+C                 AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
+C
+C               A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
+C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
+C                 1018, MAY, 1985
+C
+C               A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
+C                 ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
+C                 MATH. SOFTWARE, 1986
+C
+C***ROUTINES CALLED  ZBINU,ZABS,ZDIV,ZSQRT,D1MACH,I1MACH
+C***END PROLOGUE  ZBIRY
+C     COMPLEX BI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3
+      DOUBLE PRECISION AA, AD, AK, ALIM, ATRM, AZ, AZ3, BB, BII, BIR,
+     * BK, CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2,
+     * DIG, DK, D1, D2, EAA, ELIM, FID, FMR, FNU, FNUL, PI, RL, R1M5,
+     * SFAC, STI, STR, S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I,
+     * TRM2R, TTH, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS
+      INTEGER ID, IERR, K, KODE, K1, K2, NZ, I1MACH
+      DIMENSION CYR(2), CYI(2)
+      DATA TTH, C1, C2, COEF, PI /6.66666666666666667D-01,
+     * 6.14926627446000736D-01,4.48288357353826359D-01,
+     * 5.77350269189625765D-01,3.14159265358979324D+00/
+      DATA CONER, CONEI /1.0D0,0.0D0/
+C***FIRST EXECUTABLE STATEMENT  ZBIRY
+      IERR = 0
+      NZ=0
+      IF (ID.LT.0 .OR. ID.GT.1) IERR=1
+      IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
+      IF (IERR.NE.0) RETURN
+      AZ = ZABS(COMPLEX(ZR,ZI))
+      TOL = DMAX1(D1MACH(4),1.0D-18)
+      FID = DBLE(FLOAT(ID))
+      IF (AZ.GT.1.0E0) GO TO 70
+C-----------------------------------------------------------------------
+C     POWER SERIES FOR CABS(Z).LE.1.
+C-----------------------------------------------------------------------
+      S1R = CONER
+      S1I = CONEI
+      S2R = CONER
+      S2I = CONEI
+      IF (AZ.LT.TOL) GO TO 130
+      AA = AZ*AZ
+      IF (AA.LT.TOL/AZ) GO TO 40
+      TRM1R = CONER
+      TRM1I = CONEI
+      TRM2R = CONER
+      TRM2I = CONEI
+      ATRM = 1.0D0
+      STR = ZR*ZR - ZI*ZI
+      STI = ZR*ZI + ZI*ZR
+      Z3R = STR*ZR - STI*ZI
+      Z3I = STR*ZI + STI*ZR
+      AZ3 = AZ*AA
+      AK = 2.0D0 + FID
+      BK = 3.0D0 - FID - FID
+      CK = 4.0D0 - FID
+      DK = 3.0D0 + FID + FID
+      D1 = AK*DK
+      D2 = BK*CK
+      AD = DMIN1(D1,D2)
+      AK = 24.0D0 + 9.0D0*FID
+      BK = 30.0D0 - 9.0D0*FID
+      DO 30 K=1,25
+        STR = (TRM1R*Z3R-TRM1I*Z3I)/D1
+        TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1
+        TRM1R = STR
+        S1R = S1R + TRM1R
+        S1I = S1I + TRM1I
+        STR = (TRM2R*Z3R-TRM2I*Z3I)/D2
+        TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2
+        TRM2R = STR
+        S2R = S2R + TRM2R
+        S2I = S2I + TRM2I
+        ATRM = ATRM*AZ3/AD
+        D1 = D1 + AK
+        D2 = D2 + BK
+        AD = DMIN1(D1,D2)
+        IF (ATRM.LT.TOL*AD) GO TO 40
+        AK = AK + 18.0D0
+        BK = BK + 18.0D0
+   30 CONTINUE
+   40 CONTINUE
+      IF (ID.EQ.1) GO TO 50
+      BIR = C1*S1R + C2*(ZR*S2R-ZI*S2I)
+      BII = C1*S1I + C2*(ZR*S2I+ZI*S2R)
+      IF (KODE.EQ.1) RETURN
+      CALL ZSQRT(ZR, ZI, STR, STI)
+      ZTAR = TTH*(ZR*STR-ZI*STI)
+      ZTAI = TTH*(ZR*STI+ZI*STR)
+      AA = ZTAR
+      AA = -DABS(AA)
+      EAA = DEXP(AA)
+      BIR = BIR*EAA
+      BII = BII*EAA
+      RETURN
+   50 CONTINUE
+      BIR = S2R*C2
+      BII = S2I*C2
+      IF (AZ.LE.TOL) GO TO 60
+      CC = C1/(1.0D0+FID)
+      STR = S1R*ZR - S1I*ZI
+      STI = S1R*ZI + S1I*ZR
+      BIR = BIR + CC*(STR*ZR-STI*ZI)
+      BII = BII + CC*(STR*ZI+STI*ZR)
+   60 CONTINUE
+      IF (KODE.EQ.1) RETURN
+      CALL ZSQRT(ZR, ZI, STR, STI)
+      ZTAR = TTH*(ZR*STR-ZI*STI)
+      ZTAI = TTH*(ZR*STI+ZI*STR)
+      AA = ZTAR
+      AA = -DABS(AA)
+      EAA = DEXP(AA)
+      BIR = BIR*EAA
+      BII = BII*EAA
+      RETURN
+C-----------------------------------------------------------------------
+C     CASE FOR CABS(Z).GT.1.0
+C-----------------------------------------------------------------------
+   70 CONTINUE
+      FNU = (1.0D0+FID)/3.0D0
+C-----------------------------------------------------------------------
+C     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
+C     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
+C     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
+C     EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL    AND
+C     EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
+C     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
+C     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
+C     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
+C     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU.
+C-----------------------------------------------------------------------
+      K1 = I1MACH(15)
+      K2 = I1MACH(16)
+      R1M5 = D1MACH(5)
+      K = MIN0(IABS(K1),IABS(K2))
+      ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
+      K1 = I1MACH(14) - 1
+      AA = R1M5*DBLE(FLOAT(K1))
+      DIG = DMIN1(AA,18.0D0)
+      AA = AA*2.303D0
+      ALIM = ELIM + DMAX1(-AA,-41.45D0)
+      RL = 1.2D0*DIG + 3.0D0
+      FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
+C-----------------------------------------------------------------------
+C     TEST FOR RANGE
+C-----------------------------------------------------------------------
+      AA=0.5D0/TOL
+      BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
+      AA=DMIN1(AA,BB)
+      AA=AA**TTH
+      IF (AZ.GT.AA) GO TO 260
+      AA=DSQRT(AA)
+      IF (AZ.GT.AA) IERR=3
+      CALL ZSQRT(ZR, ZI, CSQR, CSQI)
+      ZTAR = TTH*(ZR*CSQR-ZI*CSQI)
+      ZTAI = TTH*(ZR*CSQI+ZI*CSQR)
+C-----------------------------------------------------------------------
+C     RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL
+C-----------------------------------------------------------------------
+      SFAC = 1.0D0
+      AK = ZTAI
+      IF (ZR.GE.0.0D0) GO TO 80
+      BK = ZTAR
+      CK = -DABS(BK)
+      ZTAR = CK
+      ZTAI = AK
+   80 CONTINUE
+      IF (ZI.NE.0.0D0 .OR. ZR.GT.0.0D0) GO TO 90
+      ZTAR = 0.0D0
+      ZTAI = AK
+   90 CONTINUE
+      AA = ZTAR
+      IF (KODE.EQ.2) GO TO 100
+C-----------------------------------------------------------------------
+C     OVERFLOW TEST
+C-----------------------------------------------------------------------
+      BB = DABS(AA)
+      IF (BB.LT.ALIM) GO TO 100
+      BB = BB + 0.25D0*DLOG(AZ)
+      SFAC = TOL
+      IF (BB.GT.ELIM) GO TO 190
+  100 CONTINUE
+      FMR = 0.0D0
+      IF (AA.GE.0.0D0 .AND. ZR.GT.0.0D0) GO TO 110
+      FMR = PI
+      IF (ZI.LT.0.0D0) FMR = -PI
+      ZTAR = -ZTAR
+      ZTAI = -ZTAI
+  110 CONTINUE
+C-----------------------------------------------------------------------
+C     AA=FACTOR FOR ANALYTIC CONTINUATION OF I(FNU,ZTA)
+C     KODE=2 RETURNS EXP(-ABS(XZTA))*I(FNU,ZTA) FROM CBESI
+C-----------------------------------------------------------------------
+      CALL ZBINU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, RL, FNUL, TOL,
+     * ELIM, ALIM)
+      IF (NZ.LT.0) GO TO 200
+      AA = FMR*FNU
+      Z3R = SFAC
+      STR = DCOS(AA)
+      STI = DSIN(AA)
+      S1R = (STR*CYR(1)-STI*CYI(1))*Z3R
+      S1I = (STR*CYI(1)+STI*CYR(1))*Z3R
+      FNU = (2.0D0-FID)/3.0D0
+      CALL ZBINU(ZTAR, ZTAI, FNU, KODE, 2, CYR, CYI, NZ, RL, FNUL, TOL,
+     * ELIM, ALIM)
+      CYR(1) = CYR(1)*Z3R
+      CYI(1) = CYI(1)*Z3R
+      CYR(2) = CYR(2)*Z3R
+      CYI(2) = CYI(2)*Z3R
+C-----------------------------------------------------------------------
+C     BACKWARD RECUR ONE STEP FOR ORDERS -1/3 OR -2/3
+C-----------------------------------------------------------------------
+      CALL ZDIV(CYR(1), CYI(1), ZTAR, ZTAI, STR, STI)
+      S2R = (FNU+FNU)*STR + CYR(2)
+      S2I = (FNU+FNU)*STI + CYI(2)
+      AA = FMR*(FNU-1.0D0)
+      STR = DCOS(AA)
+      STI = DSIN(AA)
+      S1R = COEF*(S1R+S2R*STR-S2I*STI)
+      S1I = COEF*(S1I+S2R*STI+S2I*STR)
+      IF (ID.EQ.1) GO TO 120
+      STR = CSQR*S1R - CSQI*S1I
+      S1I = CSQR*S1I + CSQI*S1R
+      S1R = STR
+      BIR = S1R/SFAC
+      BII = S1I/SFAC
+      RETURN
+  120 CONTINUE
+      STR = ZR*S1R - ZI*S1I
+      S1I = ZR*S1I + ZI*S1R
+      S1R = STR
+      BIR = S1R/SFAC
+      BII = S1I/SFAC
+      RETURN
+  130 CONTINUE
+      AA = C1*(1.0D0-FID) + FID*C2
+      BIR = AA
+      BII = 0.0D0
+      RETURN
+  190 CONTINUE
+      IERR=2
+      NZ=0
+      RETURN
+  200 CONTINUE
+      IF(NZ.EQ.(-1)) GO TO 190
+      NZ=0
+      IERR=5
+      RETURN
+  260 CONTINUE
+      IERR=4
+      NZ=0
+      RETURN
+      END

amos/zbknu.f

@@ -0,0 +1,568 @@
+      SUBROUTINE ZBKNU(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM,
+     * ALIM)
+C***BEGIN PROLOGUE  ZBKNU
+C***REFER TO  ZBESI,ZBESK,ZAIRY,ZBESH
+C
+C     ZBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE.
+C
+C***ROUTINES CALLED  DGAMLN,I1MACH,D1MACH,ZKSCL,ZSHCH,ZUCHK,ZABS,ZDIV,
+C                    ZEXP,ZLOG,ZMLT,ZSQRT
+C***END PROLOGUE  ZBKNU
+C
+      DOUBLE PRECISION AA, AK, ALIM, ASCLE, A1, A2, BB, BK, BRY, CAZ,
+     * CBI, CBR, CC, CCHI, CCHR, CKI, CKR, COEFI, COEFR, CONEI, CONER,
+     * CRSCR, CSCLR, CSHI, CSHR, CSI, CSR, CSRR, CSSR, CTWOR,
+     * CZEROI, CZEROR, CZI, CZR, DNU, DNU2, DPI, ELIM, ETEST, FC, FHS,
+     * FI, FK, FKS, FMUI, FMUR, FNU, FPI, FR, G1, G2, HPI, PI, PR, PTI,
+     * PTR, P1I, P1R, P2I, P2M, P2R, QI, QR, RAK, RCAZ, RTHPI, RZI,
+     * RZR, R1, S, SMUI, SMUR, SPI, STI, STR, S1I, S1R, S2I, S2R, TM,
+     * TOL, TTH, T1, T2, YI, YR, ZI, ZR, DGAMLN, D1MACH, ZABS, ELM,
+     * CELMR, ZDR, ZDI, AS, ALAS, HELIM, CYR, CYI
+      INTEGER I, IFLAG, INU, K, KFLAG, KK, KMAX, KODE, KODED, N, NZ,
+     * IDUM, I1MACH, J, IC, INUB, NW
+      DIMENSION YR(N), YI(N), CC(8), CSSR(3), CSRR(3), BRY(3), CYR(2),
+     * CYI(2)
+C     COMPLEX Z,Y,A,B,RZ,SMU,FU,FMU,F,FLRZ,CZ,S1,S2,CSH,CCH
+C     COMPLEX CK,P,Q,COEF,P1,P2,CBK,PT,CZERO,CONE,CTWO,ST,EZ,CS,DK
+C
+      DATA KMAX / 30 /
+      DATA CZEROR,CZEROI,CONER,CONEI,CTWOR,R1/
+     1  0.0D0 , 0.0D0 , 1.0D0 , 0.0D0 , 2.0D0 , 2.0D0 /
+      DATA DPI, RTHPI, SPI ,HPI, FPI, TTH /
+     1     3.14159265358979324D0,       1.25331413731550025D0,
+     2     1.90985931710274403D0,       1.57079632679489662D0,
+     3     1.89769999331517738D0,       6.66666666666666666D-01/
+      DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)/
+     1     5.77215664901532861D-01,    -4.20026350340952355D-02,
+     2    -4.21977345555443367D-02,     7.21894324666309954D-03,
+     3    -2.15241674114950973D-04,    -2.01348547807882387D-05,
+     4     1.13302723198169588D-06,     6.11609510448141582D-09/
+C
+      CAZ = ZABS(COMPLEX(ZR,ZI))
+      CSCLR = 1.0D0/TOL
+      CRSCR = TOL
+      CSSR(1) = CSCLR
+      CSSR(2) = 1.0D0
+      CSSR(3) = CRSCR
+      CSRR(1) = CRSCR
+      CSRR(2) = 1.0D0
+      CSRR(3) = CSCLR
+      BRY(1) = 1.0D+3*D1MACH(1)/TOL
+      BRY(2) = 1.0D0/BRY(1)
+      BRY(3) = D1MACH(2)
+      NZ = 0
+      IFLAG = 0
+      KODED = KODE
+      RCAZ = 1.0D0/CAZ
+      STR = ZR*RCAZ
+      STI = -ZI*RCAZ
+      RZR = (STR+STR)*RCAZ
+      RZI = (STI+STI)*RCAZ
+      INU = INT(SNGL(FNU+0.5D0))
+      DNU = FNU - DBLE(FLOAT(INU))
+      IF (DABS(DNU).EQ.0.5D0) GO TO 110
+      DNU2 = 0.0D0
+      IF (DABS(DNU).GT.TOL) DNU2 = DNU*DNU
+      IF (CAZ.GT.R1) GO TO 110
+C-----------------------------------------------------------------------
+C     SERIES FOR CABS(Z).LE.R1
+C-----------------------------------------------------------------------
+      FC = 1.0D0
+      CALL ZLOG(RZR, RZI, SMUR, SMUI, IDUM)
+      FMUR = SMUR*DNU
+      FMUI = SMUI*DNU
+      CALL ZSHCH(FMUR, FMUI, CSHR, CSHI, CCHR, CCHI)
+      IF (DNU.EQ.0.0D0) GO TO 10
+      FC = DNU*DPI
+      FC = FC/DSIN(FC)
+      SMUR = CSHR/DNU
+      SMUI = CSHI/DNU
+   10 CONTINUE
+      A2 = 1.0D0 + DNU
+C-----------------------------------------------------------------------
+C     GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU), T2=1/GAM(1+DNU)
+C-----------------------------------------------------------------------
+      T2 = DEXP(-DGAMLN(A2,IDUM))
+      T1 = 1.0D0/(T2*FC)
+      IF (DABS(DNU).GT.0.1D0) GO TO 40
+C-----------------------------------------------------------------------
+C     SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU)
+C-----------------------------------------------------------------------
+      AK = 1.0D0
+      S = CC(1)
+      DO 20 K=2,8
+        AK = AK*DNU2
+        TM = CC(K)*AK
+        S = S + TM
+        IF (DABS(TM).LT.TOL) GO TO 30
+   20 CONTINUE
+   30 G1 = -S
+      GO TO 50
+   40 CONTINUE
+      G1 = (T1-T2)/(DNU+DNU)
+   50 CONTINUE
+      G2 = (T1+T2)*0.5D0
+      FR = FC*(CCHR*G1+SMUR*G2)
+      FI = FC*(CCHI*G1+SMUI*G2)
+      CALL ZEXP(FMUR, FMUI, STR, STI)
+      PR = 0.5D0*STR/T2
+      PI = 0.5D0*STI/T2
+      CALL ZDIV(0.5D0, 0.0D0, STR, STI, PTR, PTI)
+      QR = PTR/T1
+      QI = PTI/T1
+      S1R = FR
+      S1I = FI
+      S2R = PR
+      S2I = PI
+      AK = 1.0D0
+      A1 = 1.0D0
+      CKR = CONER
+      CKI = CONEI
+      BK = 1.0D0 - DNU2
+      IF (INU.GT.0 .OR. N.GT.1) GO TO 80
+C-----------------------------------------------------------------------
+C     GENERATE K(FNU,Z), 0.0D0 .LE. FNU .LT. 0.5D0 AND N=1
+C-----------------------------------------------------------------------
+      IF (CAZ.LT.TOL) GO TO 70
+      CALL ZMLT(ZR, ZI, ZR, ZI, CZR, CZI)
+      CZR = 0.25D0*CZR
+      CZI = 0.25D0*CZI
+      T1 = 0.25D0*CAZ*CAZ
+   60 CONTINUE
+      FR = (FR*AK+PR+QR)/BK
+      FI = (FI*AK+PI+QI)/BK
+      STR = 1.0D0/(AK-DNU)
+      PR = PR*STR
+      PI = PI*STR
+      STR = 1.0D0/(AK+DNU)
+      QR = QR*STR
+      QI = QI*STR
+      STR = CKR*CZR - CKI*CZI
+      RAK = 1.0D0/AK
+      CKI = (CKR*CZI+CKI*CZR)*RAK
+      CKR = STR*RAK
+      S1R = CKR*FR - CKI*FI + S1R
+      S1I = CKR*FI + CKI*FR + S1I
+      A1 = A1*T1*RAK
+      BK = BK + AK + AK + 1.0D0
+      AK = AK + 1.0D0
+      IF (A1.GT.TOL) GO TO 60
+   70 CONTINUE
+      YR(1) = S1R
+      YI(1) = S1I
+      IF (KODED.EQ.1) RETURN
+      CALL ZEXP(ZR, ZI, STR, STI)
+      CALL ZMLT(S1R, S1I, STR, STI, YR(1), YI(1))
+      RETURN
+C-----------------------------------------------------------------------
+C     GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE
+C-----------------------------------------------------------------------
+   80 CONTINUE
+      IF (CAZ.LT.TOL) GO TO 100
+      CALL ZMLT(ZR, ZI, ZR, ZI, CZR, CZI)
+      CZR = 0.25D0*CZR
+      CZI = 0.25D0*CZI
+      T1 = 0.25D0*CAZ*CAZ
+   90 CONTINUE
+      FR = (FR*AK+PR+QR)/BK
+      FI = (FI*AK+PI+QI)/BK
+      STR = 1.0D0/(AK-DNU)
+      PR = PR*STR
+      PI = PI*STR
+      STR = 1.0D0/(AK+DNU)
+      QR = QR*STR
+      QI = QI*STR
+      STR = CKR*CZR - CKI*CZI
+      RAK = 1.0D0/AK
+      CKI = (CKR*CZI+CKI*CZR)*RAK
+      CKR = STR*RAK
+      S1R = CKR*FR - CKI*FI + S1R
+      S1I = CKR*FI + CKI*FR + S1I
+      STR = PR - FR*AK
+      STI = PI - FI*AK
+      S2R = CKR*STR - CKI*STI + S2R
+      S2I = CKR*STI + CKI*STR + S2I
+      A1 = A1*T1*RAK
+      BK = BK + AK + AK + 1.0D0
+      AK = AK + 1.0D0
+      IF (A1.GT.TOL) GO TO 90
+  100 CONTINUE
+      KFLAG = 2
+      A1 = FNU + 1.0D0
+      AK = A1*DABS(SMUR)
+      IF (AK.GT.ALIM) KFLAG = 3
+      STR = CSSR(KFLAG)
+      P2R = S2R*STR
+      P2I = S2I*STR
+      CALL ZMLT(P2R, P2I, RZR, RZI, S2R, S2I)
+      S1R = S1R*STR
+      S1I = S1I*STR
+      IF (KODED.EQ.1) GO TO 210
+      CALL ZEXP(ZR, ZI, FR, FI)
+      CALL ZMLT(S1R, S1I, FR, FI, S1R, S1I)
+      CALL ZMLT(S2R, S2I, FR, FI, S2R, S2I)
+      GO TO 210
+C-----------------------------------------------------------------------
+C     IFLAG=0 MEANS NO UNDERFLOW OCCURRED
+C     IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH
+C     KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD
+C     RECURSION
+C-----------------------------------------------------------------------
+  110 CONTINUE
+      CALL ZSQRT(ZR, ZI, STR, STI)
+      CALL ZDIV(RTHPI, CZEROI, STR, STI, COEFR, COEFI)
+      KFLAG = 2
+      IF (KODED.EQ.2) GO TO 120
+      IF (ZR.GT.ALIM) GO TO 290
+C     BLANK LINE
+      STR = DEXP(-ZR)*CSSR(KFLAG)
+      STI = -STR*DSIN(ZI)
+      STR = STR*DCOS(ZI)
+      CALL ZMLT(COEFR, COEFI, STR, STI, COEFR, COEFI)
+  120 CONTINUE
+      IF (DABS(DNU).EQ.0.5D0) GO TO 300
+C-----------------------------------------------------------------------
+C     MILLER ALGORITHM FOR CABS(Z).GT.R1
+C-----------------------------------------------------------------------
+      AK = DCOS(DPI*DNU)
+      AK = DABS(AK)
+      IF (AK.EQ.CZEROR) GO TO 300
+      FHS = DABS(0.25D0-DNU2)
+      IF (FHS.EQ.CZEROR) GO TO 300
+C-----------------------------------------------------------------------
+C     COMPUTE R2=F(E). IF CABS(Z).GE.R2, USE FORWARD RECURRENCE TO
+C     DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT LINE ON
+C     12.LE.E.LE.60. E IS COMPUTED FROM 2**(-E)=B**(1-I1MACH(14))=
+C     TOL WHERE B IS THE BASE OF THE ARITHMETIC.
+C-----------------------------------------------------------------------
+      T1 = DBLE(FLOAT(I1MACH(14)-1))
+      T1 = T1*D1MACH(5)*3.321928094D0
+      T1 = DMAX1(T1,12.0D0)
+      T1 = DMIN1(T1,60.0D0)
+      T2 = TTH*T1 - 6.0D0
+      IF (ZR.NE.0.0D0) GO TO 130
+      T1 = HPI
+      GO TO 140
+  130 CONTINUE
+      T1 = DATAN(ZI/ZR)
+      T1 = DABS(T1)
+  140 CONTINUE
+      IF (T2.GT.CAZ) GO TO 170
+C-----------------------------------------------------------------------
+C     FORWARD RECURRENCE LOOP WHEN CABS(Z).GE.R2
+C-----------------------------------------------------------------------
+      ETEST = AK/(DPI*CAZ*TOL)
+      FK = CONER
+      IF (ETEST.LT.CONER) GO TO 180
+      FKS = CTWOR
+      CKR = CAZ + CAZ + CTWOR
+      P1R = CZEROR
+      P2R = CONER
+      DO 150 I=1,KMAX
+        AK = FHS/FKS
+        CBR = CKR/(FK+CONER)
+        PTR = P2R
+        P2R = CBR*P2R - P1R*AK
+        P1R = PTR
+        CKR = CKR + CTWOR
+        FKS = FKS + FK + FK + CTWOR
+        FHS = FHS + FK + FK
+        FK = FK + CONER
+        STR = DABS(P2R)*FK
+        IF (ETEST.LT.STR) GO TO 160
+  150 CONTINUE
+      GO TO 310
+  160 CONTINUE
+      FK = FK + SPI*T1*DSQRT(T2/CAZ)
+      FHS = DABS(0.25D0-DNU2)
+      GO TO 180
+  170 CONTINUE
+C-----------------------------------------------------------------------
+C     COMPUTE BACKWARD INDEX K FOR CABS(Z).LT.R2
+C-----------------------------------------------------------------------
+      A2 = DSQRT(CAZ)
+      AK = FPI*AK/(TOL*DSQRT(A2))
+      AA = 3.0D0*T1/(1.0D0+CAZ)
+      BB = 14.7D0*T1/(28.0D0+CAZ)
+      AK = (DLOG(AK)+CAZ*DCOS(AA)/(1.0D0+0.008D0*CAZ))/DCOS(BB)
+      FK = 0.12125D0*AK*AK/CAZ + 1.5D0
+  180 CONTINUE
+C-----------------------------------------------------------------------
+C     BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM
+C-----------------------------------------------------------------------
+      K = INT(SNGL(FK))
+      FK = DBLE(FLOAT(K))
+      FKS = FK*FK
+      P1R = CZEROR
+      P1I = CZEROI
+      P2R = TOL
+      P2I = CZEROI
+      CSR = P2R
+      CSI = P2I
+      DO 190 I=1,K
+        A1 = FKS - FK
+        AK = (FKS+FK)/(A1+FHS)
+        RAK = 2.0D0/(FK+CONER)
+        CBR = (FK+ZR)*RAK
+        CBI = ZI*RAK
+        PTR = P2R
+        PTI = P2I
+        P2R = (PTR*CBR-PTI*CBI-P1R)*AK
+        P2I = (PTI*CBR+PTR*CBI-P1I)*AK
+        P1R = PTR
+        P1I = PTI
+        CSR = CSR + P2R
+        CSI = CSI + P2I
+        FKS = A1 - FK + CONER
+        FK = FK - CONER
+  190 CONTINUE
+C-----------------------------------------------------------------------
+C     COMPUTE (P2/CS)=(P2/CABS(CS))*(CONJG(CS)/CABS(CS)) FOR BETTER
+C     SCALING
+C-----------------------------------------------------------------------
+      TM = ZABS(COMPLEX(CSR,CSI))
+      PTR = 1.0D0/TM
+      S1R = P2R*PTR
+      S1I = P2I*PTR
+      CSR = CSR*PTR
+      CSI = -CSI*PTR
+      CALL ZMLT(COEFR, COEFI, S1R, S1I, STR, STI)
+      CALL ZMLT(STR, STI, CSR, CSI, S1R, S1I)
+      IF (INU.GT.0 .OR. N.GT.1) GO TO 200
+      ZDR = ZR
+      ZDI = ZI
+      IF(IFLAG.EQ.1) GO TO 270
+      GO TO 240
+  200 CONTINUE
+C-----------------------------------------------------------------------
+C     COMPUTE P1/P2=(P1/CABS(P2)*CONJG(P2)/CABS(P2) FOR SCALING
+C-----------------------------------------------------------------------
+      TM = ZABS(COMPLEX(P2R,P2I))
+      PTR = 1.0D0/TM
+      P1R = P1R*PTR
+      P1I = P1I*PTR
+      P2R = P2R*PTR
+      P2I = -P2I*PTR
+      CALL ZMLT(P1R, P1I, P2R, P2I, PTR, PTI)
+      STR = DNU + 0.5D0 - PTR
+      STI = -PTI
+      CALL ZDIV(STR, STI, ZR, ZI, STR, STI)
+      STR = STR + 1.0D0
+      CALL ZMLT(STR, STI, S1R, S1I, S2R, S2I)
+C-----------------------------------------------------------------------
+C     FORWARD RECURSION ON THE THREE TERM RECURSION WITH RELATION WITH
+C     SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3
+C-----------------------------------------------------------------------
+  210 CONTINUE
+      STR = DNU + 1.0D0
+      CKR = STR*RZR
+      CKI = STR*RZI
+      IF (N.EQ.1) INU = INU - 1
+      IF (INU.GT.0) GO TO 220
+      IF (N.GT.1) GO TO 215
+      S1R = S2R
+      S1I = S2I
+  215 CONTINUE
+      ZDR = ZR
+      ZDI = ZI
+      IF(IFLAG.EQ.1) GO TO 270
+      GO TO 240
+  220 CONTINUE
+      INUB = 1
+      IF(IFLAG.EQ.1) GO TO 261
+  225 CONTINUE
+      P1R = CSRR(KFLAG)
+      ASCLE = BRY(KFLAG)
+      DO 230 I=INUB,INU
+        STR = S2R
+        STI = S2I
+        S2R = CKR*STR - CKI*STI + S1R
+        S2I = CKR*STI + CKI*STR + S1I
+        S1R = STR
+        S1I = STI
+        CKR = CKR + RZR
+        CKI = CKI + RZI
+        IF (KFLAG.GE.3) GO TO 230
+        P2R = S2R*P1R
+        P2I = S2I*P1R
+        STR = DABS(P2R)
+        STI = DABS(P2I)
+        P2M = DMAX1(STR,STI)
+        IF (P2M.LE.ASCLE) GO TO 230
+        KFLAG = KFLAG + 1
+        ASCLE = BRY(KFLAG)
+        S1R = S1R*P1R
+        S1I = S1I*P1R
+        S2R = P2R
+        S2I = P2I
+        STR = CSSR(KFLAG)
+        S1R = S1R*STR
+        S1I = S1I*STR
+        S2R = S2R*STR
+        S2I = S2I*STR
+        P1R = CSRR(KFLAG)
+  230 CONTINUE
+      IF (N.NE.1) GO TO 240
+      S1R = S2R
+      S1I = S2I
+  240 CONTINUE
+      STR = CSRR(KFLAG)
+      YR(1) = S1R*STR
+      YI(1) = S1I*STR
+      IF (N.EQ.1) RETURN
+      YR(2) = S2R*STR
+      YI(2) = S2I*STR
+      IF (N.EQ.2) RETURN
+      KK = 2
+  250 CONTINUE
+      KK = KK + 1
+      IF (KK.GT.N) RETURN
+      P1R = CSRR(KFLAG)
+      ASCLE = BRY(KFLAG)
+      DO 260 I=KK,N
+        P2R = S2R
+        P2I = S2I
+        S2R = CKR*P2R - CKI*P2I + S1R
+        S2I = CKI*P2R + CKR*P2I + S1I
+        S1R = P2R
+        S1I = P2I
+        CKR = CKR + RZR
+        CKI = CKI + RZI
+        P2R = S2R*P1R
+        P2I = S2I*P1R
+        YR(I) = P2R
+        YI(I) = P2I
+        IF (KFLAG.GE.3) GO TO 260
+        STR = DABS(P2R)
+        STI = DABS(P2I)
+        P2M = DMAX1(STR,STI)
+        IF (P2M.LE.ASCLE) GO TO 260
+        KFLAG = KFLAG + 1
+        ASCLE = BRY(KFLAG)
+        S1R = S1R*P1R
+        S1I = S1I*P1R
+        S2R = P2R
+        S2I = P2I
+        STR = CSSR(KFLAG)
+        S1R = S1R*STR
+        S1I = S1I*STR
+        S2R = S2R*STR
+        S2I = S2I*STR
+        P1R = CSRR(KFLAG)
+  260 CONTINUE
+      RETURN
+C-----------------------------------------------------------------------
+C     IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW
+C-----------------------------------------------------------------------
+  261 CONTINUE
+      HELIM = 0.5D0*ELIM
+      ELM = DEXP(-ELIM)
+      CELMR = ELM
+      ASCLE = BRY(1)
+      ZDR = ZR
+      ZDI = ZI
+      IC = -1
+      J = 2
+      DO 262 I=1,INU
+        STR = S2R
+        STI = S2I
+        S2R = STR*CKR-STI*CKI+S1R
+        S2I = STI*CKR+STR*CKI+S1I
+        S1R = STR
+        S1I = STI
+        CKR = CKR+RZR
+        CKI = CKI+RZI
+        AS = ZABS(COMPLEX(S2R,S2I))
+        ALAS = DLOG(AS)
+        P2R = -ZDR+ALAS
+        IF(P2R.LT.(-ELIM)) GO TO 263
+        CALL ZLOG(S2R,S2I,STR,STI,IDUM)
+        P2R = -ZDR+STR
+        P2I = -ZDI+STI
+        P2M = DEXP(P2R)/TOL
+        P1R = P2M*DCOS(P2I)
+        P1I = P2M*DSIN(P2I)
+        CALL ZUCHK(P1R,P1I,NW,ASCLE,TOL)
+        IF(NW.NE.0) GO TO 263
+        J = 3 - J
+        CYR(J) = P1R
+        CYI(J) = P1I
+        IF(IC.EQ.(I-1)) GO TO 264
+        IC = I
+        GO TO 262
+  263   CONTINUE
+        IF(ALAS.LT.HELIM) GO TO 262
+        ZDR = ZDR-ELIM
+        S1R = S1R*CELMR
+        S1I = S1I*CELMR
+        S2R = S2R*CELMR
+        S2I = S2I*CELMR
+  262 CONTINUE
+      IF(N.NE.1) GO TO 270
+      S1R = S2R
+      S1I = S2I
+      GO TO 270
+  264 CONTINUE
+      KFLAG = 1
+      INUB = I+1
+      S2R = CYR(J)
+      S2I = CYI(J)
+      J = 3 - J
+      S1R = CYR(J)
+      S1I = CYI(J)
+      IF(INUB.LE.INU) GO TO 225
+      IF(N.NE.1) GO TO 240
+      S1R = S2R
+      S1I = S2I
+      GO TO 240
+  270 CONTINUE
+      YR(1) = S1R
+      YI(1) = S1I
+      IF(N.EQ.1) GO TO 280
+      YR(2) = S2R
+      YI(2) = S2I
+  280 CONTINUE
+      ASCLE = BRY(1)
+      CALL ZKSCL(ZDR,ZDI,FNU,N,YR,YI,NZ,RZR,RZI,ASCLE,TOL,ELIM)
+      INU = N - NZ
+      IF (INU.LE.0) RETURN
+      KK = NZ + 1
+      S1R = YR(KK)
+      S1I = YI(KK)
+      YR(KK) = S1R*CSRR(1)
+      YI(KK) = S1I*CSRR(1)
+      IF (INU.EQ.1) RETURN
+      KK = NZ + 2
+      S2R = YR(KK)
+      S2I = YI(KK)
+      YR(KK) = S2R*CSRR(1)
+      YI(KK) = S2I*CSRR(1)
+      IF (INU.EQ.2) RETURN
+      T2 = FNU + DBLE(FLOAT(KK-1))
+      CKR = T2*RZR
+      CKI = T2*RZI
+      KFLAG = 1
+      GO TO 250
+  290 CONTINUE
+C-----------------------------------------------------------------------
+C     SCALE BY DEXP(Z), IFLAG = 1 CASES
+C-----------------------------------------------------------------------
+      KODED = 2
+      IFLAG = 1
+      KFLAG = 2
+      GO TO 120
+C-----------------------------------------------------------------------
+C     FNU=HALF ODD INTEGER CASE, DNU=-0.5
+C-----------------------------------------------------------------------
+  300 CONTINUE
+      S1R = COEFR
+      S1I = COEFI
+      S2R = COEFR
+      S2I = COEFI
+      GO TO 210
+C
+C
+  310 CONTINUE
+      NZ=-2
+      RETURN
+      END

amos/zbuni.f

@@ -0,0 +1,174 @@
+      SUBROUTINE ZBUNI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NUI, NLAST,
+     * FNUL, TOL, ELIM, ALIM)
+C***BEGIN PROLOGUE  ZBUNI
+C***REFER TO  ZBESI,ZBESK
+C
+C     ZBUNI COMPUTES THE I BESSEL FUNCTION FOR LARGE CABS(Z).GT.
+C     FNUL AND FNU+N-1.LT.FNUL. THE ORDER IS INCREASED FROM
+C     FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING
+C     ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z)
+C     ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2
+C
+C***ROUTINES CALLED  ZUNI1,ZUNI2,ZABS,D1MACH
+C***END PROLOGUE  ZBUNI
+C     COMPLEX CSCL,CSCR,CY,RZ,ST,S1,S2,Y,Z
+      DOUBLE PRECISION ALIM, AX, AY, CSCLR, CSCRR, CYI, CYR, DFNU,
+     * ELIM, FNU, FNUI, FNUL, GNU, RAZ, RZI, RZR, STI, STR, S1I, S1R,
+     * S2I, S2R, TOL, YI, YR, ZI, ZR, ZABS, ASCLE, BRY, C1R, C1I, C1M,
+     * D1MACH
+      INTEGER I, IFLAG, IFORM, K, KODE, N, NL, NLAST, NUI, NW, NZ
+      DIMENSION YR(N), YI(N), CYR(2), CYI(2), BRY(3)
+      NZ = 0
+      AX = DABS(ZR)*1.7321D0
+      AY = DABS(ZI)
+      IFORM = 1
+      IF (AY.GT.AX) IFORM = 2
+      IF (NUI.EQ.0) GO TO 60
+      FNUI = DBLE(FLOAT(NUI))
+      DFNU = FNU + DBLE(FLOAT(N-1))
+      GNU = DFNU + FNUI
+      IF (IFORM.EQ.2) GO TO 10
+C-----------------------------------------------------------------------
+C     ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN
+C     -PI/3.LE.ARG(Z).LE.PI/3
+C-----------------------------------------------------------------------
+      CALL ZUNI1(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL,
+     * ELIM, ALIM)
+      GO TO 20
+   10 CONTINUE
+C-----------------------------------------------------------------------
+C     ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU
+C     APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I
+C     AND HPI=PI/2
+C-----------------------------------------------------------------------
+      CALL ZUNI2(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL,
+     * ELIM, ALIM)
+   20 CONTINUE
+      IF (NW.LT.0) GO TO 50
+      IF (NW.NE.0) GO TO 90
+      STR = ZABS(COMPLEX(CYR(1),CYI(1)))
+C----------------------------------------------------------------------
+C     SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER USED
+C----------------------------------------------------------------------
+      BRY(1)=1.0D+3*D1MACH(1)/TOL
+      BRY(2) = 1.0D0/BRY(1)
+      BRY(3) = BRY(2)
+      IFLAG = 2
+      ASCLE = BRY(2)
+      CSCLR = 1.0D0
+      IF (STR.GT.BRY(1)) GO TO 21
+      IFLAG = 1
+      ASCLE = BRY(1)
+      CSCLR = 1.0D0/TOL
+      GO TO 25
+   21 CONTINUE
+      IF (STR.LT.BRY(2)) GO TO 25
+      IFLAG = 3
+      ASCLE=BRY(3)
+      CSCLR = TOL
+   25 CONTINUE
+      CSCRR = 1.0D0/CSCLR
+      S1R = CYR(2)*CSCLR
+      S1I = CYI(2)*CSCLR
+      S2R = CYR(1)*CSCLR
+      S2I = CYI(1)*CSCLR
+      RAZ = 1.0D0/ZABS(COMPLEX(ZR,ZI))
+      STR = ZR*RAZ
+      STI = -ZI*RAZ
+      RZR = (STR+STR)*RAZ
+      RZI = (STI+STI)*RAZ
+      DO 30 I=1,NUI
+        STR = S2R
+        STI = S2I
+        S2R = (DFNU+FNUI)*(RZR*STR-RZI*STI) + S1R
+        S2I = (DFNU+FNUI)*(RZR*STI+RZI*STR) + S1I
+        S1R = STR
+        S1I = STI
+        FNUI = FNUI - 1.0D0
+        IF (IFLAG.GE.3) GO TO 30
+        STR = S2R*CSCRR
+        STI = S2I*CSCRR
+        C1R = DABS(STR)
+        C1I = DABS(STI)
+        C1M = DMAX1(C1R,C1I)
+        IF (C1M.LE.ASCLE) GO TO 30
+        IFLAG = IFLAG+1
+        ASCLE = BRY(IFLAG)
+        S1R = S1R*CSCRR
+        S1I = S1I*CSCRR
+        S2R = STR
+        S2I = STI
+        CSCLR = CSCLR*TOL
+        CSCRR = 1.0D0/CSCLR
+        S1R = S1R*CSCLR
+        S1I = S1I*CSCLR
+        S2R = S2R*CSCLR
+        S2I = S2I*CSCLR
+   30 CONTINUE
+      YR(N) = S2R*CSCRR
+      YI(N) = S2I*CSCRR
+      IF (N.EQ.1) RETURN
+      NL = N - 1
+      FNUI = DBLE(FLOAT(NL))
+      K = NL
+      DO 40 I=1,NL
+        STR = S2R
+        STI = S2I
+        S2R = (FNU+FNUI)*(RZR*STR-RZI*STI) + S1R
+        S2I = (FNU+FNUI)*(RZR*STI+RZI*STR) + S1I
+        S1R = STR
+        S1I = STI
+        STR = S2R*CSCRR
+        STI = S2I*CSCRR
+        YR(K) = STR
+        YI(K) = STI
+        FNUI = FNUI - 1.0D0
+        K = K - 1
+        IF (IFLAG.GE.3) GO TO 40
+        C1R = DABS(STR)
+        C1I = DABS(STI)
+        C1M = DMAX1(C1R,C1I)
+        IF (C1M.LE.ASCLE) GO TO 40
+        IFLAG = IFLAG+1
+        ASCLE = BRY(IFLAG)
+        S1R = S1R*CSCRR
+        S1I = S1I*CSCRR
+        S2R = STR
+        S2I = STI
+        CSCLR = CSCLR*TOL
+        CSCRR = 1.0D0/CSCLR
+        S1R = S1R*CSCLR
+        S1I = S1I*CSCLR
+        S2R = S2R*CSCLR
+        S2I = S2I*CSCLR
+   40 CONTINUE
+      RETURN
+   50 CONTINUE
+      NZ = -1
+      IF(NW.EQ.(-2)) NZ=-2
+      RETURN
+   60 CONTINUE
+      IF (IFORM.EQ.2) GO TO 70
+C-----------------------------------------------------------------------
+C     ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN
+C     -PI/3.LE.ARG(Z).LE.PI/3
+C-----------------------------------------------------------------------
+      CALL ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL,
+     * ELIM, ALIM)
+      GO TO 80
+   70 CONTINUE
+C-----------------------------------------------------------------------
+C     ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU
+C     APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I
+C     AND HPI=PI/2
+C-----------------------------------------------------------------------
+      CALL ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL,
+     * ELIM, ALIM)
+   80 CONTINUE
+      IF (NW.LT.0) GO TO 50
+      NZ = NW
+      RETURN
+   90 CONTINUE
+      NLAST = N
+      RETURN
+      END

amos/zbunk.f

@@ -0,0 +1,35 @@
+      SUBROUTINE ZBUNK(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM,
+     * ALIM)
+C***BEGIN PROLOGUE  ZBUNK
+C***REFER TO  ZBESK,ZBESH
+C
+C     ZBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU.GT.FNUL.
+C     ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z)
+C     IN ZUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN ZUNK2
+C
+C***ROUTINES CALLED  ZUNK1,ZUNK2
+C***END PROLOGUE  ZBUNK
+C     COMPLEX Y,Z
+      DOUBLE PRECISION ALIM, AX, AY, ELIM, FNU, TOL, YI, YR, ZI, ZR
+      INTEGER KODE, MR, N, NZ
+      DIMENSION YR(N), YI(N)
+      NZ = 0
+      AX = DABS(ZR)*1.7321D0
+      AY = DABS(ZI)
+      IF (AY.GT.AX) GO TO 10
+C-----------------------------------------------------------------------
+C     ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN
+C     -PI/3.LE.ARG(Z).LE.PI/3
+C-----------------------------------------------------------------------
+      CALL ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM)
+      GO TO 20
+   10 CONTINUE
+C-----------------------------------------------------------------------
+C     ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU
+C     APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I
+C     AND HPI=PI/2
+C-----------------------------------------------------------------------
+      CALL ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM)
+   20 CONTINUE
+      RETURN
+      END

amos/zdiv.f

@@ -0,0 +1,19 @@
+      SUBROUTINE ZDIV(AR, AI, BR, BI, CR, CI)
+C***BEGIN PROLOGUE  ZDIV
+C***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
+C
+C     DOUBLE PRECISION COMPLEX DIVIDE C=A/B.
+C
+C***ROUTINES CALLED  ZABS
+C***END PROLOGUE  ZDIV
+      DOUBLE PRECISION AR, AI, BR, BI, CR, CI, BM, CA, CB, CC, CD
+      DOUBLE PRECISION ZABS
+      BM = 1.0D0/ZABS(COMPLEX(BR,BI))
+      CC = BR*BM
+      CD = BI*BM
+      CA = (AR*CC+AI*CD)*BM
+      CB = (AI*CC-AR*CD)*BM
+      CR = CA
+      CI = CB
+      RETURN
+      END

amos/zexp.f

@@ -0,0 +1,16 @@
+      SUBROUTINE ZEXP(AR, AI, BR, BI)
+C***BEGIN PROLOGUE  ZEXP
+C***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
+C
+C     DOUBLE PRECISION COMPLEX EXPONENTIAL FUNCTION B=EXP(A)
+C
+C***ROUTINES CALLED  (NONE)
+C***END PROLOGUE  ZEXP
+      DOUBLE PRECISION AR, AI, BR, BI, ZM, CA, CB
+      ZM = DEXP(AR)
+      CA = ZM*DCOS(AI)
+      CB = ZM*DSIN(AI)
+      BR = CA
+      BI = CB
+      RETURN
+      END

amos/zkscl.f

@@ -0,0 +1,121 @@
+      SUBROUTINE ZKSCL(ZRR,ZRI,FNU,N,YR,YI,NZ,RZR,RZI,ASCLE,TOL,ELIM)
+C***BEGIN PROLOGUE  ZKSCL
+C***REFER TO  ZBESK
+C
+C     SET K FUNCTIONS TO ZERO ON UNDERFLOW, CONTINUE RECURRENCE
+C     ON SCALED FUNCTIONS UNTIL TWO MEMBERS COME ON SCALE, THEN
+C     RETURN WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL.
+C
+C***ROUTINES CALLED  ZUCHK,ZABS,ZLOG
+C***END PROLOGUE  ZKSCL
+C     COMPLEX CK,CS,CY,CZERO,RZ,S1,S2,Y,ZR,ZD,CELM
+      DOUBLE PRECISION ACS, AS, ASCLE, CKI, CKR, CSI, CSR, CYI,
+     * CYR, ELIM, FN, FNU, RZI, RZR, STR, S1I, S1R, S2I,
+     * S2R, TOL, YI, YR, ZEROI, ZEROR, ZRI, ZRR, ZABS,
+     * ZDR, ZDI, CELMR, ELM, HELIM, ALAS
+      INTEGER I, IC, IDUM, KK, N, NN, NW, NZ
+      DIMENSION YR(N), YI(N), CYR(2), CYI(2)
+      DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 /
+C
+      NZ = 0
+      IC = 0
+      NN = MIN0(2,N)
+      DO 10 I=1,NN
+        S1R = YR(I)
+        S1I = YI(I)
+        CYR(I) = S1R
+        CYI(I) = S1I
+        AS = ZABS(COMPLEX(S1R,S1I))
+        ACS = -ZRR + DLOG(AS)
+        NZ = NZ + 1
+        YR(I) = ZEROR
+        YI(I) = ZEROI
+        IF (ACS.LT.(-ELIM)) GO TO 10
+        CALL ZLOG(S1R, S1I, CSR, CSI, IDUM)
+        CSR = CSR - ZRR
+        CSI = CSI - ZRI
+        STR = DEXP(CSR)/TOL
+        CSR = STR*DCOS(CSI)
+        CSI = STR*DSIN(CSI)
+        CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL)
+        IF (NW.NE.0) GO TO 10
+        YR(I) = CSR
+        YI(I) = CSI
+        IC = I
+        NZ = NZ - 1
+   10 CONTINUE
+      IF (N.EQ.1) RETURN
+      IF (IC.GT.1) GO TO 20
+      YR(1) = ZEROR
+      YI(1) = ZEROI
+      NZ = 2
+   20 CONTINUE
+      IF (N.EQ.2) RETURN
+      IF (NZ.EQ.0) RETURN
+      FN = FNU + 1.0D0
+      CKR = FN*RZR
+      CKI = FN*RZI
+      S1R = CYR(1)
+      S1I = CYI(1)
+      S2R = CYR(2)
+      S2I = CYI(2)
+      HELIM = 0.5D0*ELIM
+      ELM = DEXP(-ELIM)
+      CELMR = ELM
+      ZDR = ZRR
+      ZDI = ZRI
+C
+C     FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE RECURRENCE IF
+C     S2 GETS LARGER THAN EXP(ELIM/2)
+C
+      DO 30 I=3,N
+        KK = I
+        CSR = S2R
+        CSI = S2I
+        S2R = CKR*CSR - CKI*CSI + S1R
+        S2I = CKI*CSR + CKR*CSI + S1I
+        S1R = CSR
+        S1I = CSI
+        CKR = CKR + RZR
+        CKI = CKI + RZI
+        AS = ZABS(COMPLEX(S2R,S2I))
+        ALAS = DLOG(AS)
+        ACS = -ZDR + ALAS
+        NZ = NZ + 1
+        YR(I) = ZEROR
+        YI(I) = ZEROI
+        IF (ACS.LT.(-ELIM)) GO TO 25
+        CALL ZLOG(S2R, S2I, CSR, CSI, IDUM)
+        CSR = CSR - ZDR
+        CSI = CSI - ZDI
+        STR = DEXP(CSR)/TOL
+        CSR = STR*DCOS(CSI)
+        CSI = STR*DSIN(CSI)
+        CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL)
+        IF (NW.NE.0) GO TO 25
+        YR(I) = CSR
+        YI(I) = CSI
+        NZ = NZ - 1
+        IF (IC.EQ.KK-1) GO TO 40
+        IC = KK
+        GO TO 30
+   25   CONTINUE
+        IF(ALAS.LT.HELIM) GO TO 30
+        ZDR = ZDR - ELIM
+        S1R = S1R*CELMR
+        S1I = S1I*CELMR
+        S2R = S2R*CELMR
+        S2I = S2I*CELMR
+   30 CONTINUE
+      NZ = N
+      IF(IC.EQ.N) NZ=N-1
+      GO TO 45
+   40 CONTINUE
+      NZ = KK - 2
+   45 CONTINUE
+      DO 50 I=1,NZ
+        YR(I) = ZEROR
+        YI(I) = ZEROI
+   50 CONTINUE
+      RETURN
+      END

amos/zlog.f

@@ -0,0 +1,41 @@
+      SUBROUTINE ZLOG(AR, AI, BR, BI, IERR)
+C***BEGIN PROLOGUE  ZLOG
+C***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
+C
+C     DOUBLE PRECISION COMPLEX LOGARITHM B=CLOG(A)
+C     IERR=0,NORMAL RETURN      IERR=1, Z=CMPLX(0.0,0.0)
+C***ROUTINES CALLED  ZABS
+C***END PROLOGUE  ZLOG
+      DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DHPI
+      DOUBLE PRECISION ZABS
+      DATA DPI , DHPI  / 3.141592653589793238462643383D+0,
+     1                   1.570796326794896619231321696D+0/
+C
+      IERR=0
+      IF (AR.EQ.0.0D+0) GO TO 10
+      IF (AI.EQ.0.0D+0) GO TO 20
+      DTHETA = DATAN(AI/AR)
+      IF (DTHETA.LE.0.0D+0) GO TO 40
+      IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI
+      GO TO 50
+   10 IF (AI.EQ.0.0D+0) GO TO 60
+      BI = DHPI
+      BR = DLOG(DABS(AI))
+      IF (AI.LT.0.0D+0) BI = -BI
+      RETURN
+   20 IF (AR.GT.0.0D+0) GO TO 30
+      BR = DLOG(DABS(AR))
+      BI = DPI
+      RETURN
+   30 BR = DLOG(AR)
+      BI = 0.0D+0
+      RETURN
+   40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI
+   50 ZM = ZABS(COMPLEX(AR,AI))
+      BR = DLOG(ZM)
+      BI = DTHETA
+      RETURN
+   60 CONTINUE
+      IERR=1
+      RETURN
+      END

amos/zmlri.f

@@ -0,0 +1,204 @@
+      SUBROUTINE ZMLRI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL)
+C***BEGIN PROLOGUE  ZMLRI
+C***REFER TO  ZBESI,ZBESK
+C
+C     ZMLRI COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY THE
+C     MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES.
+C
+C***ROUTINES CALLED  DGAMLN,D1MACH,ZABS,ZEXP,ZLOG,ZMLT
+C***END PROLOGUE  ZMLRI
+C     COMPLEX CK,CNORM,CONE,CTWO,CZERO,PT,P1,P2,RZ,SUM,Y,Z
+      DOUBLE PRECISION ACK, AK, AP, AT, AZ, BK, CKI, CKR, CNORMI,
+     * CNORMR, CONEI, CONER, FKAP, FKK, FLAM, FNF, FNU, PTI, PTR, P1I,
+     * P1R, P2I, P2R, RAZ, RHO, RHO2, RZI, RZR, SCLE, STI, STR, SUMI,
+     * SUMR, TFNF, TOL, TST, YI, YR, ZEROI, ZEROR, ZI, ZR, DGAMLN,
+     * D1MACH, ZABS
+      INTEGER I, IAZ, IDUM, IFNU, INU, ITIME, K, KK, KM, KODE, M, N, NZ
+      DIMENSION YR(N), YI(N)
+      DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
+      SCLE = D1MACH(1)/TOL
+      NZ=0
+      AZ = ZABS(COMPLEX(ZR,ZI))
+      IAZ = INT(SNGL(AZ))
+      IFNU = INT(SNGL(FNU))
+      INU = IFNU + N - 1
+      AT = DBLE(FLOAT(IAZ)) + 1.0D0
+      RAZ = 1.0D0/AZ
+      STR = ZR*RAZ
+      STI = -ZI*RAZ
+      CKR = STR*AT*RAZ
+      CKI = STI*AT*RAZ
+      RZR = (STR+STR)*RAZ
+      RZI = (STI+STI)*RAZ
+      P1R = ZEROR
+      P1I = ZEROI
+      P2R = CONER
+      P2I = CONEI
+      ACK = (AT+1.0D0)*RAZ
+      RHO = ACK + DSQRT(ACK*ACK-1.0D0)
+      RHO2 = RHO*RHO
+      TST = (RHO2+RHO2)/((RHO2-1.0D0)*(RHO-1.0D0))
+      TST = TST/TOL
+C-----------------------------------------------------------------------
+C     COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES
+C-----------------------------------------------------------------------
+      AK = AT
+      DO 10 I=1,80
+        PTR = P2R
+        PTI = P2I
+        P2R = P1R - (CKR*PTR-CKI*PTI)
+        P2I = P1I - (CKI*PTR+CKR*PTI)
+        P1R = PTR
+        P1I = PTI
+        CKR = CKR + RZR
+        CKI = CKI + RZI
+        AP = ZABS(COMPLEX(P2R,P2I))
+        IF (AP.GT.TST*AK*AK) GO TO 20
+        AK = AK + 1.0D0
+   10 CONTINUE
+      GO TO 110
+   20 CONTINUE
+      I = I + 1
+      K = 0
+      IF (INU.LT.IAZ) GO TO 40
+C-----------------------------------------------------------------------
+C     COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS
+C-----------------------------------------------------------------------
+      P1R = ZEROR
+      P1I = ZEROI
+      P2R = CONER
+      P2I = CONEI
+      AT = DBLE(FLOAT(INU)) + 1.0D0
+      STR = ZR*RAZ
+      STI = -ZI*RAZ
+      CKR = STR*AT*RAZ
+      CKI = STI*AT*RAZ
+      ACK = AT*RAZ
+      TST = DSQRT(ACK/TOL)
+      ITIME = 1
+      DO 30 K=1,80
+        PTR = P2R
+        PTI = P2I
+        P2R = P1R - (CKR*PTR-CKI*PTI)
+        P2I = P1I - (CKR*PTI+CKI*PTR)
+        P1R = PTR
+        P1I = PTI
+        CKR = CKR + RZR
+        CKI = CKI + RZI
+        AP = ZABS(COMPLEX(P2R,P2I))
+        IF (AP.LT.TST) GO TO 30
+        IF (ITIME.EQ.2) GO TO 40
+        ACK = ZABS(COMPLEX(CKR,CKI))
+        FLAM = ACK + DSQRT(ACK*ACK-1.0D0)
+        FKAP = AP/ZABS(COMPLEX(P1R,P1I))
+        RHO = DMIN1(FLAM,FKAP)
+        TST = TST*DSQRT(RHO/(RHO*RHO-1.0D0))
+        ITIME = 2
+   30 CONTINUE
+      GO TO 110
+   40 CONTINUE
+C-----------------------------------------------------------------------
+C     BACKWARD RECURRENCE AND SUM NORMALIZING RELATION
+C-----------------------------------------------------------------------
+      K = K + 1
+      KK = MAX0(I+IAZ,K+INU)
+      FKK = DBLE(FLOAT(KK))
+      P1R = ZEROR
+      P1I = ZEROI
+C-----------------------------------------------------------------------
+C     SCALE P2 AND SUM BY SCLE
+C-----------------------------------------------------------------------
+      P2R = SCLE
+      P2I = ZEROI
+      FNF = FNU - DBLE(FLOAT(IFNU))
+      TFNF = FNF + FNF
+      BK = DGAMLN(FKK+TFNF+1.0D0,IDUM) - DGAMLN(FKK+1.0D0,IDUM) -
+     * DGAMLN(TFNF+1.0D0,IDUM)
+      BK = DEXP(BK)
+      SUMR = ZEROR
+      SUMI = ZEROI
+      KM = KK - INU
+      DO 50 I=1,KM
+        PTR = P2R
+        PTI = P2I
+        P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI)
+        P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI)
+        P1R = PTR
+        P1I = PTI
+        AK = 1.0D0 - TFNF/(FKK+TFNF)
+        ACK = BK*AK
+        SUMR = SUMR + (ACK+BK)*P1R
+        SUMI = SUMI + (ACK+BK)*P1I
+        BK = ACK
+        FKK = FKK - 1.0D0
+   50 CONTINUE
+      YR(N) = P2R
+      YI(N) = P2I
+      IF (N.EQ.1) GO TO 70
+      DO 60 I=2,N
+        PTR = P2R
+        PTI = P2I
+        P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI)
+        P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI)
+        P1R = PTR
+        P1I = PTI
+        AK = 1.0D0 - TFNF/(FKK+TFNF)
+        ACK = BK*AK
+        SUMR = SUMR + (ACK+BK)*P1R
+        SUMI = SUMI + (ACK+BK)*P1I
+        BK = ACK
+        FKK = FKK - 1.0D0
+        M = N - I + 1
+        YR(M) = P2R
+        YI(M) = P2I
+   60 CONTINUE
+   70 CONTINUE
+      IF (IFNU.LE.0) GO TO 90
+      DO 80 I=1,IFNU
+        PTR = P2R
+        PTI = P2I
+        P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI)
+        P2I = P1I + (FKK+FNF)*(RZR*PTI+RZI*PTR)
+        P1R = PTR
+        P1I = PTI
+        AK = 1.0D0 - TFNF/(FKK+TFNF)
+        ACK = BK*AK
+        SUMR = SUMR + (ACK+BK)*P1R
+        SUMI = SUMI + (ACK+BK)*P1I
+        BK = ACK
+        FKK = FKK - 1.0D0
+   80 CONTINUE
+   90 CONTINUE
+      PTR = ZR
+      PTI = ZI
+      IF (KODE.EQ.2) PTR = ZEROR
+      CALL ZLOG(RZR, RZI, STR, STI, IDUM)
+      P1R = -FNF*STR + PTR
+      P1I = -FNF*STI + PTI
+      AP = DGAMLN(1.0D0+FNF,IDUM)
+      PTR = P1R - AP
+      PTI = P1I
+C-----------------------------------------------------------------------
+C     THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW
+C     IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES
+C-----------------------------------------------------------------------
+      P2R = P2R + SUMR
+      P2I = P2I + SUMI
+      AP = ZABS(COMPLEX(P2R,P2I))
+      P1R = 1.0D0/AP
+      CALL ZEXP(PTR, PTI, STR, STI)
+      CKR = STR*P1R
+      CKI = STI*P1R
+      PTR = P2R*P1R
+      PTI = -P2I*P1R
+      CALL ZMLT(CKR, CKI, PTR, PTI, CNORMR, CNORMI)
+      DO 100 I=1,N
+        STR = YR(I)*CNORMR - YI(I)*CNORMI
+        YI(I) = YR(I)*CNORMI + YI(I)*CNORMR
+        YR(I) = STR
+  100 CONTINUE
+      RETURN
+  110 CONTINUE
+      NZ=-2
+      RETURN
+      END

amos/zmlt.f

@@ -0,0 +1,15 @@
+      SUBROUTINE ZMLT(AR, AI, BR, BI, CR, CI)
+C***BEGIN PROLOGUE  ZMLT
+C***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
+C
+C     DOUBLE PRECISION COMPLEX MULTIPLY, C=A*B.
+C
+C***ROUTINES CALLED  (NONE)
+C***END PROLOGUE  ZMLT
+      DOUBLE PRECISION AR, AI, BR, BI, CR, CI, CA, CB
+      CA = AR*BR - AI*BI
+      CB = AR*BI + AI*BR
+      CR = CA
+      CI = CB
+      RETURN
+      END

amos/zrati.f

@@ -0,0 +1,132 @@
+      SUBROUTINE ZRATI(ZR, ZI, FNU, N, CYR, CYI, TOL)
+C***BEGIN PROLOGUE  ZRATI
+C***REFER TO  ZBESI,ZBESK,ZBESH
+C
+C     ZRATI COMPUTES RATIOS OF I BESSEL FUNCTIONS BY BACKWARD
+C     RECURRENCE.  THE STARTING INDEX IS DETERMINED BY FORWARD
+C     RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B,
+C     MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973,
+C     BESSEL FUNCTIONS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER,
+C     BY D. J. SOOKNE.
+C
+C***ROUTINES CALLED  ZABS,ZDIV
+C***END PROLOGUE  ZRATI
+C     COMPLEX Z,CY(1),CONE,CZERO,P1,P2,T1,RZ,PT,CDFNU
+      DOUBLE PRECISION AK, AMAGZ, AP1, AP2, ARG, AZ, CDFNUI, CDFNUR,
+     * CONEI, CONER, CYI, CYR, CZEROI, CZEROR, DFNU, FDNU, FLAM, FNU,
+     * FNUP, PTI, PTR, P1I, P1R, P2I, P2R, RAK, RAP1, RHO, RT2, RZI,
+     * RZR, TEST, TEST1, TOL, TTI, TTR, T1I, T1R, ZI, ZR, ZABS
+      INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ, N
+      DIMENSION CYR(N), CYI(N)
+      DATA CZEROR,CZEROI,CONER,CONEI,RT2/
+     1 0.0D0, 0.0D0, 1.0D0, 0.0D0, 1.41421356237309505D0 /
+      AZ = ZABS(COMPLEX(ZR,ZI))
+      INU = INT(SNGL(FNU))
+      IDNU = INU + N - 1
+      MAGZ = INT(SNGL(AZ))
+      AMAGZ = DBLE(FLOAT(MAGZ+1))
+      FDNU = DBLE(FLOAT(IDNU))
+      FNUP = DMAX1(AMAGZ,FDNU)
+      ID = IDNU - MAGZ - 1
+      ITIME = 1
+      K = 1
+      PTR = 1.0D0/AZ
+      RZR = PTR*(ZR+ZR)*PTR
+      RZI = -PTR*(ZI+ZI)*PTR
+      T1R = RZR*FNUP
+      T1I = RZI*FNUP
+      P2R = -T1R
+      P2I = -T1I
+      P1R = CONER
+      P1I = CONEI
+      T1R = T1R + RZR
+      T1I = T1I + RZI
+      IF (ID.GT.0) ID = 0
+      AP2 = ZABS(COMPLEX(P2R,P2I))
+      AP1 = ZABS(COMPLEX(P1R,P1I))
+C-----------------------------------------------------------------------
+C     THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNU
+C     GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT
+C     P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR
+C     PREMATURELY.
+C-----------------------------------------------------------------------
+      ARG = (AP2+AP2)/(AP1*TOL)
+      TEST1 = DSQRT(ARG)
+      TEST = TEST1
+      RAP1 = 1.0D0/AP1
+      P1R = P1R*RAP1
+      P1I = P1I*RAP1
+      P2R = P2R*RAP1
+      P2I = P2I*RAP1
+      AP2 = AP2*RAP1
+   10 CONTINUE
+      K = K + 1
+      AP1 = AP2
+      PTR = P2R
+      PTI = P2I
+      P2R = P1R - (T1R*PTR-T1I*PTI)
+      P2I = P1I - (T1R*PTI+T1I*PTR)
+      P1R = PTR
+      P1I = PTI
+      T1R = T1R + RZR
+      T1I = T1I + RZI
+      AP2 = ZABS(COMPLEX(P2R,P2I))
+      IF (AP1.LE.TEST) GO TO 10
+      IF (ITIME.EQ.2) GO TO 20
+      AK = ZABS(COMPLEX(T1R,T1I)*0.5D0)
+      FLAM = AK + DSQRT(AK*AK-1.0D0)
+      RHO = DMIN1(AP2/AP1,FLAM)
+      TEST = TEST1*DSQRT(RHO/(RHO*RHO-1.0D0))
+      ITIME = 2
+      GO TO 10
+   20 CONTINUE
+      KK = K + 1 - ID
+      AK = DBLE(FLOAT(KK))
+      T1R = AK
+      T1I = CZEROI
+      DFNU = FNU + DBLE(FLOAT(N-1))
+      P1R = 1.0D0/AP2
+      P1I = CZEROI
+      P2R = CZEROR
+      P2I = CZEROI
+      DO 30 I=1,KK
+        PTR = P1R
+        PTI = P1I
+        RAP1 = DFNU + T1R
+        TTR = RZR*RAP1
+        TTI = RZI*RAP1
+        P1R = (PTR*TTR-PTI*TTI) + P2R
+        P1I = (PTR*TTI+PTI*TTR) + P2I
+        P2R = PTR
+        P2I = PTI
+        T1R = T1R - CONER
+   30 CONTINUE
+      IF (P1R.NE.CZEROR .OR. P1I.NE.CZEROI) GO TO 40
+      P1R = TOL
+      P1I = TOL
+   40 CONTINUE
+      CALL ZDIV(P2R, P2I, P1R, P1I, CYR(N), CYI(N))
+      IF (N.EQ.1) RETURN
+      K = N - 1
+      AK = DBLE(FLOAT(K))
+      T1R = AK
+      T1I = CZEROI
+      CDFNUR = FNU*RZR
+      CDFNUI = FNU*RZI
+      DO 60 I=2,N
+        PTR = CDFNUR + (T1R*RZR-T1I*RZI) + CYR(K+1)
+        PTI = CDFNUI + (T1R*RZI+T1I*RZR) + CYI(K+1)
+        AK = ZABS(COMPLEX(PTR,PTI))
+        IF (AK.NE.CZEROR) GO TO 50
+        PTR = TOL
+        PTI = TOL
+        AK = TOL*RT2
+   50   CONTINUE
+        RAK = CONER/AK
+        CYR(K) = RAK*PTR*RAK
+        CYI(K) = -RAK*PTI*RAK
+        T1R = T1R - CONER
+        K = K - 1
+   60 CONTINUE
+      RETURN
+      END

amos/zs1s2.f

@@ -0,0 +1,49 @@
+      SUBROUTINE ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NZ, ASCLE, ALIM,
+     * IUF)
+C***BEGIN PROLOGUE  ZS1S2
+C***REFER TO  ZBESK,ZAIRY
+C
+C     ZS1S2 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE
+C     ADDITION OF THE I AND K FUNCTIONS IN THE ANALYTIC CON-
+C     TINUATION FORMULA WHERE S1=K FUNCTION AND S2=I FUNCTION.
+C     ON KODE=1 THE I AND K FUNCTIONS ARE DIFFERENT ORDERS OF
+C     MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER
+C     OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE
+C     PRECISION ABOVE THE UNDERFLOW LIMIT.
+C
+C***ROUTINES CALLED  ZABS,ZEXP,ZLOG
+C***END PROLOGUE  ZS1S2
+C     COMPLEX CZERO,C1,S1,S1D,S2,ZR
+      DOUBLE PRECISION AA, ALIM, ALN, ASCLE, AS1, AS2, C1I, C1R, S1DI,
+     * S1DR, S1I, S1R, S2I, S2R, ZEROI, ZEROR, ZRI, ZRR, ZABS
+      INTEGER IUF, IDUM, NZ
+      DATA ZEROR,ZEROI  / 0.0D0 , 0.0D0 /
+      NZ = 0
+      AS1 = ZABS(COMPLEX(S1R,S1I))
+      AS2 = ZABS(COMPLEX(S2R,S2I))
+      IF (S1R.EQ.0.0D0 .AND. S1I.EQ.0.0D0) GO TO 10
+      IF (AS1.EQ.0.0D0) GO TO 10
+      ALN = -ZRR - ZRR + DLOG(AS1)
+      S1DR = S1R
+      S1DI = S1I
+      S1R = ZEROR
+      S1I = ZEROI
+      AS1 = ZEROR
+      IF (ALN.LT.(-ALIM)) GO TO 10
+      CALL ZLOG(S1DR, S1DI, C1R, C1I, IDUM)
+      C1R = C1R - ZRR - ZRR
+      C1I = C1I - ZRI - ZRI
+      CALL ZEXP(C1R, C1I, S1R, S1I)
+      AS1 = ZABS(COMPLEX(S1R,S1I))
+      IUF = IUF + 1
+   10 CONTINUE
+      AA = DMAX1(AS1,AS2)
+      IF (AA.GT.ASCLE) RETURN
+      S1R = ZEROR
+      S1I = ZEROI
+      S2R = ZEROR
+      S2I = ZEROI
+      NZ = 1
+      IUF = 0
+      RETURN
+      END

amos/zseri.f

@@ -0,0 +1,190 @@
+      SUBROUTINE ZSERI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM,
+     * ALIM)
+C***BEGIN PROLOGUE  ZSERI
+C***REFER TO  ZBESI,ZBESK
+C
+C     ZSERI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY
+C     MEANS OF THE POWER SERIES FOR LARGE CABS(Z) IN THE
+C     REGION CABS(Z).LE.2*SQRT(FNU+1). NZ=0 IS A NORMAL RETURN.
+C     NZ.GT.0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO
+C     DUE TO UNDERFLOW. NZ.LT.0 MEANS UNDERFLOW OCCURRED, BUT THE
+C     CONDITION CABS(Z).LE.2*SQRT(FNU+1) WAS VIOLATED AND THE
+C     COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ).
+C
+C***ROUTINES CALLED  DGAMLN,D1MACH,ZUCHK,ZABS,ZDIV,ZLOG,ZMLT
+C***END PROLOGUE  ZSERI
+C     COMPLEX AK1,CK,COEF,CONE,CRSC,CSCL,CZ,CZERO,HZ,RZ,S1,S2,Y,Z
+      DOUBLE PRECISION AA, ACZ, AK, AK1I, AK1R, ALIM, ARM, ASCLE, ATOL,
+     * AZ, CKI, CKR, COEFI, COEFR, CONEI, CONER, CRSCR, CZI, CZR, DFNU,
+     * ELIM, FNU, FNUP, HZI, HZR, RAZ, RS, RTR1, RZI, RZR, S, SS, STI,
+     * STR, S1I, S1R, S2I, S2R, TOL, YI, YR, WI, WR, ZEROI, ZEROR, ZI,
+     * ZR, DGAMLN, D1MACH, ZABS
+      INTEGER I, IB, IDUM, IFLAG, IL, K, KODE, L, M, N, NN, NZ, NW
+      DIMENSION YR(N), YI(N), WR(2), WI(2)
+      DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
+C
+      NZ = 0
+      AZ = ZABS(COMPLEX(ZR,ZI))
+      IF (AZ.EQ.0.0D0) GO TO 160
+      ARM = 1.0D+3*D1MACH(1)
+      RTR1 = DSQRT(ARM)
+      CRSCR = 1.0D0
+      IFLAG = 0
+      IF (AZ.LT.ARM) GO TO 150
+      HZR = 0.5D0*ZR
+      HZI = 0.5D0*ZI
+      CZR = ZEROR
+      CZI = ZEROI
+      IF (AZ.LE.RTR1) GO TO 10
+      CALL ZMLT(HZR, HZI, HZR, HZI, CZR, CZI)
+   10 CONTINUE
+      ACZ = ZABS(COMPLEX(CZR,CZI))
+      NN = N
+      CALL ZLOG(HZR, HZI, CKR, CKI, IDUM)
+   20 CONTINUE
+      DFNU = FNU + DBLE(FLOAT(NN-1))
+      FNUP = DFNU + 1.0D0
+C-----------------------------------------------------------------------
+C     UNDERFLOW TEST
+C-----------------------------------------------------------------------
+      AK1R = CKR*DFNU
+      AK1I = CKI*DFNU
+      AK = DGAMLN(FNUP,IDUM)
+      AK1R = AK1R - AK
+      IF (KODE.EQ.2) AK1R = AK1R - ZR
+      IF (AK1R.GT.(-ELIM)) GO TO 40
+   30 CONTINUE
+      NZ = NZ + 1
+      YR(NN) = ZEROR
+      YI(NN) = ZEROI
+      IF (ACZ.GT.DFNU) GO TO 190
+      NN = NN - 1
+      IF (NN.EQ.0) RETURN
+      GO TO 20
+   40 CONTINUE
+      IF (AK1R.GT.(-ALIM)) GO TO 50
+      IFLAG = 1
+      SS = 1.0D0/TOL
+      CRSCR = TOL
+      ASCLE = ARM*SS
+   50 CONTINUE
+      AA = DEXP(AK1R)
+      IF (IFLAG.EQ.1) AA = AA*SS
+      COEFR = AA*DCOS(AK1I)
+      COEFI = AA*DSIN(AK1I)
+      ATOL = TOL*ACZ/FNUP
+      IL = MIN0(2,NN)
+      DO 90 I=1,IL
+        DFNU = FNU + DBLE(FLOAT(NN-I))
+        FNUP = DFNU + 1.0D0
+        S1R = CONER
+        S1I = CONEI
+        IF (ACZ.LT.TOL*FNUP) GO TO 70
+        AK1R = CONER
+        AK1I = CONEI
+        AK = FNUP + 2.0D0
+        S = FNUP
+        AA = 2.0D0
+   60   CONTINUE
+        RS = 1.0D0/S
+        STR = AK1R*CZR - AK1I*CZI
+        STI = AK1R*CZI + AK1I*CZR
+        AK1R = STR*RS
+        AK1I = STI*RS
+        S1R = S1R + AK1R
+        S1I = S1I + AK1I
+        S = S + AK
+        AK = AK + 2.0D0
+        AA = AA*ACZ*RS
+        IF (AA.GT.ATOL) GO TO 60
+   70   CONTINUE
+        S2R = S1R*COEFR - S1I*COEFI
+        S2I = S1R*COEFI + S1I*COEFR
+        WR(I) = S2R
+        WI(I) = S2I
+        IF (IFLAG.EQ.0) GO TO 80
+        CALL ZUCHK(S2R, S2I, NW, ASCLE, TOL)
+        IF (NW.NE.0) GO TO 30
+   80   CONTINUE
+        M = NN - I + 1
+        YR(M) = S2R*CRSCR
+        YI(M) = S2I*CRSCR
+        IF (I.EQ.IL) GO TO 90
+        CALL ZDIV(COEFR, COEFI, HZR, HZI, STR, STI)
+        COEFR = STR*DFNU
+        COEFI = STI*DFNU
+   90 CONTINUE
+      IF (NN.LE.2) RETURN
+      K = NN - 2
+      AK = DBLE(FLOAT(K))
+      RAZ = 1.0D0/AZ
+      STR = ZR*RAZ
+      STI = -ZI*RAZ
+      RZR = (STR+STR)*RAZ
+      RZI = (STI+STI)*RAZ
+      IF (IFLAG.EQ.1) GO TO 120
+      IB = 3
+  100 CONTINUE
+      DO 110 I=IB,NN
+        YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2)
+        YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2)
+        AK = AK - 1.0D0
+        K = K - 1
+  110 CONTINUE
+      RETURN
+C-----------------------------------------------------------------------
+C     RECUR BACKWARD WITH SCALED VALUES
+C-----------------------------------------------------------------------
+  120 CONTINUE
+C-----------------------------------------------------------------------
+C     EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE
+C     UNDERFLOW LIMIT = ASCLE = D1MACH(1)*SS*1.0D+3
+C-----------------------------------------------------------------------
+      S1R = WR(1)
+      S1I = WI(1)
+      S2R = WR(2)
+      S2I = WI(2)
+      DO 130 L=3,NN
+        CKR = S2R
+        CKI = S2I
+        S2R = S1R + (AK+FNU)*(RZR*CKR-RZI*CKI)
+        S2I = S1I + (AK+FNU)*(RZR*CKI+RZI*CKR)
+        S1R = CKR
+        S1I = CKI
+        CKR = S2R*CRSCR
+        CKI = S2I*CRSCR
+        YR(K) = CKR
+        YI(K) = CKI
+        AK = AK - 1.0D0
+        K = K - 1
+        IF (ZABS(COMPLEX(CKR,CKI)).GT.ASCLE) GO TO 140
+  130 CONTINUE
+      RETURN
+  140 CONTINUE
+      IB = L + 1
+      IF (IB.GT.NN) RETURN
+      GO TO 100
+  150 CONTINUE
+      NZ = N
+      IF (FNU.EQ.0.0D0) NZ = NZ - 1
+  160 CONTINUE
+      YR(1) = ZEROR
+      YI(1) = ZEROI
+      IF (FNU.NE.0.0D0) GO TO 170
+      YR(1) = CONER
+      YI(1) = CONEI
+  170 CONTINUE
+      IF (N.EQ.1) RETURN
+      DO 180 I=2,N
+        YR(I) = ZEROR
+        YI(I) = ZEROI
+  180 CONTINUE
+      RETURN
+C-----------------------------------------------------------------------
+C     RETURN WITH NZ.LT.0 IF CABS(Z*Z/4).GT.FNU+N-NZ-1 COMPLETE
+C     THE CALCULATION IN CBINU WITH N=N-IABS(NZ)
+C-----------------------------------------------------------------------
+  190 CONTINUE
+      NZ = -NZ
+      RETURN
+      END

amos/zshch.f

@@ -0,0 +1,22 @@
+      SUBROUTINE ZSHCH(ZR, ZI, CSHR, CSHI, CCHR, CCHI)
+C***BEGIN PROLOGUE  ZSHCH
+C***REFER TO  ZBESK,ZBESH
+C
+C     ZSHCH COMPUTES THE COMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y)
+C     AND CCH=COSH(X+I*Y), WHERE I**2=-1.
+C
+C***ROUTINES CALLED  (NONE)
+C***END PROLOGUE  ZSHCH
+C
+      DOUBLE PRECISION CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, ZI, ZR,
+     * DCOSH, DSINH
+      SH = DSINH(ZR)
+      CH = DCOSH(ZR)
+      SN = DSIN(ZI)
+      CN = DCOS(ZI)
+      CSHR = SH*CN
+      CSHI = CH*SN
+      CCHR = CH*CN
+      CCHI = SH*SN
+      RETURN
+      END

amos/zsqrt.f

@@ -0,0 +1,44 @@
+      SUBROUTINE ZSQRT(AR, AI, BR, BI)
+C***BEGIN PROLOGUE  ZSQRT
+C***REFER TO  ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
+C
+C     DOUBLE PRECISION COMPLEX SQUARE ROOT, B=CSQRT(A)
+C
+C***ROUTINES CALLED  ZABS
+C***END PROLOGUE  ZSQRT
+      DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DRT
+      DOUBLE PRECISION ZABS
+      DATA DRT , DPI / 7.071067811865475244008443621D-1,
+     1                 3.141592653589793238462643383D+0/
+      ZM = ZABS(COMPLEX(AR,AI))
+      ZM = DSQRT(ZM)
+      IF (AR.EQ.0.0D+0) GO TO 10
+      IF (AI.EQ.0.0D+0) GO TO 20
+      DTHETA = DATAN(AI/AR)
+      IF (DTHETA.LE.0.0D+0) GO TO 40
+      IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI
+      GO TO 50
+   10 IF (AI.GT.0.0D+0) GO TO 60
+      IF (AI.LT.0.0D+0) GO TO 70
+      BR = 0.0D+0
+      BI = 0.0D+0
+      RETURN
+   20 IF (AR.GT.0.0D+0) GO TO 30
+      BR = 0.0D+0
+      BI = DSQRT(DABS(AR))
+      RETURN
+   30 BR = DSQRT(AR)
+      BI = 0.0D+0
+      RETURN
+   40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI
+   50 DTHETA = DTHETA*0.5D+0
+      BR = ZM*DCOS(DTHETA)
+      BI = ZM*DSIN(DTHETA)
+      RETURN
+   60 BR = ZM*DRT
+      BI = ZM*DRT
+      RETURN
+   70 BR = ZM*DRT
+      BI = -ZM*DRT
+      RETURN
+      END

amos/zuchk.f

@@ -0,0 +1,28 @@
+      SUBROUTINE ZUCHK(YR, YI, NZ, ASCLE, TOL)
+C***BEGIN PROLOGUE  ZUCHK
+C***REFER TO ZSERI,ZUOIK,ZUNK1,ZUNK2,ZUNI1,ZUNI2,ZKSCL
+C
+C      Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN
+C      EXP(-ALIM)=ASCLE=1.0E+3*D1MACH(1)/TOL. THE TEST IS MADE TO SEE
+C      IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDERFLOW
+C      WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED
+C      IF THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE
+C      OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE
+C      ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED.
+C
+C***ROUTINES CALLED  (NONE)
+C***END PROLOGUE  ZUCHK
+C
+C     COMPLEX Y
+      DOUBLE PRECISION ASCLE, SS, ST, TOL, WR, WI, YR, YI
+      INTEGER NZ
+      NZ = 0
+      WR = DABS(YR)
+      WI = DABS(YI)
+      ST = DMIN1(WR,WI)
+      IF (ST.GT.ASCLE) RETURN
+      SS = DMAX1(WR,WI)
+      ST = ST/TOL
+      IF (SS.LT.ST) NZ = 1
+      RETURN
+      END

amos/zunhj.f

@@ -0,0 +1,714 @@
+      SUBROUTINE ZUNHJ(ZR, ZI, FNU, IPMTR, TOL, PHIR, PHII, ARGR, ARGI,
+     * ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI)
+C***BEGIN PROLOGUE  ZUNHJ
+C***REFER TO  ZBESI,ZBESK
+C
+C     REFERENCES
+C         HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ AND I.A.
+C         STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9.
+C
+C         ASYMPTOTICS AND SPECIAL FUNCTIONS BY F.W.J. OLVER, ACADEMIC
+C         PRESS, N.Y., 1974, PAGE 420
+C
+C     ABSTRACT
+C         ZUNHJ COMPUTES PARAMETERS FOR BESSEL FUNCTIONS C(FNU,Z) =
+C         J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU
+C         BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION
+C
+C         C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) )
+C
+C         FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS
+C         AN AIRY FUNCTION AND DAIRY IS ITS DERIVATIVE.
+C
+C               (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2,
+C
+C         ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING
+C         PURPOSES IN AIRY FUNCTIONS FROM CAIRY OR CBIRY.
+C
+C         MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND
+C         MUST BE SPECIFIED. IPMTR=0 RETURNS ALL PARAMETERS. IPMTR=
+C         1 COMPUTES ALL EXCEPT ASUM AND BSUM.
+C
+C***ROUTINES CALLED  ZABS,ZDIV,ZLOG,ZSQRT,D1MACH
+C***END PROLOGUE  ZUNHJ
+C     COMPLEX ARG,ASUM,BSUM,CFNU,CONE,CR,CZERO,DR,P,PHI,PRZTH,PTFN,
+C    *RFN13,RTZTA,RZTH,SUMA,SUMB,TFN,T2,UP,W,W2,Z,ZA,ZB,ZC,ZETA,ZETA1,
+C    *ZETA2,ZTH
+      DOUBLE PRECISION ALFA, ANG, AP, AR, ARGI, ARGR, ASUMI, ASUMR,
+     * ATOL, AW2, AZTH, BETA, BR, BSUMI, BSUMR, BTOL, C, CONEI, CONER,
+     * CRI, CRR, DRI, DRR, EX1, EX2, FNU, FN13, FN23, GAMA, GPI, HPI,
+     * PHII, PHIR, PI, PP, PR, PRZTHI, PRZTHR, PTFNI, PTFNR, RAW, RAW2,
+     * RAZTH, RFNU, RFNU2, RFN13, RTZTI, RTZTR, RZTHI, RZTHR, STI, STR,
+     * SUMAI, SUMAR, SUMBI, SUMBR, TEST, TFNI, TFNR, THPI, TOL, TZAI,
+     * TZAR, T2I, T2R, UPI, UPR, WI, WR, W2I, W2R, ZAI, ZAR, ZBI, ZBR,
+     * ZCI, ZCR, ZEROI, ZEROR, ZETAI, ZETAR, ZETA1I, ZETA1R, ZETA2I,
+     * ZETA2R, ZI, ZR, ZTHI, ZTHR, ZABS, AC, D1MACH
+      INTEGER IAS, IBS, IPMTR, IS, J, JR, JU, K, KMAX, KP1, KS, L, LR,
+     * LRP1, L1, L2, M, IDUM
+      DIMENSION AR(14), BR(14), C(105), ALFA(180), BETA(210), GAMA(30),
+     * AP(30), PR(30), PI(30), UPR(14), UPI(14), CRR(14), CRI(14),
+     * DRR(14), DRI(14)
+      DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), AR(8),
+     1     AR(9), AR(10), AR(11), AR(12), AR(13), AR(14)/
+     2     1.00000000000000000D+00,     1.04166666666666667D-01,
+     3     8.35503472222222222D-02,     1.28226574556327160D-01,
+     4     2.91849026464140464D-01,     8.81627267443757652D-01,
+     5     3.32140828186276754D+00,     1.49957629868625547D+01,
+     6     7.89230130115865181D+01,     4.74451538868264323D+02,
+     7     3.20749009089066193D+03,     2.40865496408740049D+04,
+     8     1.98923119169509794D+05,     1.79190200777534383D+06/
+      DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8),
+     1     BR(9), BR(10), BR(11), BR(12), BR(13), BR(14)/
+     2     1.00000000000000000D+00,    -1.45833333333333333D-01,
+     3    -9.87413194444444444D-02,    -1.43312053915895062D-01,
+     4    -3.17227202678413548D-01,    -9.42429147957120249D-01,
+     5    -3.51120304082635426D+00,    -1.57272636203680451D+01,
+     6    -8.22814390971859444D+01,    -4.92355370523670524D+02,
+     7    -3.31621856854797251D+03,    -2.48276742452085896D+04,
+     8    -2.04526587315129788D+05,    -1.83844491706820990D+06/
+      DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10),
+     1     C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18),
+     2     C(19), C(20), C(21), C(22), C(23), C(24)/
+     3     1.00000000000000000D+00,    -2.08333333333333333D-01,
+     4     1.25000000000000000D-01,     3.34201388888888889D-01,
+     5    -4.01041666666666667D-01,     7.03125000000000000D-02,
+     6    -1.02581259645061728D+00,     1.84646267361111111D+00,
+     7    -8.91210937500000000D-01,     7.32421875000000000D-02,
+     8     4.66958442342624743D+00,    -1.12070026162229938D+01,
+     9     8.78912353515625000D+00,    -2.36408691406250000D+00,
+     A     1.12152099609375000D-01,    -2.82120725582002449D+01,
+     B     8.46362176746007346D+01,    -9.18182415432400174D+01,
+     C     4.25349987453884549D+01,    -7.36879435947963170D+00,
+     D     2.27108001708984375D-01,     2.12570130039217123D+02,
+     E    -7.65252468141181642D+02,     1.05999045252799988D+03/
+      DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32),
+     1     C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40),
+     2     C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/
+     3    -6.99579627376132541D+02,     2.18190511744211590D+02,
+     4    -2.64914304869515555D+01,     5.72501420974731445D-01,
+     5    -1.91945766231840700D+03,     8.06172218173730938D+03,
+     6    -1.35865500064341374D+04,     1.16553933368645332D+04,
+     7    -5.30564697861340311D+03,     1.20090291321635246D+03,
+     8    -1.08090919788394656D+02,     1.72772750258445740D+00,
+     9     2.02042913309661486D+04,    -9.69805983886375135D+04,
+     A     1.92547001232531532D+05,    -2.03400177280415534D+05,
+     B     1.22200464983017460D+05,    -4.11926549688975513D+04,
+     C     7.10951430248936372D+03,    -4.93915304773088012D+02,
+     D     6.07404200127348304D+00,    -2.42919187900551333D+05,
+     E     1.31176361466297720D+06,    -2.99801591853810675D+06/
+      DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56),
+     1     C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64),
+     2     C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/
+     3     3.76327129765640400D+06,    -2.81356322658653411D+06,
+     4     1.26836527332162478D+06,    -3.31645172484563578D+05,
+     5     4.52187689813627263D+04,    -2.49983048181120962D+03,
+     6     2.43805296995560639D+01,     3.28446985307203782D+06,
+     7    -1.97068191184322269D+07,     5.09526024926646422D+07,
+     8    -7.41051482115326577D+07,     6.63445122747290267D+07,
+     9    -3.75671766607633513D+07,     1.32887671664218183D+07,
+     A    -2.78561812808645469D+06,     3.08186404612662398D+05,
+     B    -1.38860897537170405D+04,     1.10017140269246738D+02,
+     C    -4.93292536645099620D+07,     3.25573074185765749D+08,
+     D    -9.39462359681578403D+08,     1.55359689957058006D+09,
+     E    -1.62108055210833708D+09,     1.10684281682301447D+09/
+      DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80),
+     1     C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88),
+     2     C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/
+     3    -4.95889784275030309D+08,     1.42062907797533095D+08,
+     4    -2.44740627257387285D+07,     2.24376817792244943D+06,
+     5    -8.40054336030240853D+04,     5.51335896122020586D+02,
+     6     8.14789096118312115D+08,    -5.86648149205184723D+09,
+     7     1.86882075092958249D+10,    -3.46320433881587779D+10,
+     8     4.12801855797539740D+10,    -3.30265997498007231D+10,
+     9     1.79542137311556001D+10,    -6.56329379261928433D+09,
+     A     1.55927986487925751D+09,    -2.25105661889415278D+08,
+     B     1.73951075539781645D+07,    -5.49842327572288687D+05,
+     C     3.03809051092238427D+03,    -1.46792612476956167D+10,
+     D     1.14498237732025810D+11,    -3.99096175224466498D+11,
+     E     8.19218669548577329D+11,    -1.09837515608122331D+12/
+      DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104),
+     1     C(105)/
+     2     1.00815810686538209D+12,    -6.45364869245376503D+11,
+     3     2.87900649906150589D+11,    -8.78670721780232657D+10,
+     4     1.76347306068349694D+10,    -2.16716498322379509D+09,
+     5     1.43157876718888981D+08,    -3.87183344257261262D+06,
+     6     1.82577554742931747D+04/
+      DATA ALFA(1), ALFA(2), ALFA(3), ALFA(4), ALFA(5), ALFA(6),
+     1     ALFA(7), ALFA(8), ALFA(9), ALFA(10), ALFA(11), ALFA(12),
+     2     ALFA(13), ALFA(14), ALFA(15), ALFA(16), ALFA(17), ALFA(18),
+     3     ALFA(19), ALFA(20), ALFA(21), ALFA(22)/
+     4    -4.44444444444444444D-03,    -9.22077922077922078D-04,
+     5    -8.84892884892884893D-05,     1.65927687832449737D-04,
+     6     2.46691372741792910D-04,     2.65995589346254780D-04,
+     7     2.61824297061500945D-04,     2.48730437344655609D-04,
+     8     2.32721040083232098D-04,     2.16362485712365082D-04,
+     9     2.00738858762752355D-04,     1.86267636637545172D-04,
+     A     1.73060775917876493D-04,     1.61091705929015752D-04,
+     B     1.50274774160908134D-04,     1.40503497391269794D-04,
+     C     1.31668816545922806D-04,     1.23667445598253261D-04,
+     D     1.16405271474737902D-04,     1.09798298372713369D-04,
+     E     1.03772410422992823D-04,     9.82626078369363448D-05/
+      DATA ALFA(23), ALFA(24), ALFA(25), ALFA(26), ALFA(27), ALFA(28),
+     1     ALFA(29), ALFA(30), ALFA(31), ALFA(32), ALFA(33), ALFA(34),
+     2     ALFA(35), ALFA(36), ALFA(37), ALFA(38), ALFA(39), ALFA(40),
+     3     ALFA(41), ALFA(42), ALFA(43), ALFA(44)/
+     4     9.32120517249503256D-05,     8.85710852478711718D-05,
+     5     8.42963105715700223D-05,     8.03497548407791151D-05,
+     6     7.66981345359207388D-05,     7.33122157481777809D-05,
+     7     7.01662625163141333D-05,     6.72375633790160292D-05,
+     8     6.93735541354588974D-04,     2.32241745182921654D-04,
+     9    -1.41986273556691197D-05,    -1.16444931672048640D-04,
+     A    -1.50803558053048762D-04,    -1.55121924918096223D-04,
+     B    -1.46809756646465549D-04,    -1.33815503867491367D-04,
+     C    -1.19744975684254051D-04,    -1.06184319207974020D-04,
+     D    -9.37699549891194492D-05,    -8.26923045588193274D-05,
+     E    -7.29374348155221211D-05,    -6.44042357721016283D-05/
+      DATA ALFA(45), ALFA(46), ALFA(47), ALFA(48), ALFA(49), ALFA(50),
+     1     ALFA(51), ALFA(52), ALFA(53), ALFA(54), ALFA(55), ALFA(56),
+     2     ALFA(57), ALFA(58), ALFA(59), ALFA(60), ALFA(61), ALFA(62),
+     3     ALFA(63), ALFA(64), ALFA(65), ALFA(66)/
+     4    -5.69611566009369048D-05,    -5.04731044303561628D-05,
+     5    -4.48134868008882786D-05,    -3.98688727717598864D-05,
+     6    -3.55400532972042498D-05,    -3.17414256609022480D-05,
+     7    -2.83996793904174811D-05,    -2.54522720634870566D-05,
+     8    -2.28459297164724555D-05,    -2.05352753106480604D-05,
+     9    -1.84816217627666085D-05,    -1.66519330021393806D-05,
+     A    -1.50179412980119482D-05,    -1.35554031379040526D-05,
+     B    -1.22434746473858131D-05,    -1.10641884811308169D-05,
+     C    -3.54211971457743841D-04,    -1.56161263945159416D-04,
+     D     3.04465503594936410D-05,     1.30198655773242693D-04,
+     E     1.67471106699712269D-04,     1.70222587683592569D-04/
+      DATA ALFA(67), ALFA(68), ALFA(69), ALFA(70), ALFA(71), ALFA(72),
+     1     ALFA(73), ALFA(74), ALFA(75), ALFA(76), ALFA(77), ALFA(78),
+     2     ALFA(79), ALFA(80), ALFA(81), ALFA(82), ALFA(83), ALFA(84),
+     3     ALFA(85), ALFA(86), ALFA(87), ALFA(88)/
+     4     1.56501427608594704D-04,     1.36339170977445120D-04,
+     5     1.14886692029825128D-04,     9.45869093034688111D-05,
+     6     7.64498419250898258D-05,     6.07570334965197354D-05,
+     7     4.74394299290508799D-05,     3.62757512005344297D-05,
+     8     2.69939714979224901D-05,     1.93210938247939253D-05,
+     9     1.30056674793963203D-05,     7.82620866744496661D-06,
+     A     3.59257485819351583D-06,     1.44040049814251817D-07,
+     B    -2.65396769697939116D-06,    -4.91346867098485910D-06,
+     C    -6.72739296091248287D-06,    -8.17269379678657923D-06,
+     D    -9.31304715093561232D-06,    -1.02011418798016441D-05,
+     E    -1.08805962510592880D-05,    -1.13875481509603555D-05/
+      DATA ALFA(89), ALFA(90), ALFA(91), ALFA(92), ALFA(93), ALFA(94),
+     1     ALFA(95), ALFA(96), ALFA(97), ALFA(98), ALFA(99), ALFA(100),
+     2     ALFA(101), ALFA(102), ALFA(103), ALFA(104), ALFA(105),
+     3     ALFA(106), ALFA(107), ALFA(108), ALFA(109), ALFA(110)/
+     4    -1.17519675674556414D-05,    -1.19987364870944141D-05,
+     5     3.78194199201772914D-04,     2.02471952761816167D-04,
+     6    -6.37938506318862408D-05,    -2.38598230603005903D-04,
+     7    -3.10916256027361568D-04,    -3.13680115247576316D-04,
+     8    -2.78950273791323387D-04,    -2.28564082619141374D-04,
+     9    -1.75245280340846749D-04,    -1.25544063060690348D-04,
+     A    -8.22982872820208365D-05,    -4.62860730588116458D-05,
+     B    -1.72334302366962267D-05,     5.60690482304602267D-06,
+     C     2.31395443148286800D-05,     3.62642745856793957D-05,
+     D     4.58006124490188752D-05,     5.24595294959114050D-05,
+     E     5.68396208545815266D-05,     5.94349820393104052D-05/
+      DATA ALFA(111), ALFA(112), ALFA(113), ALFA(114), ALFA(115),
+     1     ALFA(116), ALFA(117), ALFA(118), ALFA(119), ALFA(120),
+     2     ALFA(121), ALFA(122), ALFA(123), ALFA(124), ALFA(125),
+     3     ALFA(126), ALFA(127), ALFA(128), ALFA(129), ALFA(130)/
+     4     6.06478527578421742D-05,     6.08023907788436497D-05,
+     5     6.01577894539460388D-05,     5.89199657344698500D-05,
+     6     5.72515823777593053D-05,     5.52804375585852577D-05,
+     7     5.31063773802880170D-05,     5.08069302012325706D-05,
+     8     4.84418647620094842D-05,     4.60568581607475370D-05,
+     9    -6.91141397288294174D-04,    -4.29976633058871912D-04,
+     A     1.83067735980039018D-04,     6.60088147542014144D-04,
+     B     8.75964969951185931D-04,     8.77335235958235514D-04,
+     C     7.49369585378990637D-04,     5.63832329756980918D-04,
+     D     3.68059319971443156D-04,     1.88464535514455599D-04/
+      DATA ALFA(131), ALFA(132), ALFA(133), ALFA(134), ALFA(135),
+     1     ALFA(136), ALFA(137), ALFA(138), ALFA(139), ALFA(140),
+     2     ALFA(141), ALFA(142), ALFA(143), ALFA(144), ALFA(145),
+     3     ALFA(146), ALFA(147), ALFA(148), ALFA(149), ALFA(150)/
+     4     3.70663057664904149D-05,    -8.28520220232137023D-05,
+     5    -1.72751952869172998D-04,    -2.36314873605872983D-04,
+     6    -2.77966150694906658D-04,    -3.02079514155456919D-04,
+     7    -3.12594712643820127D-04,    -3.12872558758067163D-04,
+     8    -3.05678038466324377D-04,    -2.93226470614557331D-04,
+     9    -2.77255655582934777D-04,    -2.59103928467031709D-04,
+     A    -2.39784014396480342D-04,    -2.20048260045422848D-04,
+     B    -2.00443911094971498D-04,    -1.81358692210970687D-04,
+     C    -1.63057674478657464D-04,    -1.45712672175205844D-04,
+     D    -1.29425421983924587D-04,    -1.14245691942445952D-04/
+      DATA ALFA(151), ALFA(152), ALFA(153), ALFA(154), ALFA(155),
+     1     ALFA(156), ALFA(157), ALFA(158), ALFA(159), ALFA(160),
+     2     ALFA(161), ALFA(162), ALFA(163), ALFA(164), ALFA(165),
+     3     ALFA(166), ALFA(167), ALFA(168), ALFA(169), ALFA(170)/
+     4     1.92821964248775885D-03,     1.35592576302022234D-03,
+     5    -7.17858090421302995D-04,    -2.58084802575270346D-03,
+     6    -3.49271130826168475D-03,    -3.46986299340960628D-03,
+     7    -2.82285233351310182D-03,    -1.88103076404891354D-03,
+     8    -8.89531718383947600D-04,     3.87912102631035228D-06,
+     9     7.28688540119691412D-04,     1.26566373053457758D-03,
+     A     1.62518158372674427D-03,     1.83203153216373172D-03,
+     B     1.91588388990527909D-03,     1.90588846755546138D-03,
+     C     1.82798982421825727D-03,     1.70389506421121530D-03,
+     D     1.55097127171097686D-03,     1.38261421852276159D-03/
+      DATA ALFA(171), ALFA(172), ALFA(173), ALFA(174), ALFA(175),
+     1     ALFA(176), ALFA(177), ALFA(178), ALFA(179), ALFA(180)/
+     2     1.20881424230064774D-03,     1.03676532638344962D-03,
+     3     8.71437918068619115D-04,     7.16080155297701002D-04,
+     4     5.72637002558129372D-04,     4.42089819465802277D-04,
+     5     3.24724948503090564D-04,     2.20342042730246599D-04,
+     6     1.28412898401353882D-04,     4.82005924552095464D-05/
+      DATA BETA(1), BETA(2), BETA(3), BETA(4), BETA(5), BETA(6),
+     1     BETA(7), BETA(8), BETA(9), BETA(10), BETA(11), BETA(12),
+     2     BETA(13), BETA(14), BETA(15), BETA(16), BETA(17), BETA(18),
+     3     BETA(19), BETA(20), BETA(21), BETA(22)/
+     4     1.79988721413553309D-02,     5.59964911064388073D-03,
+     5     2.88501402231132779D-03,     1.80096606761053941D-03,
+     6     1.24753110589199202D-03,     9.22878876572938311D-04,
+     7     7.14430421727287357D-04,     5.71787281789704872D-04,
+     8     4.69431007606481533D-04,     3.93232835462916638D-04,
+     9     3.34818889318297664D-04,     2.88952148495751517D-04,
+     A     2.52211615549573284D-04,     2.22280580798883327D-04,
+     B     1.97541838033062524D-04,     1.76836855019718004D-04,
+     C     1.59316899661821081D-04,     1.44347930197333986D-04,
+     D     1.31448068119965379D-04,     1.20245444949302884D-04,
+     E     1.10449144504599392D-04,     1.01828770740567258D-04/
+      DATA BETA(23), BETA(24), BETA(25), BETA(26), BETA(27), BETA(28),
+     1     BETA(29), BETA(30), BETA(31), BETA(32), BETA(33), BETA(34),
+     2     BETA(35), BETA(36), BETA(37), BETA(38), BETA(39), BETA(40),
+     3     BETA(41), BETA(42), BETA(43), BETA(44)/
+     4     9.41998224204237509D-05,     8.74130545753834437D-05,
+     5     8.13466262162801467D-05,     7.59002269646219339D-05,
+     6     7.09906300634153481D-05,     6.65482874842468183D-05,
+     7     6.25146958969275078D-05,     5.88403394426251749D-05,
+     8    -1.49282953213429172D-03,    -8.78204709546389328D-04,
+     9    -5.02916549572034614D-04,    -2.94822138512746025D-04,
+     A    -1.75463996970782828D-04,    -1.04008550460816434D-04,
+     B    -5.96141953046457895D-05,    -3.12038929076098340D-05,
+     C    -1.26089735980230047D-05,    -2.42892608575730389D-07,
+     D     8.05996165414273571D-06,     1.36507009262147391D-05,
+     E     1.73964125472926261D-05,     1.98672978842133780D-05/
+      DATA BETA(45), BETA(46), BETA(47), BETA(48), BETA(49), BETA(50),
+     1     BETA(51), BETA(52), BETA(53), BETA(54), BETA(55), BETA(56),
+     2     BETA(57), BETA(58), BETA(59), BETA(60), BETA(61), BETA(62),
+     3     BETA(63), BETA(64), BETA(65), BETA(66)/
+     4     2.14463263790822639D-05,     2.23954659232456514D-05,
+     5     2.28967783814712629D-05,     2.30785389811177817D-05,
+     6     2.30321976080909144D-05,     2.28236073720348722D-05,
+     7     2.25005881105292418D-05,     2.20981015361991429D-05,
+     8     2.16418427448103905D-05,     2.11507649256220843D-05,
+     9     2.06388749782170737D-05,     2.01165241997081666D-05,
+     A     1.95913450141179244D-05,     1.90689367910436740D-05,
+     B     1.85533719641636667D-05,     1.80475722259674218D-05,
+     C     5.52213076721292790D-04,     4.47932581552384646D-04,
+     D     2.79520653992020589D-04,     1.52468156198446602D-04,
+     E     6.93271105657043598D-05,     1.76258683069991397D-05/
+      DATA BETA(67), BETA(68), BETA(69), BETA(70), BETA(71), BETA(72),
+     1     BETA(73), BETA(74), BETA(75), BETA(76), BETA(77), BETA(78),
+     2     BETA(79), BETA(80), BETA(81), BETA(82), BETA(83), BETA(84),
+     3     BETA(85), BETA(86), BETA(87), BETA(88)/
+     4    -1.35744996343269136D-05,    -3.17972413350427135D-05,
+     5    -4.18861861696693365D-05,    -4.69004889379141029D-05,
+     6    -4.87665447413787352D-05,    -4.87010031186735069D-05,
+     7    -4.74755620890086638D-05,    -4.55813058138628452D-05,
+     8    -4.33309644511266036D-05,    -4.09230193157750364D-05,
+     9    -3.84822638603221274D-05,    -3.60857167535410501D-05,
+     A    -3.37793306123367417D-05,    -3.15888560772109621D-05,
+     B    -2.95269561750807315D-05,    -2.75978914828335759D-05,
+     C    -2.58006174666883713D-05,    -2.41308356761280200D-05,
+     D    -2.25823509518346033D-05,    -2.11479656768912971D-05,
+     E    -1.98200638885294927D-05,    -1.85909870801065077D-05/
+      DATA BETA(89), BETA(90), BETA(91), BETA(92), BETA(93), BETA(94),
+     1     BETA(95), BETA(96), BETA(97), BETA(98), BETA(99), BETA(100),
+     2     BETA(101), BETA(102), BETA(103), BETA(104), BETA(105),
+     3     BETA(106), BETA(107), BETA(108), BETA(109), BETA(110)/
+     4    -1.74532699844210224D-05,    -1.63997823854497997D-05,
+     5    -4.74617796559959808D-04,    -4.77864567147321487D-04,
+     6    -3.20390228067037603D-04,    -1.61105016119962282D-04,
+     7    -4.25778101285435204D-05,     3.44571294294967503D-05,
+     8     7.97092684075674924D-05,     1.03138236708272200D-04,
+     9     1.12466775262204158D-04,     1.13103642108481389D-04,
+     A     1.08651634848774268D-04,     1.01437951597661973D-04,
+     B     9.29298396593363896D-05,     8.40293133016089978D-05,
+     C     7.52727991349134062D-05,     6.69632521975730872D-05,
+     D     5.92564547323194704D-05,     5.22169308826975567D-05,
+     E     4.58539485165360646D-05,     4.01445513891486808D-05/
+      DATA BETA(111), BETA(112), BETA(113), BETA(114), BETA(115),
+     1     BETA(116), BETA(117), BETA(118), BETA(119), BETA(120),
+     2     BETA(121), BETA(122), BETA(123), BETA(124), BETA(125),
+     3     BETA(126), BETA(127), BETA(128), BETA(129), BETA(130)/
+     4     3.50481730031328081D-05,     3.05157995034346659D-05,
+     5     2.64956119950516039D-05,     2.29363633690998152D-05,
+     6     1.97893056664021636D-05,     1.70091984636412623D-05,
+     7     1.45547428261524004D-05,     1.23886640995878413D-05,
+     8     1.04775876076583236D-05,     8.79179954978479373D-06,
+     9     7.36465810572578444D-04,     8.72790805146193976D-04,
+     A     6.22614862573135066D-04,     2.85998154194304147D-04,
+     B     3.84737672879366102D-06,    -1.87906003636971558D-04,
+     C    -2.97603646594554535D-04,    -3.45998126832656348D-04,
+     D    -3.53382470916037712D-04,    -3.35715635775048757D-04/
+      DATA BETA(131), BETA(132), BETA(133), BETA(134), BETA(135),
+     1     BETA(136), BETA(137), BETA(138), BETA(139), BETA(140),
+     2     BETA(141), BETA(142), BETA(143), BETA(144), BETA(145),
+     3     BETA(146), BETA(147), BETA(148), BETA(149), BETA(150)/
+     4    -3.04321124789039809D-04,    -2.66722723047612821D-04,
+     5    -2.27654214122819527D-04,    -1.89922611854562356D-04,
+     6    -1.55058918599093870D-04,    -1.23778240761873630D-04,
+     7    -9.62926147717644187D-05,    -7.25178327714425337D-05,
+     8    -5.22070028895633801D-05,    -3.50347750511900522D-05,
+     9    -2.06489761035551757D-05,    -8.70106096849767054D-06,
+     A     1.13698686675100290D-06,     9.16426474122778849D-06,
+     B     1.56477785428872620D-05,     2.08223629482466847D-05,
+     C     2.48923381004595156D-05,     2.80340509574146325D-05,
+     D     3.03987774629861915D-05,     3.21156731406700616D-05/
+      DATA BETA(151), BETA(152), BETA(153), BETA(154), BETA(155),
+     1     BETA(156), BETA(157), BETA(158), BETA(159), BETA(160),
+     2     BETA(161), BETA(162), BETA(163), BETA(164), BETA(165),
+     3     BETA(166), BETA(167), BETA(168), BETA(169), BETA(170)/
+     4    -1.80182191963885708D-03,    -2.43402962938042533D-03,
+     5    -1.83422663549856802D-03,    -7.62204596354009765D-04,
+     6     2.39079475256927218D-04,     9.49266117176881141D-04,
+     7     1.34467449701540359D-03,     1.48457495259449178D-03,
+     8     1.44732339830617591D-03,     1.30268261285657186D-03,
+     9     1.10351597375642682D-03,     8.86047440419791759D-04,
+     A     6.73073208165665473D-04,     4.77603872856582378D-04,
+     B     3.05991926358789362D-04,     1.60315694594721630D-04,
+     C     4.00749555270613286D-05,    -5.66607461635251611D-05,
+     D    -1.32506186772982638D-04,    -1.90296187989614057D-04/
+      DATA BETA(171), BETA(172), BETA(173), BETA(174), BETA(175),
+     1     BETA(176), BETA(177), BETA(178), BETA(179), BETA(180),
+     2     BETA(181), BETA(182), BETA(183), BETA(184), BETA(185),
+     3     BETA(186), BETA(187), BETA(188), BETA(189), BETA(190)/
+     4    -2.32811450376937408D-04,    -2.62628811464668841D-04,
+     5    -2.82050469867598672D-04,    -2.93081563192861167D-04,
+     6    -2.97435962176316616D-04,    -2.96557334239348078D-04,
+     7    -2.91647363312090861D-04,    -2.83696203837734166D-04,
+     8    -2.73512317095673346D-04,    -2.61750155806768580D-04,
+     9     6.38585891212050914D-03,     9.62374215806377941D-03,
+     A     7.61878061207001043D-03,     2.83219055545628054D-03,
+     B    -2.09841352012720090D-03,    -5.73826764216626498D-03,
+     C    -7.70804244495414620D-03,    -8.21011692264844401D-03,
+     D    -7.65824520346905413D-03,    -6.47209729391045177D-03/
+      DATA BETA(191), BETA(192), BETA(193), BETA(194), BETA(195),
+     1     BETA(196), BETA(197), BETA(198), BETA(199), BETA(200),
+     2     BETA(201), BETA(202), BETA(203), BETA(204), BETA(205),
+     3     BETA(206), BETA(207), BETA(208), BETA(209), BETA(210)/
+     4    -4.99132412004966473D-03,    -3.45612289713133280D-03,
+     5    -2.01785580014170775D-03,    -7.59430686781961401D-04,
+     6     2.84173631523859138D-04,     1.10891667586337403D-03,
+     7     1.72901493872728771D-03,     2.16812590802684701D-03,
+     8     2.45357710494539735D-03,     2.61281821058334862D-03,
+     9     2.67141039656276912D-03,     2.65203073395980430D-03,
+     A     2.57411652877287315D-03,     2.45389126236094427D-03,
+     B     2.30460058071795494D-03,     2.13684837686712662D-03,
+     C     1.95896528478870911D-03,     1.77737008679454412D-03,
+     D     1.59690280765839059D-03,     1.42111975664438546D-03/
+      DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), GAMA(6),
+     1     GAMA(7), GAMA(8), GAMA(9), GAMA(10), GAMA(11), GAMA(12),
+     2     GAMA(13), GAMA(14), GAMA(15), GAMA(16), GAMA(17), GAMA(18),
+     3     GAMA(19), GAMA(20), GAMA(21), GAMA(22)/
+     4     6.29960524947436582D-01,     2.51984209978974633D-01,
+     5     1.54790300415655846D-01,     1.10713062416159013D-01,
+     6     8.57309395527394825D-02,     6.97161316958684292D-02,
+     7     5.86085671893713576D-02,     5.04698873536310685D-02,
+     8     4.42600580689154809D-02,     3.93720661543509966D-02,
+     9     3.54283195924455368D-02,     3.21818857502098231D-02,
+     A     2.94646240791157679D-02,     2.71581677112934479D-02,
+     B     2.51768272973861779D-02,     2.34570755306078891D-02,
+     C     2.19508390134907203D-02,     2.06210828235646240D-02,
+     D     1.94388240897880846D-02,     1.83810633800683158D-02,
+     E     1.74293213231963172D-02,     1.65685837786612353D-02/
+      DATA GAMA(23), GAMA(24), GAMA(25), GAMA(26), GAMA(27), GAMA(28),
+     1     GAMA(29), GAMA(30)/
+     2     1.57865285987918445D-02,     1.50729501494095594D-02,
+     3     1.44193250839954639D-02,     1.38184805735341786D-02,
+     4     1.32643378994276568D-02,     1.27517121970498651D-02,
+     5     1.22761545318762767D-02,     1.18338262398482403D-02/
+      DATA EX1, EX2, HPI, GPI, THPI /
+     1     3.33333333333333333D-01,     6.66666666666666667D-01,
+     2     1.57079632679489662D+00,     3.14159265358979324D+00,
+     3     4.71238898038468986D+00/
+      DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
+C
+      RFNU = 1.0D0/FNU
+C-----------------------------------------------------------------------
+C     OVERFLOW TEST (Z/FNU TOO SMALL)
+C-----------------------------------------------------------------------
+      TEST = D1MACH(1)*1.0D+3
+      AC = FNU*TEST
+      IF (DABS(ZR).GT.AC .OR. DABS(ZI).GT.AC) GO TO 15
+      ZETA1R = 2.0D0*DABS(DLOG(TEST))+FNU
+      ZETA1I = 0.0D0
+      ZETA2R = FNU
+      ZETA2I = 0.0D0
+      PHIR = 1.0D0
+      PHII = 0.0D0
+      ARGR = 1.0D0
+      ARGI = 0.0D0
+      RETURN
+   15 CONTINUE
+      ZBR = ZR*RFNU
+      ZBI = ZI*RFNU
+      RFNU2 = RFNU*RFNU
+C-----------------------------------------------------------------------
+C     COMPUTE IN THE FOURTH QUADRANT
+C-----------------------------------------------------------------------
+      FN13 = FNU**EX1
+      FN23 = FN13*FN13
+      RFN13 = 1.0D0/FN13
+      W2R = CONER - ZBR*ZBR + ZBI*ZBI
+      W2I = CONEI - ZBR*ZBI - ZBR*ZBI
+      AW2 = ZABS(COMPLEX(W2R,W2I))
+      IF (AW2.GT.0.25D0) GO TO 130
+C-----------------------------------------------------------------------
+C     POWER SERIES FOR CABS(W2).LE.0.25D0
+C-----------------------------------------------------------------------
+      K = 1
+      PR(1) = CONER
+      PI(1) = CONEI
+      SUMAR = GAMA(1)
+      SUMAI = ZEROI
+      AP(1) = 1.0D0
+      IF (AW2.LT.TOL) GO TO 20
+      DO 10 K=2,30
+        PR(K) = PR(K-1)*W2R - PI(K-1)*W2I
+        PI(K) = PR(K-1)*W2I + PI(K-1)*W2R
+        SUMAR = SUMAR + PR(K)*GAMA(K)
+        SUMAI = SUMAI + PI(K)*GAMA(K)
+        AP(K) = AP(K-1)*AW2
+        IF (AP(K).LT.TOL) GO TO 20
+   10 CONTINUE
+      K = 30
+   20 CONTINUE
+      KMAX = K
+      ZETAR = W2R*SUMAR - W2I*SUMAI
+      ZETAI = W2R*SUMAI + W2I*SUMAR
+      ARGR = ZETAR*FN23
+      ARGI = ZETAI*FN23
+      CALL ZSQRT(SUMAR, SUMAI, ZAR, ZAI)
+      CALL ZSQRT(W2R, W2I, STR, STI)
+      ZETA2R = STR*FNU
+      ZETA2I = STI*FNU
+      STR = CONER + EX2*(ZETAR*ZAR-ZETAI*ZAI)
+      STI = CONEI + EX2*(ZETAR*ZAI+ZETAI*ZAR)
+      ZETA1R = STR*ZETA2R - STI*ZETA2I
+      ZETA1I = STR*ZETA2I + STI*ZETA2R
+      ZAR = ZAR + ZAR
+      ZAI = ZAI + ZAI
+      CALL ZSQRT(ZAR, ZAI, STR, STI)
+      PHIR = STR*RFN13
+      PHII = STI*RFN13
+      IF (IPMTR.EQ.1) GO TO 120
+C-----------------------------------------------------------------------
+C     SUM SERIES FOR ASUM AND BSUM
+C-----------------------------------------------------------------------
+      SUMBR = ZEROR
+      SUMBI = ZEROI
+      DO 30 K=1,KMAX
+        SUMBR = SUMBR + PR(K)*BETA(K)
+        SUMBI = SUMBI + PI(K)*BETA(K)
+   30 CONTINUE
+      ASUMR = ZEROR
+      ASUMI = ZEROI
+      BSUMR = SUMBR
+      BSUMI = SUMBI
+      L1 = 0
+      L2 = 30
+      BTOL = TOL*(DABS(BSUMR)+DABS(BSUMI))
+      ATOL = TOL
+      PP = 1.0D0
+      IAS = 0
+      IBS = 0
+      IF (RFNU2.LT.TOL) GO TO 110
+      DO 100 IS=2,7
+        ATOL = ATOL/RFNU2
+        PP = PP*RFNU2
+        IF (IAS.EQ.1) GO TO 60
+        SUMAR = ZEROR
+        SUMAI = ZEROI
+        DO 40 K=1,KMAX
+          M = L1 + K
+          SUMAR = SUMAR + PR(K)*ALFA(M)
+          SUMAI = SUMAI + PI(K)*ALFA(M)
+          IF (AP(K).LT.ATOL) GO TO 50
+   40   CONTINUE
+   50   CONTINUE
+        ASUMR = ASUMR + SUMAR*PP
+        ASUMI = ASUMI + SUMAI*PP
+        IF (PP.LT.TOL) IAS = 1
+   60   CONTINUE
+        IF (IBS.EQ.1) GO TO 90
+        SUMBR = ZEROR
+        SUMBI = ZEROI
+        DO 70 K=1,KMAX
+          M = L2 + K
+          SUMBR = SUMBR + PR(K)*BETA(M)
+          SUMBI = SUMBI + PI(K)*BETA(M)
+          IF (AP(K).LT.ATOL) GO TO 80
+   70   CONTINUE
+   80   CONTINUE
+        BSUMR = BSUMR + SUMBR*PP
+        BSUMI = BSUMI + SUMBI*PP
+        IF (PP.LT.BTOL) IBS = 1
+   90   CONTINUE
+        IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 110
+        L1 = L1 + 30
+        L2 = L2 + 30
+  100 CONTINUE
+  110 CONTINUE
+      ASUMR = ASUMR + CONER
+      PP = RFNU*RFN13
+      BSUMR = BSUMR*PP
+      BSUMI = BSUMI*PP
+  120 CONTINUE
+      RETURN
+C-----------------------------------------------------------------------
+C     CABS(W2).GT.0.25D0
+C-----------------------------------------------------------------------
+  130 CONTINUE
+      CALL ZSQRT(W2R, W2I, WR, WI)
+      IF (WR.LT.0.0D0) WR = 0.0D0
+      IF (WI.LT.0.0D0) WI = 0.0D0
+      STR = CONER + WR
+      STI = WI
+      CALL ZDIV(STR, STI, ZBR, ZBI, ZAR, ZAI)
+      CALL ZLOG(ZAR, ZAI, ZCR, ZCI, IDUM)
+      IF (ZCI.LT.0.0D0) ZCI = 0.0D0
+      IF (ZCI.GT.HPI) ZCI = HPI
+      IF (ZCR.LT.0.0D0) ZCR = 0.0D0
+      ZTHR = (ZCR-WR)*1.5D0
+      ZTHI = (ZCI-WI)*1.5D0
+      ZETA1R = ZCR*FNU
+      ZETA1I = ZCI*FNU
+      ZETA2R = WR*FNU
+      ZETA2I = WI*FNU
+      AZTH = ZABS(COMPLEX(ZTHR,ZTHI))
+      ANG = THPI
+      IF (ZTHR.GE.0.0D0 .AND. ZTHI.LT.0.0D0) GO TO 140
+      ANG = HPI
+      IF (ZTHR.EQ.0.0D0) GO TO 140
+      ANG = DATAN(ZTHI/ZTHR)
+      IF (ZTHR.LT.0.0D0) ANG = ANG + GPI
+  140 CONTINUE
+      PP = AZTH**EX2
+      ANG = ANG*EX2
+      ZETAR = PP*DCOS(ANG)
+      ZETAI = PP*DSIN(ANG)
+      IF (ZETAI.LT.0.0D0) ZETAI = 0.0D0
+      ARGR = ZETAR*FN23
+      ARGI = ZETAI*FN23
+      CALL ZDIV(ZTHR, ZTHI, ZETAR, ZETAI, RTZTR, RTZTI)
+      CALL ZDIV(RTZTR, RTZTI, WR, WI, ZAR, ZAI)
+      TZAR = ZAR + ZAR
+      TZAI = ZAI + ZAI
+      CALL ZSQRT(TZAR, TZAI, STR, STI)
+      PHIR = STR*RFN13
+      PHII = STI*RFN13
+      IF (IPMTR.EQ.1) GO TO 120
+      RAW = 1.0D0/DSQRT(AW2)
+      STR = WR*RAW
+      STI = -WI*RAW
+      TFNR = STR*RFNU*RAW
+      TFNI = STI*RFNU*RAW
+      RAZTH = 1.0D0/AZTH
+      STR = ZTHR*RAZTH
+      STI = -ZTHI*RAZTH
+      RZTHR = STR*RAZTH*RFNU
+      RZTHI = STI*RAZTH*RFNU
+      ZCR = RZTHR*AR(2)
+      ZCI = RZTHI*AR(2)
+      RAW2 = 1.0D0/AW2
+      STR = W2R*RAW2
+      STI = -W2I*RAW2
+      T2R = STR*RAW2
+      T2I = STI*RAW2
+      STR = T2R*C(2) + C(3)
+      STI = T2I*C(2)
+      UPR(2) = STR*TFNR - STI*TFNI
+      UPI(2) = STR*TFNI + STI*TFNR
+      BSUMR = UPR(2) + ZCR
+      BSUMI = UPI(2) + ZCI
+      ASUMR = ZEROR
+      ASUMI = ZEROI
+      IF (RFNU.LT.TOL) GO TO 220
+      PRZTHR = RZTHR
+      PRZTHI = RZTHI
+      PTFNR = TFNR
+      PTFNI = TFNI
+      UPR(1) = CONER
+      UPI(1) = CONEI
+      PP = 1.0D0
+      BTOL = TOL*(DABS(BSUMR)+DABS(BSUMI))
+      KS = 0
+      KP1 = 2
+      L = 3
+      IAS = 0
+      IBS = 0
+      DO 210 LR=2,12,2
+        LRP1 = LR + 1
+C-----------------------------------------------------------------------
+C     COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE TERMS IN
+C     NEXT SUMA AND SUMB
+C-----------------------------------------------------------------------
+        DO 160 K=LR,LRP1
+          KS = KS + 1
+          KP1 = KP1 + 1
+          L = L + 1
+          ZAR = C(L)
+          ZAI = ZEROI
+          DO 150 J=2,KP1
+            L = L + 1
+            STR = ZAR*T2R - T2I*ZAI + C(L)
+            ZAI = ZAR*T2I + ZAI*T2R
+            ZAR = STR
+  150     CONTINUE
+          STR = PTFNR*TFNR - PTFNI*TFNI
+          PTFNI = PTFNR*TFNI + PTFNI*TFNR
+          PTFNR = STR
+          UPR(KP1) = PTFNR*ZAR - PTFNI*ZAI
+          UPI(KP1) = PTFNI*ZAR + PTFNR*ZAI
+          CRR(KS) = PRZTHR*BR(KS+1)
+          CRI(KS) = PRZTHI*BR(KS+1)
+          STR = PRZTHR*RZTHR - PRZTHI*RZTHI
+          PRZTHI = PRZTHR*RZTHI + PRZTHI*RZTHR
+          PRZTHR = STR
+          DRR(KS) = PRZTHR*AR(KS+2)
+          DRI(KS) = PRZTHI*AR(KS+2)
+  160   CONTINUE
+        PP = PP*RFNU2
+        IF (IAS.EQ.1) GO TO 180
+        SUMAR = UPR(LRP1)
+        SUMAI = UPI(LRP1)
+        JU = LRP1
+        DO 170 JR=1,LR
+          JU = JU - 1
+          SUMAR = SUMAR + CRR(JR)*UPR(JU) - CRI(JR)*UPI(JU)
+          SUMAI = SUMAI + CRR(JR)*UPI(JU) + CRI(JR)*UPR(JU)
+  170   CONTINUE
+        ASUMR = ASUMR + SUMAR
+        ASUMI = ASUMI + SUMAI
+        TEST = DABS(SUMAR) + DABS(SUMAI)
+        IF (PP.LT.TOL .AND. TEST.LT.TOL) IAS = 1
+  180   CONTINUE
+        IF (IBS.EQ.1) GO TO 200
+        SUMBR = UPR(LR+2) + UPR(LRP1)*ZCR - UPI(LRP1)*ZCI
+        SUMBI = UPI(LR+2) + UPR(LRP1)*ZCI + UPI(LRP1)*ZCR
+        JU = LRP1
+        DO 190 JR=1,LR
+          JU = JU - 1
+          SUMBR = SUMBR + DRR(JR)*UPR(JU) - DRI(JR)*UPI(JU)
+          SUMBI = SUMBI + DRR(JR)*UPI(JU) + DRI(JR)*UPR(JU)
+  190   CONTINUE
+        BSUMR = BSUMR + SUMBR
+        BSUMI = BSUMI + SUMBI
+        TEST = DABS(SUMBR) + DABS(SUMBI)
+        IF (PP.LT.BTOL .AND. TEST.LT.BTOL) IBS = 1
+  200   CONTINUE
+        IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 220
+  210 CONTINUE
+  220 CONTINUE
+      ASUMR = ASUMR + CONER
+      STR = -BSUMR*RFN13
+      STI = -BSUMI*RFN13
+      CALL ZDIV(STR, STI, RTZTR, RTZTI, BSUMR, BSUMI)
+      GO TO 120
+      END

amos/zuni1.f

@@ -0,0 +1,204 @@
+      SUBROUTINE ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL,
+     * TOL, ELIM, ALIM)
+C***BEGIN PROLOGUE  ZUNI1
+C***REFER TO  ZBESI,ZBESK
+C
+C     ZUNI1 COMPUTES I(FNU,Z)  BY MEANS OF THE UNIFORM ASYMPTOTIC
+C     EXPANSION FOR I(FNU,Z) IN -PI/3.LE.ARG Z.LE.PI/3.
+C
+C     FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC
+C     EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET.
+C     NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER
+C     FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL.
+C     Y(I)=CZERO FOR I=NLAST+1,N
+C
+C***ROUTINES CALLED  ZUCHK,ZUNIK,ZUOIK,D1MACH,ZABS
+C***END PROLOGUE  ZUNI1
+C     COMPLEX CFN,CONE,CRSC,CSCL,CSR,CSS,CWRK,CZERO,C1,C2,PHI,RZ,SUM,S1,
+C    *S2,Y,Z,ZETA1,ZETA2
+      DOUBLE PRECISION ALIM, APHI, ASCLE, BRY, CONER, CRSC,
+     * CSCL, CSRR, CSSR, CWRKI, CWRKR, C1R, C2I, C2M, C2R, ELIM, FN,
+     * FNU, FNUL, PHII, PHIR, RAST, RS1, RZI, RZR, STI, STR, SUMI,
+     * SUMR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I,
+     * ZETA1R, ZETA2I, ZETA2R, ZI, ZR, CYR, CYI, D1MACH, ZABS
+      INTEGER I, IFLAG, INIT, K, KODE, M, N, ND, NLAST, NN, NUF, NW, NZ
+      DIMENSION BRY(3), YR(N), YI(N), CWRKR(16), CWRKI(16), CSSR(3),
+     * CSRR(3), CYR(2), CYI(2)
+      DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 /
+C
+      NZ = 0
+      ND = N
+      NLAST = 0
+C-----------------------------------------------------------------------
+C     COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG-
+C     NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE,
+C     EXP(ALIM)=EXP(ELIM)*TOL
+C-----------------------------------------------------------------------
+      CSCL = 1.0D0/TOL
+      CRSC = TOL
+      CSSR(1) = CSCL
+      CSSR(2) = CONER
+      CSSR(3) = CRSC
+      CSRR(1) = CRSC
+      CSRR(2) = CONER
+      CSRR(3) = CSCL
+      BRY(1) = 1.0D+3*D1MACH(1)/TOL
+C-----------------------------------------------------------------------
+C     CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER
+C-----------------------------------------------------------------------
+      FN = DMAX1(FNU,1.0D0)
+      INIT = 0
+      CALL ZUNIK(ZR, ZI, FN, 1, 1, TOL, INIT, PHIR, PHII, ZETA1R,
+     * ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI)
+      IF (KODE.EQ.1) GO TO 10
+      STR = ZR + ZETA2R
+      STI = ZI + ZETA2I
+      RAST = FN/ZABS(COMPLEX(STR,STI))
+      STR = STR*RAST*RAST
+      STI = -STI*RAST*RAST
+      S1R = -ZETA1R + STR
+      S1I = -ZETA1I + STI
+      GO TO 20
+   10 CONTINUE
+      S1R = -ZETA1R + ZETA2R
+      S1I = -ZETA1I + ZETA2I
+   20 CONTINUE
+      RS1 = S1R
+      IF (DABS(RS1).GT.ELIM) GO TO 130
+   30 CONTINUE
+      NN = MIN0(2,ND)
+      DO 80 I=1,NN
+        FN = FNU + DBLE(FLOAT(ND-I))
+        INIT = 0
+        CALL ZUNIK(ZR, ZI, FN, 1, 0, TOL, INIT, PHIR, PHII, ZETA1R,
+     *   ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI)
+        IF (KODE.EQ.1) GO TO 40
+        STR = ZR + ZETA2R
+        STI = ZI + ZETA2I
+        RAST = FN/ZABS(COMPLEX(STR,STI))
+        STR = STR*RAST*RAST
+        STI = -STI*RAST*RAST
+        S1R = -ZETA1R + STR
+        S1I = -ZETA1I + STI + ZI
+        GO TO 50
+   40   CONTINUE
+        S1R = -ZETA1R + ZETA2R
+        S1I = -ZETA1I + ZETA2I
+   50   CONTINUE
+C-----------------------------------------------------------------------
+C     TEST FOR UNDERFLOW AND OVERFLOW
+C-----------------------------------------------------------------------
+        RS1 = S1R
+        IF (DABS(RS1).GT.ELIM) GO TO 110
+        IF (I.EQ.1) IFLAG = 2
+        IF (DABS(RS1).LT.ALIM) GO TO 60
+C-----------------------------------------------------------------------
+C     REFINE  TEST AND SCALE
+C-----------------------------------------------------------------------
+        APHI = ZABS(COMPLEX(PHIR,PHII))
+        RS1 = RS1 + DLOG(APHI)
+        IF (DABS(RS1).GT.ELIM) GO TO 110
+        IF (I.EQ.1) IFLAG = 1
+        IF (RS1.LT.0.0D0) GO TO 60
+        IF (I.EQ.1) IFLAG = 3
+   60   CONTINUE
+C-----------------------------------------------------------------------
+C     SCALE S1 IF CABS(S1).LT.ASCLE
+C-----------------------------------------------------------------------
+        S2R = PHIR*SUMR - PHII*SUMI
+        S2I = PHIR*SUMI + PHII*SUMR
+        STR = DEXP(S1R)*CSSR(IFLAG)
+        S1R = STR*DCOS(S1I)
+        S1I = STR*DSIN(S1I)
+        STR = S2R*S1R - S2I*S1I
+        S2I = S2R*S1I + S2I*S1R
+        S2R = STR
+        IF (IFLAG.NE.1) GO TO 70
+        CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL)
+        IF (NW.NE.0) GO TO 110
+   70   CONTINUE
+        CYR(I) = S2R
+        CYI(I) = S2I
+        M = ND - I + 1
+        YR(M) = S2R*CSRR(IFLAG)
+        YI(M) = S2I*CSRR(IFLAG)
+   80 CONTINUE
+      IF (ND.LE.2) GO TO 100
+      RAST = 1.0D0/ZABS(COMPLEX(ZR,ZI))
+      STR = ZR*RAST
+      STI = -ZI*RAST
+      RZR = (STR+STR)*RAST
+      RZI = (STI+STI)*RAST
+      BRY(2) = 1.0D0/BRY(1)
+      BRY(3) = D1MACH(2)
+      S1R = CYR(1)
+      S1I = CYI(1)
+      S2R = CYR(2)
+      S2I = CYI(2)
+      C1R = CSRR(IFLAG)
+      ASCLE = BRY(IFLAG)
+      K = ND - 2
+      FN = DBLE(FLOAT(K))
+      DO 90 I=3,ND
+        C2R = S2R
+        C2I = S2I
+        S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I)
+        S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R)
+        S1R = C2R
+        S1I = C2I
+        C2R = S2R*C1R
+        C2I = S2I*C1R
+        YR(K) = C2R
+        YI(K) = C2I
+        K = K - 1
+        FN = FN - 1.0D0
+        IF (IFLAG.GE.3) GO TO 90
+        STR = DABS(C2R)
+        STI = DABS(C2I)
+        C2M = DMAX1(STR,STI)
+        IF (C2M.LE.ASCLE) GO TO 90
+        IFLAG = IFLAG + 1
+        ASCLE = BRY(IFLAG)
+        S1R = S1R*C1R
+        S1I = S1I*C1R
+        S2R = C2R
+        S2I = C2I
+        S1R = S1R*CSSR(IFLAG)
+        S1I = S1I*CSSR(IFLAG)
+        S2R = S2R*CSSR(IFLAG)
+        S2I = S2I*CSSR(IFLAG)
+        C1R = CSRR(IFLAG)
+   90 CONTINUE
+  100 CONTINUE
+      RETURN
+C-----------------------------------------------------------------------
+C     SET UNDERFLOW AND UPDATE PARAMETERS
+C-----------------------------------------------------------------------
+  110 CONTINUE
+      IF (RS1.GT.0.0D0) GO TO 120
+      YR(ND) = ZEROR
+      YI(ND) = ZEROI
+      NZ = NZ + 1
+      ND = ND - 1
+      IF (ND.EQ.0) GO TO 100
+      CALL ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM)
+      IF (NUF.LT.0) GO TO 120
+      ND = ND - NUF
+      NZ = NZ + NUF
+      IF (ND.EQ.0) GO TO 100
+      FN = FNU + DBLE(FLOAT(ND-1))
+      IF (FN.GE.FNUL) GO TO 30
+      NLAST = ND
+      RETURN
+  120 CONTINUE
+      NZ = -1
+      RETURN
+  130 CONTINUE
+      IF (RS1.GT.0.0D0) GO TO 120
+      NZ = N
+      DO 140 I=1,N
+        YR(I) = ZEROR
+        YI(I) = ZEROI
+  140 CONTINUE
+      RETURN
+      END

amos/zuni2.f

@@ -0,0 +1,267 @@
+      SUBROUTINE ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL,
+     * TOL, ELIM, ALIM)
+C***BEGIN PROLOGUE  ZUNI2
+C***REFER TO  ZBESI,ZBESK
+C
+C     ZUNI2 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF
+C     UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I
+C     OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO.
+C
+C     FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC
+C     EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET.
+C     NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER
+C     FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL.
+C     Y(I)=CZERO FOR I=NLAST+1,N
+C
+C***ROUTINES CALLED  ZAIRY,ZUCHK,ZUNHJ,ZUOIK,D1MACH,ZABS
+C***END PROLOGUE  ZUNI2
+C     COMPLEX AI,ARG,ASUM,BSUM,CFN,CI,CID,CIP,CONE,CRSC,CSCL,CSR,CSS,
+C    *CZERO,C1,C2,DAI,PHI,RZ,S1,S2,Y,Z,ZB,ZETA1,ZETA2,ZN
+      DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGI,
+     * ARGR, ASCLE, ASUMI, ASUMR, BRY, BSUMI, BSUMR, CIDI, CIPI, CIPR,
+     * CONER, CRSC, CSCL, CSRR, CSSR, C1R, C2I, C2M, C2R, DAII,
+     * DAIR, ELIM, FN, FNU, FNUL, HPI, PHII, PHIR, RAST, RAZ, RS1, RZI,
+     * RZR, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZBI, ZBR, ZEROI,
+     * ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, ZNI, ZNR, ZR, CYR,
+     * CYI, D1MACH, ZABS, CAR, SAR
+      INTEGER I, IFLAG, IN, INU, J, K, KODE, N, NAI, ND, NDAI, NLAST,
+     * NN, NUF, NW, NZ, IDUM
+      DIMENSION BRY(3), YR(N), YI(N), CIPR(4), CIPI(4), CSSR(3),
+     * CSRR(3), CYR(2), CYI(2)
+      DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 /
+      DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4),
+     * CIPI(4)/ 1.0D0,0.0D0, 0.0D0,1.0D0, -1.0D0,0.0D0, 0.0D0,-1.0D0/
+      DATA HPI, AIC  /
+     1      1.57079632679489662D+00,     1.265512123484645396D+00/
+C
+      NZ = 0
+      ND = N
+      NLAST = 0
+C-----------------------------------------------------------------------
+C     COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG-
+C     NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE,
+C     EXP(ALIM)=EXP(ELIM)*TOL
+C-----------------------------------------------------------------------
+      CSCL = 1.0D0/TOL
+      CRSC = TOL
+      CSSR(1) = CSCL
+      CSSR(2) = CONER
+      CSSR(3) = CRSC
+      CSRR(1) = CRSC
+      CSRR(2) = CONER
+      CSRR(3) = CSCL
+      BRY(1) = 1.0D+3*D1MACH(1)/TOL
+C-----------------------------------------------------------------------
+C     ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI
+C-----------------------------------------------------------------------
+      ZNR = ZI
+      ZNI = -ZR
+      ZBR = ZR
+      ZBI = ZI
+      CIDI = -CONER
+      INU = INT(SNGL(FNU))
+      ANG = HPI*(FNU-DBLE(FLOAT(INU)))
+      C2R = DCOS(ANG)
+      C2I = DSIN(ANG)
+      CAR = C2R
+      SAR = C2I
+      IN = INU + N - 1
+      IN = MOD(IN,4) + 1
+      STR = C2R*CIPR(IN) - C2I*CIPI(IN)
+      C2I = C2R*CIPI(IN) + C2I*CIPR(IN)
+      C2R = STR
+      IF (ZI.GT.0.0D0) GO TO 10
+      ZNR = -ZNR
+      ZBI = -ZBI
+      CIDI = -CIDI
+      C2I = -C2I
+   10 CONTINUE
+C-----------------------------------------------------------------------
+C     CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER
+C-----------------------------------------------------------------------
+      FN = DMAX1(FNU,1.0D0)
+      CALL ZUNHJ(ZNR, ZNI, FN, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R,
+     * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI)
+      IF (KODE.EQ.1) GO TO 20
+      STR = ZBR + ZETA2R
+      STI = ZBI + ZETA2I
+      RAST = FN/ZABS(COMPLEX(STR,STI))
+      STR = STR*RAST*RAST
+      STI = -STI*RAST*RAST
+      S1R = -ZETA1R + STR
+      S1I = -ZETA1I + STI
+      GO TO 30
+   20 CONTINUE
+      S1R = -ZETA1R + ZETA2R
+      S1I = -ZETA1I + ZETA2I
+   30 CONTINUE
+      RS1 = S1R
+      IF (DABS(RS1).GT.ELIM) GO TO 150
+   40 CONTINUE
+      NN = MIN0(2,ND)
+      DO 90 I=1,NN
+        FN = FNU + DBLE(FLOAT(ND-I))
+        CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR, PHII, ARGR, ARGI,
+     *   ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI)
+        IF (KODE.EQ.1) GO TO 50
+        STR = ZBR + ZETA2R
+        STI = ZBI + ZETA2I
+        RAST = FN/ZABS(COMPLEX(STR,STI))
+        STR = STR*RAST*RAST
+        STI = -STI*RAST*RAST
+        S1R = -ZETA1R + STR
+        S1I = -ZETA1I + STI + DABS(ZI)
+        GO TO 60
+   50   CONTINUE
+        S1R = -ZETA1R + ZETA2R
+        S1I = -ZETA1I + ZETA2I
+   60   CONTINUE
+C-----------------------------------------------------------------------
+C     TEST FOR UNDERFLOW AND OVERFLOW
+C-----------------------------------------------------------------------
+        RS1 = S1R
+        IF (DABS(RS1).GT.ELIM) GO TO 120
+        IF (I.EQ.1) IFLAG = 2
+        IF (DABS(RS1).LT.ALIM) GO TO 70
+C-----------------------------------------------------------------------
+C     REFINE  TEST AND SCALE
+C-----------------------------------------------------------------------
+C-----------------------------------------------------------------------
+        APHI = ZABS(COMPLEX(PHIR,PHII))
+        AARG = ZABS(COMPLEX(ARGR,ARGI))
+        RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC
+        IF (DABS(RS1).GT.ELIM) GO TO 120
+        IF (I.EQ.1) IFLAG = 1
+        IF (RS1.LT.0.0D0) GO TO 70
+        IF (I.EQ.1) IFLAG = 3
+   70   CONTINUE
+C-----------------------------------------------------------------------
+C     SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR
+C     EXPONENT EXTREMES
+C-----------------------------------------------------------------------
+        CALL ZAIRY(ARGR, ARGI, 0, 2, AIR, AII, NAI, IDUM)
+        CALL ZAIRY(ARGR, ARGI, 1, 2, DAIR, DAII, NDAI, IDUM)
+        STR = DAIR*BSUMR - DAII*BSUMI
+        STI = DAIR*BSUMI + DAII*BSUMR
+        STR = STR + (AIR*ASUMR-AII*ASUMI)
+        STI = STI + (AIR*ASUMI+AII*ASUMR)
+        S2R = PHIR*STR - PHII*STI
+        S2I = PHIR*STI + PHII*STR
+        STR = DEXP(S1R)*CSSR(IFLAG)
+        S1R = STR*DCOS(S1I)
+        S1I = STR*DSIN(S1I)
+        STR = S2R*S1R - S2I*S1I
+        S2I = S2R*S1I + S2I*S1R
+        S2R = STR
+        IF (IFLAG.NE.1) GO TO 80
+        CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL)
+        IF (NW.NE.0) GO TO 120
+   80   CONTINUE
+        IF (ZI.LE.0.0D0) S2I = -S2I
+        STR = S2R*C2R - S2I*C2I
+        S2I = S2R*C2I + S2I*C2R
+        S2R = STR
+        CYR(I) = S2R
+        CYI(I) = S2I
+        J = ND - I + 1
+        YR(J) = S2R*CSRR(IFLAG)
+        YI(J) = S2I*CSRR(IFLAG)
+        STR = -C2I*CIDI
+        C2I = C2R*CIDI
+        C2R = STR
+   90 CONTINUE
+      IF (ND.LE.2) GO TO 110
+      RAZ = 1.0D0/ZABS(COMPLEX(ZR,ZI))
+      STR = ZR*RAZ
+      STI = -ZI*RAZ
+      RZR = (STR+STR)*RAZ
+      RZI = (STI+STI)*RAZ
+      BRY(2) = 1.0D0/BRY(1)
+      BRY(3) = D1MACH(2)
+      S1R = CYR(1)
+      S1I = CYI(1)
+      S2R = CYR(2)
+      S2I = CYI(2)
+      C1R = CSRR(IFLAG)
+      ASCLE = BRY(IFLAG)
+      K = ND - 2
+      FN = DBLE(FLOAT(K))
+      DO 100 I=3,ND
+        C2R = S2R
+        C2I = S2I
+        S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I)
+        S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R)
+        S1R = C2R
+        S1I = C2I
+        C2R = S2R*C1R
+        C2I = S2I*C1R
+        YR(K) = C2R
+        YI(K) = C2I
+        K = K - 1
+        FN = FN - 1.0D0
+        IF (IFLAG.GE.3) GO TO 100
+        STR = DABS(C2R)
+        STI = DABS(C2I)
+        C2M = DMAX1(STR,STI)
+        IF (C2M.LE.ASCLE) GO TO 100
+        IFLAG = IFLAG + 1
+        ASCLE = BRY(IFLAG)
+        S1R = S1R*C1R
+        S1I = S1I*C1R
+        S2R = C2R
+        S2I = C2I
+        S1R = S1R*CSSR(IFLAG)
+        S1I = S1I*CSSR(IFLAG)
+        S2R = S2R*CSSR(IFLAG)
+        S2I = S2I*CSSR(IFLAG)
+        C1R = CSRR(IFLAG)
+  100 CONTINUE
+  110 CONTINUE
+      RETURN
+  120 CONTINUE
+      IF (RS1.GT.0.0D0) GO TO 140
+C-----------------------------------------------------------------------
+C     SET UNDERFLOW AND UPDATE PARAMETERS
+C-----------------------------------------------------------------------
+      YR(ND) = ZEROR
+      YI(ND) = ZEROI
+      NZ = NZ + 1
+      ND = ND - 1
+      IF (ND.EQ.0) GO TO 110
+      CALL ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM)
+      IF (NUF.LT.0) GO TO 140
+      ND = ND - NUF
+      NZ = NZ + NUF
+      IF (ND.EQ.0) GO TO 110
+      FN = FNU + DBLE(FLOAT(ND-1))
+      IF (FN.LT.FNUL) GO TO 130
+C      FN = CIDI
+C      J = NUF + 1
+C      K = MOD(J,4) + 1
+C      S1R = CIPR(K)
+C      S1I = CIPI(K)
+C      IF (FN.LT.0.0D0) S1I = -S1I
+C      STR = C2R*S1R - C2I*S1I
+C      C2I = C2R*S1I + C2I*S1R
+C      C2R = STR
+      IN = INU + ND - 1
+      IN = MOD(IN,4) + 1
+      C2R = CAR*CIPR(IN) - SAR*CIPI(IN)
+      C2I = CAR*CIPI(IN) + SAR*CIPR(IN)
+      IF (ZI.LE.0.0D0) C2I = -C2I
+      GO TO 40
+  130 CONTINUE
+      NLAST = ND
+      RETURN
+  140 CONTINUE
+      NZ = -1
+      RETURN
+  150 CONTINUE
+      IF (RS1.GT.0.0D0) GO TO 140
+      NZ = N
+      DO 160 I=1,N
+        YR(I) = ZEROR
+        YI(I) = ZEROI
+  160 CONTINUE
+      RETURN
+      END

amos/zunik.f

@@ -0,0 +1,211 @@
+      SUBROUTINE ZUNIK(ZRR, ZRI, FNU, IKFLG, IPMTR, TOL, INIT, PHIR,
+     * PHII, ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI)
+C***BEGIN PROLOGUE  ZUNIK
+C***REFER TO  ZBESI,ZBESK
+C
+C        ZUNIK COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC
+C        EXPANSIONS OF THE I AND K FUNCTIONS ON IKFLG= 1 OR 2
+C        RESPECTIVELY BY
+C
+C        W(FNU,ZR) = PHI*EXP(ZETA)*SUM
+C
+C        WHERE       ZETA=-ZETA1 + ZETA2       OR
+C                          ZETA1 - ZETA2
+C
+C        THE FIRST CALL MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE
+C        SAME ZR AND FNU WILL RETURN THE I OR K FUNCTION ON IKFLG=
+C        1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK
+C        ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI,
+C        ZETA1,ZETA2.
+C
+C***ROUTINES CALLED  ZDIV,ZLOG,ZSQRT,D1MACH
+C***END PROLOGUE  ZUNIK
+C     COMPLEX CFN,CON,CONE,CRFN,CWRK,CZERO,PHI,S,SR,SUM,T,T2,ZETA1,
+C    *ZETA2,ZN,ZR
+      DOUBLE PRECISION AC, C, CON, CONEI, CONER, CRFNI, CRFNR, CWRKI,
+     * CWRKR, FNU, PHII, PHIR, RFN, SI, SR, SRI, SRR, STI, STR, SUMI,
+     * SUMR, TEST, TI, TOL, TR, T2I, T2R, ZEROI, ZEROR, ZETA1I, ZETA1R,
+     * ZETA2I, ZETA2R, ZNI, ZNR, ZRI, ZRR, D1MACH
+      INTEGER I, IDUM, IKFLG, INIT, IPMTR, J, K, L
+      DIMENSION C(120), CWRKR(16), CWRKI(16), CON(2)
+      DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
+      DATA CON(1), CON(2)  /
+     1 3.98942280401432678D-01,  1.25331413731550025D+00 /
+      DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10),
+     1     C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18),
+     2     C(19), C(20), C(21), C(22), C(23), C(24)/
+     3     1.00000000000000000D+00,    -2.08333333333333333D-01,
+     4     1.25000000000000000D-01,     3.34201388888888889D-01,
+     5    -4.01041666666666667D-01,     7.03125000000000000D-02,
+     6    -1.02581259645061728D+00,     1.84646267361111111D+00,
+     7    -8.91210937500000000D-01,     7.32421875000000000D-02,
+     8     4.66958442342624743D+00,    -1.12070026162229938D+01,
+     9     8.78912353515625000D+00,    -2.36408691406250000D+00,
+     A     1.12152099609375000D-01,    -2.82120725582002449D+01,
+     B     8.46362176746007346D+01,    -9.18182415432400174D+01,
+     C     4.25349987453884549D+01,    -7.36879435947963170D+00,
+     D     2.27108001708984375D-01,     2.12570130039217123D+02,
+     E    -7.65252468141181642D+02,     1.05999045252799988D+03/
+      DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32),
+     1     C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40),
+     2     C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/
+     3    -6.99579627376132541D+02,     2.18190511744211590D+02,
+     4    -2.64914304869515555D+01,     5.72501420974731445D-01,
+     5    -1.91945766231840700D+03,     8.06172218173730938D+03,
+     6    -1.35865500064341374D+04,     1.16553933368645332D+04,
+     7    -5.30564697861340311D+03,     1.20090291321635246D+03,
+     8    -1.08090919788394656D+02,     1.72772750258445740D+00,
+     9     2.02042913309661486D+04,    -9.69805983886375135D+04,
+     A     1.92547001232531532D+05,    -2.03400177280415534D+05,
+     B     1.22200464983017460D+05,    -4.11926549688975513D+04,
+     C     7.10951430248936372D+03,    -4.93915304773088012D+02,
+     D     6.07404200127348304D+00,    -2.42919187900551333D+05,
+     E     1.31176361466297720D+06,    -2.99801591853810675D+06/
+      DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56),
+     1     C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64),
+     2     C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/
+     3     3.76327129765640400D+06,    -2.81356322658653411D+06,
+     4     1.26836527332162478D+06,    -3.31645172484563578D+05,
+     5     4.52187689813627263D+04,    -2.49983048181120962D+03,
+     6     2.43805296995560639D+01,     3.28446985307203782D+06,
+     7    -1.97068191184322269D+07,     5.09526024926646422D+07,
+     8    -7.41051482115326577D+07,     6.63445122747290267D+07,
+     9    -3.75671766607633513D+07,     1.32887671664218183D+07,
+     A    -2.78561812808645469D+06,     3.08186404612662398D+05,
+     B    -1.38860897537170405D+04,     1.10017140269246738D+02,
+     C    -4.93292536645099620D+07,     3.25573074185765749D+08,
+     D    -9.39462359681578403D+08,     1.55359689957058006D+09,
+     E    -1.62108055210833708D+09,     1.10684281682301447D+09/
+      DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80),
+     1     C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88),
+     2     C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/
+     3    -4.95889784275030309D+08,     1.42062907797533095D+08,
+     4    -2.44740627257387285D+07,     2.24376817792244943D+06,
+     5    -8.40054336030240853D+04,     5.51335896122020586D+02,
+     6     8.14789096118312115D+08,    -5.86648149205184723D+09,
+     7     1.86882075092958249D+10,    -3.46320433881587779D+10,
+     8     4.12801855797539740D+10,    -3.30265997498007231D+10,
+     9     1.79542137311556001D+10,    -6.56329379261928433D+09,
+     A     1.55927986487925751D+09,    -2.25105661889415278D+08,
+     B     1.73951075539781645D+07,    -5.49842327572288687D+05,
+     C     3.03809051092238427D+03,    -1.46792612476956167D+10,
+     D     1.14498237732025810D+11,    -3.99096175224466498D+11,
+     E     8.19218669548577329D+11,    -1.09837515608122331D+12/
+      DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104),
+     1     C(105), C(106), C(107), C(108), C(109), C(110), C(111),
+     2     C(112), C(113), C(114), C(115), C(116), C(117), C(118)/
+     3     1.00815810686538209D+12,    -6.45364869245376503D+11,
+     4     2.87900649906150589D+11,    -8.78670721780232657D+10,
+     5     1.76347306068349694D+10,    -2.16716498322379509D+09,
+     6     1.43157876718888981D+08,    -3.87183344257261262D+06,
+     7     1.82577554742931747D+04,     2.86464035717679043D+11,
+     8    -2.40629790002850396D+12,     9.10934118523989896D+12,
+     9    -2.05168994109344374D+13,     3.05651255199353206D+13,
+     A    -3.16670885847851584D+13,     2.33483640445818409D+13,
+     B    -1.23204913055982872D+13,     4.61272578084913197D+12,
+     C    -1.19655288019618160D+12,     2.05914503232410016D+11,
+     D    -2.18229277575292237D+10,     1.24700929351271032D+09/
+      DATA C(119), C(120)/
+     1    -2.91883881222208134D+07,     1.18838426256783253D+05/
+C
+      IF (INIT.NE.0) GO TO 40
+C-----------------------------------------------------------------------
+C     INITIALIZE ALL VARIABLES
+C-----------------------------------------------------------------------
+      RFN = 1.0D0/FNU
+C-----------------------------------------------------------------------
+C     OVERFLOW TEST (ZR/FNU TOO SMALL)
+C-----------------------------------------------------------------------
+      TEST = D1MACH(1)*1.0D+3
+      AC = FNU*TEST
+      IF (DABS(ZRR).GT.AC .OR. DABS(ZRI).GT.AC) GO TO 15
+      ZETA1R = 2.0D0*DABS(DLOG(TEST))+FNU
+      ZETA1I = 0.0D0
+      ZETA2R = FNU
+      ZETA2I = 0.0D0
+      PHIR = 1.0D0
+      PHII = 0.0D0
+      RETURN
+   15 CONTINUE
+      TR = ZRR*RFN
+      TI = ZRI*RFN
+      SR = CONER + (TR*TR-TI*TI)
+      SI = CONEI + (TR*TI+TI*TR)
+      CALL ZSQRT(SR, SI, SRR, SRI)
+      STR = CONER + SRR
+      STI = CONEI + SRI
+      CALL ZDIV(STR, STI, TR, TI, ZNR, ZNI)
+      CALL ZLOG(ZNR, ZNI, STR, STI, IDUM)
+      ZETA1R = FNU*STR
+      ZETA1I = FNU*STI
+      ZETA2R = FNU*SRR
+      ZETA2I = FNU*SRI
+      CALL ZDIV(CONER, CONEI, SRR, SRI, TR, TI)
+      SRR = TR*RFN
+      SRI = TI*RFN
+      CALL ZSQRT(SRR, SRI, CWRKR(16), CWRKI(16))
+      PHIR = CWRKR(16)*CON(IKFLG)
+      PHII = CWRKI(16)*CON(IKFLG)
+      IF (IPMTR.NE.0) RETURN
+      CALL ZDIV(CONER, CONEI, SR, SI, T2R, T2I)
+      CWRKR(1) = CONER
+      CWRKI(1) = CONEI
+      CRFNR = CONER
+      CRFNI = CONEI
+      AC = 1.0D0
+      L = 1
+      DO 20 K=2,15
+        SR = ZEROR
+        SI = ZEROI
+        DO 10 J=1,K
+          L = L + 1
+          STR = SR*T2R - SI*T2I + C(L)
+          SI = SR*T2I + SI*T2R
+          SR = STR
+   10   CONTINUE
+        STR = CRFNR*SRR - CRFNI*SRI
+        CRFNI = CRFNR*SRI + CRFNI*SRR
+        CRFNR = STR
+        CWRKR(K) = CRFNR*SR - CRFNI*SI
+        CWRKI(K) = CRFNR*SI + CRFNI*SR
+        AC = AC*RFN
+        TEST = DABS(CWRKR(K)) + DABS(CWRKI(K))
+        IF (AC.LT.TOL .AND. TEST.LT.TOL) GO TO 30
+   20 CONTINUE
+      K = 15
+   30 CONTINUE
+      INIT = K
+   40 CONTINUE
+      IF (IKFLG.EQ.2) GO TO 60
+C-----------------------------------------------------------------------
+C     COMPUTE SUM FOR THE I FUNCTION
+C-----------------------------------------------------------------------
+      SR = ZEROR
+      SI = ZEROI
+      DO 50 I=1,INIT
+        SR = SR + CWRKR(I)
+        SI = SI + CWRKI(I)
+   50 CONTINUE
+      SUMR = SR
+      SUMI = SI
+      PHIR = CWRKR(16)*CON(1)
+      PHII = CWRKI(16)*CON(1)
+      RETURN
+   60 CONTINUE
+C-----------------------------------------------------------------------
+C     COMPUTE SUM FOR THE K FUNCTION
+C-----------------------------------------------------------------------
+      SR = ZEROR
+      SI = ZEROI
+      TR = CONER
+      DO 70 I=1,INIT
+        SR = SR + TR*CWRKR(I)
+        SI = SI + TR*CWRKI(I)
+        TR = -TR
+   70 CONTINUE
+      SUMR = SR
+      SUMI = SI
+      PHIR = CWRKR(16)*CON(2)
+      PHII = CWRKI(16)*CON(2)
+      RETURN
+      END

amos/zunk1.f

@@ -0,0 +1,426 @@
+      SUBROUTINE ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM,
+     * ALIM)
+C***BEGIN PROLOGUE  ZUNK1
+C***REFER TO  ZBESK
+C
+C     ZUNK1 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE
+C     RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE
+C     UNIFORM ASYMPTOTIC EXPANSION.
+C     MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION.
+C     NZ=-1 MEANS AN OVERFLOW WILL OCCUR
+C
+C***ROUTINES CALLED  ZKSCL,ZS1S2,ZUCHK,ZUNIK,D1MACH,ZABS
+C***END PROLOGUE  ZUNK1
+C     COMPLEX CFN,CK,CONE,CRSC,CS,CSCL,CSGN,CSPN,CSR,CSS,CWRK,CY,CZERO,
+C    *C1,C2,PHI,PHID,RZ,SUM,SUMD,S1,S2,Y,Z,ZETA1,ZETA1D,ZETA2,ZETA2D,ZR
+      DOUBLE PRECISION ALIM, ANG, APHI, ASC, ASCLE, BRY, CKI, CKR,
+     * CONER, CRSC, CSCL, CSGNI, CSPNI, CSPNR, CSR, CSRR, CSSR,
+     * CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2M, C2R, ELIM, FMR, FN,
+     * FNF, FNU, PHIDI, PHIDR, PHII, PHIR, PI, RAST, RAZR, RS1, RZI,
+     * RZR, SGN, STI, STR, SUMDI, SUMDR, SUMI, SUMR, S1I, S1R, S2I,
+     * S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R,
+     * ZET1DI, ZET1DR, ZET2DI, ZET2DR, ZI, ZR, ZRI, ZRR, D1MACH, ZABS
+      INTEGER I, IB, IFLAG, IFN, IL, INIT, INU, IUF, K, KDFLG, KFLAG,
+     * KK, KODE, MR, N, NW, NZ, INITD, IC, IPARD, J
+      DIMENSION BRY(3), INIT(2), YR(N), YI(N), SUMR(2), SUMI(2),
+     * ZETA1R(2), ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2),
+     * CWRKR(16,3), CWRKI(16,3), CSSR(3), CSRR(3), PHIR(2), PHII(2)
+      DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 /
+      DATA PI / 3.14159265358979324D0 /
+C
+      KDFLG = 1
+      NZ = 0
+C-----------------------------------------------------------------------
+C     EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN
+C     THE UNDERFLOW LIMIT
+C-----------------------------------------------------------------------
+      CSCL = 1.0D0/TOL
+      CRSC = TOL
+      CSSR(1) = CSCL
+      CSSR(2) = CONER
+      CSSR(3) = CRSC
+      CSRR(1) = CRSC
+      CSRR(2) = CONER
+      CSRR(3) = CSCL
+      BRY(1) = 1.0D+3*D1MACH(1)/TOL
+      BRY(2) = 1.0D0/BRY(1)
+      BRY(3) = D1MACH(2)
+      ZRR = ZR
+      ZRI = ZI
+      IF (ZR.GE.0.0D0) GO TO 10
+      ZRR = -ZR
+      ZRI = -ZI
+   10 CONTINUE
+      J = 2
+      DO 70 I=1,N
+C-----------------------------------------------------------------------
+C     J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J
+C-----------------------------------------------------------------------
+        J = 3 - J
+        FN = FNU + DBLE(FLOAT(I-1))
+        INIT(J) = 0
+        CALL ZUNIK(ZRR, ZRI, FN, 2, 0, TOL, INIT(J), PHIR(J), PHII(J),
+     *   ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), SUMR(J), SUMI(J),
+     *   CWRKR(1,J), CWRKI(1,J))
+        IF (KODE.EQ.1) GO TO 20
+        STR = ZRR + ZETA2R(J)
+        STI = ZRI + ZETA2I(J)
+        RAST = FN/ZABS(COMPLEX(STR,STI))
+        STR = STR*RAST*RAST
+        STI = -STI*RAST*RAST
+        S1R = ZETA1R(J) - STR
+        S1I = ZETA1I(J) - STI
+        GO TO 30
+   20   CONTINUE
+        S1R = ZETA1R(J) - ZETA2R(J)
+        S1I = ZETA1I(J) - ZETA2I(J)
+   30   CONTINUE
+        RS1 = S1R
+C-----------------------------------------------------------------------
+C     TEST FOR UNDERFLOW AND OVERFLOW
+C-----------------------------------------------------------------------
+        IF (DABS(RS1).GT.ELIM) GO TO 60
+        IF (KDFLG.EQ.1) KFLAG = 2
+        IF (DABS(RS1).LT.ALIM) GO TO 40
+C-----------------------------------------------------------------------
+C     REFINE  TEST AND SCALE
+C-----------------------------------------------------------------------
+        APHI = ZABS(COMPLEX(PHIR(J),PHII(J)))
+        RS1 = RS1 + DLOG(APHI)
+        IF (DABS(RS1).GT.ELIM) GO TO 60
+        IF (KDFLG.EQ.1) KFLAG = 1
+        IF (RS1.LT.0.0D0) GO TO 40
+        IF (KDFLG.EQ.1) KFLAG = 3
+   40   CONTINUE
+C-----------------------------------------------------------------------
+C     SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR
+C     EXPONENT EXTREMES
+C-----------------------------------------------------------------------
+        S2R = PHIR(J)*SUMR(J) - PHII(J)*SUMI(J)
+        S2I = PHIR(J)*SUMI(J) + PHII(J)*SUMR(J)
+        STR = DEXP(S1R)*CSSR(KFLAG)
+        S1R = STR*DCOS(S1I)
+        S1I = STR*DSIN(S1I)
+        STR = S2R*S1R - S2I*S1I
+        S2I = S1R*S2I + S2R*S1I
+        S2R = STR
+        IF (KFLAG.NE.1) GO TO 50
+        CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL)
+        IF (NW.NE.0) GO TO 60
+   50   CONTINUE
+        CYR(KDFLG) = S2R
+        CYI(KDFLG) = S2I
+        YR(I) = S2R*CSRR(KFLAG)
+        YI(I) = S2I*CSRR(KFLAG)
+        IF (KDFLG.EQ.2) GO TO 75
+        KDFLG = 2
+        GO TO 70
+   60   CONTINUE
+        IF (RS1.GT.0.0D0) GO TO 300
+C-----------------------------------------------------------------------
+C     FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW
+C-----------------------------------------------------------------------
+        IF (ZR.LT.0.0D0) GO TO 300
+        KDFLG = 1
+        YR(I)=ZEROR
+        YI(I)=ZEROI
+        NZ=NZ+1
+        IF (I.EQ.1) GO TO 70
+        IF ((YR(I-1).EQ.ZEROR).AND.(YI(I-1).EQ.ZEROI)) GO TO 70
+        YR(I-1)=ZEROR
+        YI(I-1)=ZEROI
+        NZ=NZ+1
+   70 CONTINUE
+      I = N
+   75 CONTINUE
+      RAZR = 1.0D0/ZABS(COMPLEX(ZRR,ZRI))
+      STR = ZRR*RAZR
+      STI = -ZRI*RAZR
+      RZR = (STR+STR)*RAZR
+      RZI = (STI+STI)*RAZR
+      CKR = FN*RZR
+      CKI = FN*RZI
+      IB = I + 1
+      IF (N.LT.IB) GO TO 160
+C-----------------------------------------------------------------------
+C     TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO
+C     ON UNDERFLOW.
+C-----------------------------------------------------------------------
+      FN = FNU + DBLE(FLOAT(N-1))
+      IPARD = 1
+      IF (MR.NE.0) IPARD = 0
+      INITD = 0
+      CALL ZUNIK(ZRR, ZRI, FN, 2, IPARD, TOL, INITD, PHIDR, PHIDI,
+     * ZET1DR, ZET1DI, ZET2DR, ZET2DI, SUMDR, SUMDI, CWRKR(1,3),
+     * CWRKI(1,3))
+      IF (KODE.EQ.1) GO TO 80
+      STR = ZRR + ZET2DR
+      STI = ZRI + ZET2DI
+      RAST = FN/ZABS(COMPLEX(STR,STI))
+      STR = STR*RAST*RAST
+      STI = -STI*RAST*RAST
+      S1R = ZET1DR - STR
+      S1I = ZET1DI - STI
+      GO TO 90
+   80 CONTINUE
+      S1R = ZET1DR - ZET2DR
+      S1I = ZET1DI - ZET2DI
+   90 CONTINUE
+      RS1 = S1R
+      IF (DABS(RS1).GT.ELIM) GO TO 95
+      IF (DABS(RS1).LT.ALIM) GO TO 100
+C----------------------------------------------------------------------------
+C     REFINE ESTIMATE AND TEST
+C-------------------------------------------------------------------------
+      APHI = ZABS(COMPLEX(PHIDR,PHIDI))
+      RS1 = RS1+DLOG(APHI)
+      IF (DABS(RS1).LT.ELIM) GO TO 100
+   95 CONTINUE
+      IF (DABS(RS1).GT.0.0D0) GO TO 300
+C-----------------------------------------------------------------------
+C     FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW
+C-----------------------------------------------------------------------
+      IF (ZR.LT.0.0D0) GO TO 300
+      NZ = N
+      DO 96 I=1,N
+        YR(I) = ZEROR
+        YI(I) = ZEROI
+   96 CONTINUE
+      RETURN
+C---------------------------------------------------------------------------
+C     FORWARD RECUR FOR REMAINDER OF THE SEQUENCE
+C----------------------------------------------------------------------------
+  100 CONTINUE
+      S1R = CYR(1)
+      S1I = CYI(1)
+      S2R = CYR(2)
+      S2I = CYI(2)
+      C1R = CSRR(KFLAG)
+      ASCLE = BRY(KFLAG)
+      DO 120 I=IB,N
+        C2R = S2R
+        C2I = S2I
+        S2R = CKR*C2R - CKI*C2I + S1R
+        S2I = CKR*C2I + CKI*C2R + S1I
+        S1R = C2R
+        S1I = C2I
+        CKR = CKR + RZR
+        CKI = CKI + RZI
+        C2R = S2R*C1R
+        C2I = S2I*C1R
+        YR(I) = C2R
+        YI(I) = C2I
+        IF (KFLAG.GE.3) GO TO 120
+        STR = DABS(C2R)
+        STI = DABS(C2I)
+        C2M = DMAX1(STR,STI)
+        IF (C2M.LE.ASCLE) GO TO 120
+        KFLAG = KFLAG + 1
+        ASCLE = BRY(KFLAG)
+        S1R = S1R*C1R
+        S1I = S1I*C1R
+        S2R = C2R
+        S2I = C2I
+        S1R = S1R*CSSR(KFLAG)
+        S1I = S1I*CSSR(KFLAG)
+        S2R = S2R*CSSR(KFLAG)
+        S2I = S2I*CSSR(KFLAG)
+        C1R = CSRR(KFLAG)
+  120 CONTINUE
+  160 CONTINUE
+      IF (MR.EQ.0) RETURN
+C-----------------------------------------------------------------------
+C     ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0
+C-----------------------------------------------------------------------
+      NZ = 0
+      FMR = DBLE(FLOAT(MR))
+      SGN = -DSIGN(PI,FMR)
+C-----------------------------------------------------------------------
+C     CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP.
+C-----------------------------------------------------------------------
+      CSGNI = SGN
+      INU = INT(SNGL(FNU))
+      FNF = FNU - DBLE(FLOAT(INU))
+      IFN = INU + N - 1
+      ANG = FNF*SGN
+      CSPNR = DCOS(ANG)
+      CSPNI = DSIN(ANG)
+      IF (MOD(IFN,2).EQ.0) GO TO 170
+      CSPNR = -CSPNR
+      CSPNI = -CSPNI
+  170 CONTINUE
+      ASC = BRY(1)
+      IUF = 0
+      KK = N
+      KDFLG = 1
+      IB = IB - 1
+      IC = IB - 1
+      DO 270 K=1,N
+        FN = FNU + DBLE(FLOAT(KK-1))
+C-----------------------------------------------------------------------
+C     LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K
+C     FUNCTION ABOVE
+C-----------------------------------------------------------------------
+        M=3
+        IF (N.GT.2) GO TO 175
+  172   CONTINUE
+        INITD = INIT(J)
+        PHIDR = PHIR(J)
+        PHIDI = PHII(J)
+        ZET1DR = ZETA1R(J)
+        ZET1DI = ZETA1I(J)
+        ZET2DR = ZETA2R(J)
+        ZET2DI = ZETA2I(J)
+        SUMDR = SUMR(J)
+        SUMDI = SUMI(J)
+        M = J
+        J = 3 - J
+        GO TO 180
+  175   CONTINUE
+        IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 180
+        IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 172
+        INITD = 0
+  180   CONTINUE
+        CALL ZUNIK(ZRR, ZRI, FN, 1, 0, TOL, INITD, PHIDR, PHIDI,
+     *   ZET1DR, ZET1DI, ZET2DR, ZET2DI, SUMDR, SUMDI,
+     *   CWRKR(1,M), CWRKI(1,M))
+        IF (KODE.EQ.1) GO TO 200
+        STR = ZRR + ZET2DR
+        STI = ZRI + ZET2DI
+        RAST = FN/ZABS(COMPLEX(STR,STI))
+        STR = STR*RAST*RAST
+        STI = -STI*RAST*RAST
+        S1R = -ZET1DR + STR
+        S1I = -ZET1DI + STI
+        GO TO 210
+  200   CONTINUE
+        S1R = -ZET1DR + ZET2DR
+        S1I = -ZET1DI + ZET2DI
+  210   CONTINUE
+C-----------------------------------------------------------------------
+C     TEST FOR UNDERFLOW AND OVERFLOW
+C-----------------------------------------------------------------------
+        RS1 = S1R
+        IF (DABS(RS1).GT.ELIM) GO TO 260
+        IF (KDFLG.EQ.1) IFLAG = 2
+        IF (DABS(RS1).LT.ALIM) GO TO 220
+C-----------------------------------------------------------------------
+C     REFINE  TEST AND SCALE
+C-----------------------------------------------------------------------
+        APHI = ZABS(COMPLEX(PHIDR,PHIDI))
+        RS1 = RS1 + DLOG(APHI)
+        IF (DABS(RS1).GT.ELIM) GO TO 260
+        IF (KDFLG.EQ.1) IFLAG = 1
+        IF (RS1.LT.0.0D0) GO TO 220
+        IF (KDFLG.EQ.1) IFLAG = 3
+  220   CONTINUE
+        STR = PHIDR*SUMDR - PHIDI*SUMDI
+        STI = PHIDR*SUMDI + PHIDI*SUMDR
+        S2R = -CSGNI*STI
+        S2I = CSGNI*STR
+        STR = DEXP(S1R)*CSSR(IFLAG)
+        S1R = STR*DCOS(S1I)
+        S1I = STR*DSIN(S1I)
+        STR = S2R*S1R - S2I*S1I
+        S2I = S2R*S1I + S2I*S1R
+        S2R = STR
+        IF (IFLAG.NE.1) GO TO 230
+        CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL)
+        IF (NW.EQ.0) GO TO 230
+        S2R = ZEROR
+        S2I = ZEROI
+  230   CONTINUE
+        CYR(KDFLG) = S2R
+        CYI(KDFLG) = S2I
+        C2R = S2R
+        C2I = S2I
+        S2R = S2R*CSRR(IFLAG)
+        S2I = S2I*CSRR(IFLAG)
+C-----------------------------------------------------------------------
+C     ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N
+C-----------------------------------------------------------------------
+        S1R = YR(KK)
+        S1I = YI(KK)
+        IF (KODE.EQ.1) GO TO 250
+        CALL ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NW, ASC, ALIM, IUF)
+        NZ = NZ + NW
+  250   CONTINUE
+        YR(KK) = S1R*CSPNR - S1I*CSPNI + S2R
+        YI(KK) = CSPNR*S1I + CSPNI*S1R + S2I
+        KK = KK - 1
+        CSPNR = -CSPNR
+        CSPNI = -CSPNI
+        IF (C2R.NE.0.0D0 .OR. C2I.NE.0.0D0) GO TO 255
+        KDFLG = 1
+        GO TO 270
+  255   CONTINUE
+        IF (KDFLG.EQ.2) GO TO 275
+        KDFLG = 2
+        GO TO 270
+  260   CONTINUE
+        IF (RS1.GT.0.0D0) GO TO 300
+        S2R = ZEROR
+        S2I = ZEROI
+        GO TO 230
+  270 CONTINUE
+      K = N
+  275 CONTINUE
+      IL = N - K
+      IF (IL.EQ.0) RETURN
+C-----------------------------------------------------------------------
+C     RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE
+C     K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP
+C     INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES.
+C-----------------------------------------------------------------------
+      S1R = CYR(1)
+      S1I = CYI(1)
+      S2R = CYR(2)
+      S2I = CYI(2)
+      CSR = CSRR(IFLAG)
+      ASCLE = BRY(IFLAG)
+      FN = DBLE(FLOAT(INU+IL))
+      DO 290 I=1,IL
+        C2R = S2R
+        C2I = S2I
+        S2R = S1R + (FN+FNF)*(RZR*C2R-RZI*C2I)
+        S2I = S1I + (FN+FNF)*(RZR*C2I+RZI*C2R)
+        S1R = C2R
+        S1I = C2I
+        FN = FN - 1.0D0
+        C2R = S2R*CSR
+        C2I = S2I*CSR
+        CKR = C2R
+        CKI = C2I
+        C1R = YR(KK)
+        C1I = YI(KK)
+        IF (KODE.EQ.1) GO TO 280
+        CALL ZS1S2(ZRR, ZRI, C1R, C1I, C2R, C2I, NW, ASC, ALIM, IUF)
+        NZ = NZ + NW
+  280   CONTINUE
+        YR(KK) = C1R*CSPNR - C1I*CSPNI + C2R
+        YI(KK) = C1R*CSPNI + C1I*CSPNR + C2I
+        KK = KK - 1
+        CSPNR = -CSPNR
+        CSPNI = -CSPNI
+        IF (IFLAG.GE.3) GO TO 290
+        C2R = DABS(CKR)
+        C2I = DABS(CKI)
+        C2M = DMAX1(C2R,C2I)
+        IF (C2M.LE.ASCLE) GO TO 290
+        IFLAG = IFLAG + 1
+        ASCLE = BRY(IFLAG)
+        S1R = S1R*CSR
+        S1I = S1I*CSR
+        S2R = CKR
+        S2I = CKI
+        S1R = S1R*CSSR(IFLAG)
+        S1I = S1I*CSSR(IFLAG)
+        S2R = S2R*CSSR(IFLAG)
+        S2I = S2I*CSSR(IFLAG)
+        CSR = CSRR(IFLAG)
+  290 CONTINUE
+      RETURN
+  300 CONTINUE
+      NZ = -1
+      RETURN
+      END

amos/zunk2.f

@@ -0,0 +1,505 @@
+      SUBROUTINE ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM,
+     * ALIM)
+C***BEGIN PROLOGUE  ZUNK2
+C***REFER TO  ZBESK
+C
+C     ZUNK2 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE
+C     RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE
+C     UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN)
+C     WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR
+C     -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z IF Z IS IN THE RIGHT
+C     HALF PLANE OR ZR=-Z IF Z IS IN THE LEFT HALF PLANE. MR INDIC-
+C     ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION.
+C     NZ=-1 MEANS AN OVERFLOW WILL OCCUR
+C
+C***ROUTINES CALLED  ZAIRY,ZKSCL,ZS1S2,ZUCHK,ZUNHJ,D1MACH,ZABS
+C***END PROLOGUE  ZUNK2
+C     COMPLEX AI,ARG,ARGD,ASUM,ASUMD,BSUM,BSUMD,CFN,CI,CIP,CK,CONE,CRSC,
+C    *CR1,CR2,CS,CSCL,CSGN,CSPN,CSR,CSS,CY,CZERO,C1,C2,DAI,PHI,PHID,RZ,
+C    *S1,S2,Y,Z,ZB,ZETA1,ZETA1D,ZETA2,ZETA2D,ZN,ZR
+      DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGDI,
+     * ARGDR, ARGI, ARGR, ASC, ASCLE, ASUMDI, ASUMDR, ASUMI, ASUMR,
+     * BRY, BSUMDI, BSUMDR, BSUMI, BSUMR, CAR, CIPI, CIPR, CKI, CKR,
+     * CONER, CRSC, CR1I, CR1R, CR2I, CR2R, CSCL, CSGNI, CSI,
+     * CSPNI, CSPNR, CSR, CSRR, CSSR, CYI, CYR, C1I, C1R, C2I, C2M,
+     * C2R, DAII, DAIR, ELIM, FMR, FN, FNF, FNU, HPI, PHIDI, PHIDR,
+     * PHII, PHIR, PI, PTI, PTR, RAST, RAZR, RS1, RZI, RZR, SAR, SGN,
+     * STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, YY, ZBI, ZBR, ZEROI,
+     * ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZET1DI, ZET1DR, ZET2DI,
+     * ZET2DR, ZI, ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS
+      INTEGER I, IB, IFLAG, IFN, IL, IN, INU, IUF, K, KDFLG, KFLAG, KK,
+     * KODE, MR, N, NAI, NDAI, NW, NZ, IDUM, J, IPARD, IC
+      DIMENSION BRY(3), YR(N), YI(N), ASUMR(2), ASUMI(2), BSUMR(2),
+     * BSUMI(2), PHIR(2), PHII(2), ARGR(2), ARGI(2), ZETA1R(2),
+     * ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2), CIPR(4),
+     * CIPI(4), CSSR(3), CSRR(3)
+      DATA ZEROR,ZEROI,CONER,CR1R,CR1I,CR2R,CR2I /
+     1         0.0D0, 0.0D0, 1.0D0,
+     1 1.0D0,1.73205080756887729D0 , -0.5D0,-8.66025403784438647D-01 /
+      DATA HPI, PI, AIC /
+     1     1.57079632679489662D+00,     3.14159265358979324D+00,
+     1     1.26551212348464539D+00/
+      DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4),
+     * CIPI(4) /
+     1  1.0D0,0.0D0 ,  0.0D0,-1.0D0 ,  -1.0D0,0.0D0 ,  0.0D0,1.0D0 /
+C
+      KDFLG = 1
+      NZ = 0
+C-----------------------------------------------------------------------
+C     EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN
+C     THE UNDERFLOW LIMIT
+C-----------------------------------------------------------------------
+      CSCL = 1.0D0/TOL
+      CRSC = TOL
+      CSSR(1) = CSCL
+      CSSR(2) = CONER
+      CSSR(3) = CRSC
+      CSRR(1) = CRSC
+      CSRR(2) = CONER
+      CSRR(3) = CSCL
+      BRY(1) = 1.0D+3*D1MACH(1)/TOL
+      BRY(2) = 1.0D0/BRY(1)
+      BRY(3) = D1MACH(2)
+      ZRR = ZR
+      ZRI = ZI
+      IF (ZR.GE.0.0D0) GO TO 10
+      ZRR = -ZR
+      ZRI = -ZI
+   10 CONTINUE
+      YY = ZRI
+      ZNR = ZRI
+      ZNI = -ZRR
+      ZBR = ZRR
+      ZBI = ZRI
+      INU = INT(SNGL(FNU))
+      FNF = FNU - DBLE(FLOAT(INU))
+      ANG = -HPI*FNF
+      CAR = DCOS(ANG)
+      SAR = DSIN(ANG)
+      C2R = HPI*SAR
+      C2I = -HPI*CAR
+      KK = MOD(INU,4) + 1
+      STR = C2R*CIPR(KK) - C2I*CIPI(KK)
+      STI = C2R*CIPI(KK) + C2I*CIPR(KK)
+      CSR = CR1R*STR - CR1I*STI
+      CSI = CR1R*STI + CR1I*STR
+      IF (YY.GT.0.0D0) GO TO 20
+      ZNR = -ZNR
+      ZBI = -ZBI
+   20 CONTINUE
+C-----------------------------------------------------------------------
+C     K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST
+C     QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY
+C     CONJUGATION SINCE THE K FUNCTION IS REAL ON THE POSITIVE REAL AXIS
+C-----------------------------------------------------------------------
+      J = 2
+      DO 80 I=1,N
+C-----------------------------------------------------------------------
+C     J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J
+C-----------------------------------------------------------------------
+        J = 3 - J
+        FN = FNU + DBLE(FLOAT(I-1))
+        CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR(J), PHII(J), ARGR(J),
+     *   ARGI(J), ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), ASUMR(J),
+     *   ASUMI(J), BSUMR(J), BSUMI(J))
+        IF (KODE.EQ.1) GO TO 30
+        STR = ZBR + ZETA2R(J)
+        STI = ZBI + ZETA2I(J)
+        RAST = FN/ZABS(COMPLEX(STR,STI))
+        STR = STR*RAST*RAST
+        STI = -STI*RAST*RAST
+        S1R = ZETA1R(J) - STR
+        S1I = ZETA1I(J) - STI
+        GO TO 40
+   30   CONTINUE
+        S1R = ZETA1R(J) - ZETA2R(J)
+        S1I = ZETA1I(J) - ZETA2I(J)
+   40   CONTINUE
+C-----------------------------------------------------------------------
+C     TEST FOR UNDERFLOW AND OVERFLOW
+C-----------------------------------------------------------------------
+        RS1 = S1R
+        IF (DABS(RS1).GT.ELIM) GO TO 70
+        IF (KDFLG.EQ.1) KFLAG = 2
+        IF (DABS(RS1).LT.ALIM) GO TO 50
+C-----------------------------------------------------------------------
+C     REFINE  TEST AND SCALE
+C-----------------------------------------------------------------------
+        APHI = ZABS(COMPLEX(PHIR(J),PHII(J)))
+        AARG = ZABS(COMPLEX(ARGR(J),ARGI(J)))
+        RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC
+        IF (DABS(RS1).GT.ELIM) GO TO 70
+        IF (KDFLG.EQ.1) KFLAG = 1
+        IF (RS1.LT.0.0D0) GO TO 50
+        IF (KDFLG.EQ.1) KFLAG = 3
+   50   CONTINUE
+C-----------------------------------------------------------------------
+C     SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR
+C     EXPONENT EXTREMES
+C-----------------------------------------------------------------------
+        C2R = ARGR(J)*CR2R - ARGI(J)*CR2I
+        C2I = ARGR(J)*CR2I + ARGI(J)*CR2R
+        CALL ZAIRY(C2R, C2I, 0, 2, AIR, AII, NAI, IDUM)
+        CALL ZAIRY(C2R, C2I, 1, 2, DAIR, DAII, NDAI, IDUM)
+        STR = DAIR*BSUMR(J) - DAII*BSUMI(J)
+        STI = DAIR*BSUMI(J) + DAII*BSUMR(J)
+        PTR = STR*CR2R - STI*CR2I
+        PTI = STR*CR2I + STI*CR2R
+        STR = PTR + (AIR*ASUMR(J)-AII*ASUMI(J))
+        STI = PTI + (AIR*ASUMI(J)+AII*ASUMR(J))
+        PTR = STR*PHIR(J) - STI*PHII(J)
+        PTI = STR*PHII(J) + STI*PHIR(J)
+        S2R = PTR*CSR - PTI*CSI
+        S2I = PTR*CSI + PTI*CSR
+        STR = DEXP(S1R)*CSSR(KFLAG)
+        S1R = STR*DCOS(S1I)
+        S1I = STR*DSIN(S1I)
+        STR = S2R*S1R - S2I*S1I
+        S2I = S1R*S2I + S2R*S1I
+        S2R = STR
+        IF (KFLAG.NE.1) GO TO 60
+        CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL)
+        IF (NW.NE.0) GO TO 70
+   60   CONTINUE
+        IF (YY.LE.0.0D0) S2I = -S2I
+        CYR(KDFLG) = S2R
+        CYI(KDFLG) = S2I
+        YR(I) = S2R*CSRR(KFLAG)
+        YI(I) = S2I*CSRR(KFLAG)
+        STR = CSI
+        CSI = -CSR
+        CSR = STR
+        IF (KDFLG.EQ.2) GO TO 85
+        KDFLG = 2
+        GO TO 80
+   70   CONTINUE
+        IF (RS1.GT.0.0D0) GO TO 320
+C-----------------------------------------------------------------------
+C     FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW
+C-----------------------------------------------------------------------
+        IF (ZR.LT.0.0D0) GO TO 320
+        KDFLG = 1
+        YR(I)=ZEROR
+        YI(I)=ZEROI
+        NZ=NZ+1
+        STR = CSI
+        CSI =-CSR
+        CSR = STR
+        IF (I.EQ.1) GO TO 80
+        IF ((YR(I-1).EQ.ZEROR).AND.(YI(I-1).EQ.ZEROI)) GO TO 80
+        YR(I-1)=ZEROR
+        YI(I-1)=ZEROI
+        NZ=NZ+1
+   80 CONTINUE
+      I = N
+   85 CONTINUE
+      RAZR = 1.0D0/ZABS(COMPLEX(ZRR,ZRI))
+      STR = ZRR*RAZR
+      STI = -ZRI*RAZR
+      RZR = (STR+STR)*RAZR
+      RZI = (STI+STI)*RAZR
+      CKR = FN*RZR
+      CKI = FN*RZI
+      IB = I + 1
+      IF (N.LT.IB) GO TO 180
+C-----------------------------------------------------------------------
+C     TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO
+C     ON UNDERFLOW.
+C-----------------------------------------------------------------------
+      FN = FNU + DBLE(FLOAT(N-1))
+      IPARD = 1
+      IF (MR.NE.0) IPARD = 0
+      CALL ZUNHJ(ZNR, ZNI, FN, IPARD, TOL, PHIDR, PHIDI, ARGDR, ARGDI,
+     * ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR, ASUMDI, BSUMDR, BSUMDI)
+      IF (KODE.EQ.1) GO TO 90
+      STR = ZBR + ZET2DR
+      STI = ZBI + ZET2DI
+      RAST = FN/ZABS(COMPLEX(STR,STI))
+      STR = STR*RAST*RAST
+      STI = -STI*RAST*RAST
+      S1R = ZET1DR - STR
+      S1I = ZET1DI - STI
+      GO TO 100
+   90 CONTINUE
+      S1R = ZET1DR - ZET2DR
+      S1I = ZET1DI - ZET2DI
+  100 CONTINUE
+      RS1 = S1R
+      IF (DABS(RS1).GT.ELIM) GO TO 105
+      IF (DABS(RS1).LT.ALIM) GO TO 120
+C----------------------------------------------------------------------------
+C     REFINE ESTIMATE AND TEST
+C-------------------------------------------------------------------------
+      APHI = ZABS(COMPLEX(PHIDR,PHIDI))
+      RS1 = RS1+DLOG(APHI)
+      IF (DABS(RS1).LT.ELIM) GO TO 120
+  105 CONTINUE
+      IF (RS1.GT.0.0D0) GO TO 320
+C-----------------------------------------------------------------------
+C     FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW
+C-----------------------------------------------------------------------
+      IF (ZR.LT.0.0D0) GO TO 320
+      NZ = N
+      DO 106 I=1,N
+        YR(I) = ZEROR
+        YI(I) = ZEROI
+  106 CONTINUE
+      RETURN
+  120 CONTINUE
+      S1R = CYR(1)
+      S1I = CYI(1)
+      S2R = CYR(2)
+      S2I = CYI(2)
+      C1R = CSRR(KFLAG)
+      ASCLE = BRY(KFLAG)
+      DO 130 I=IB,N
+        C2R = S2R
+        C2I = S2I
+        S2R = CKR*C2R - CKI*C2I + S1R
+        S2I = CKR*C2I + CKI*C2R + S1I
+        S1R = C2R
+        S1I = C2I
+        CKR = CKR + RZR
+        CKI = CKI + RZI
+        C2R = S2R*C1R
+        C2I = S2I*C1R
+        YR(I) = C2R
+        YI(I) = C2I
+        IF (KFLAG.GE.3) GO TO 130
+        STR = DABS(C2R)
+        STI = DABS(C2I)
+        C2M = DMAX1(STR,STI)
+        IF (C2M.LE.ASCLE) GO TO 130
+        KFLAG = KFLAG + 1
+        ASCLE = BRY(KFLAG)
+        S1R = S1R*C1R
+        S1I = S1I*C1R
+        S2R = C2R
+        S2I = C2I
+        S1R = S1R*CSSR(KFLAG)
+        S1I = S1I*CSSR(KFLAG)
+        S2R = S2R*CSSR(KFLAG)
+        S2I = S2I*CSSR(KFLAG)
+        C1R = CSRR(KFLAG)
+  130 CONTINUE
+  180 CONTINUE
+      IF (MR.EQ.0) RETURN
+C-----------------------------------------------------------------------
+C     ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0
+C-----------------------------------------------------------------------
+      NZ = 0
+      FMR = DBLE(FLOAT(MR))
+      SGN = -DSIGN(PI,FMR)
+C-----------------------------------------------------------------------
+C     CSPN AND CSGN ARE COEFF OF K AND I FUNCIONS RESP.
+C-----------------------------------------------------------------------
+      CSGNI = SGN
+      IF (YY.LE.0.0D0) CSGNI = -CSGNI
+      IFN = INU + N - 1
+      ANG = FNF*SGN
+      CSPNR = DCOS(ANG)
+      CSPNI = DSIN(ANG)
+      IF (MOD(IFN,2).EQ.0) GO TO 190
+      CSPNR = -CSPNR
+      CSPNI = -CSPNI
+  190 CONTINUE
+C-----------------------------------------------------------------------
+C     CS=COEFF OF THE J FUNCTION TO GET THE I FUNCTION. I(FNU,Z) IS
+C     COMPUTED FROM EXP(I*FNU*HPI)*J(FNU,-I*Z) WHERE Z IS IN THE FIRST
+C     QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY
+C     CONJUGATION SINCE THE I FUNCTION IS REAL ON THE POSITIVE REAL AXIS
+C-----------------------------------------------------------------------
+      CSR = SAR*CSGNI
+      CSI = CAR*CSGNI
+      IN = MOD(IFN,4) + 1
+      C2R = CIPR(IN)
+      C2I = CIPI(IN)
+      STR = CSR*C2R + CSI*C2I
+      CSI = -CSR*C2I + CSI*C2R
+      CSR = STR
+      ASC = BRY(1)
+      IUF = 0
+      KK = N
+      KDFLG = 1
+      IB = IB - 1
+      IC = IB - 1
+      DO 290 K=1,N
+        FN = FNU + DBLE(FLOAT(KK-1))
+C-----------------------------------------------------------------------
+C     LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K
+C     FUNCTION ABOVE
+C-----------------------------------------------------------------------
+        IF (N.GT.2) GO TO 175
+  172   CONTINUE
+        PHIDR = PHIR(J)
+        PHIDI = PHII(J)
+        ARGDR = ARGR(J)
+        ARGDI = ARGI(J)
+        ZET1DR = ZETA1R(J)
+        ZET1DI = ZETA1I(J)
+        ZET2DR = ZETA2R(J)
+        ZET2DI = ZETA2I(J)
+        ASUMDR = ASUMR(J)
+        ASUMDI = ASUMI(J)
+        BSUMDR = BSUMR(J)
+        BSUMDI = BSUMI(J)
+        J = 3 - J
+        GO TO 210
+  175   CONTINUE
+        IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 210
+        IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 172
+        CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIDR, PHIDI, ARGDR,
+     *   ARGDI, ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR,
+     *   ASUMDI, BSUMDR, BSUMDI)
+  210   CONTINUE
+        IF (KODE.EQ.1) GO TO 220
+        STR = ZBR + ZET2DR
+        STI = ZBI + ZET2DI
+        RAST = FN/ZABS(COMPLEX(STR,STI))
+        STR = STR*RAST*RAST
+        STI = -STI*RAST*RAST
+        S1R = -ZET1DR + STR
+        S1I = -ZET1DI + STI
+        GO TO 230
+  220   CONTINUE
+        S1R = -ZET1DR + ZET2DR
+        S1I = -ZET1DI + ZET2DI
+  230   CONTINUE
+C-----------------------------------------------------------------------
+C     TEST FOR UNDERFLOW AND OVERFLOW
+C-----------------------------------------------------------------------
+        RS1 = S1R
+        IF (DABS(RS1).GT.ELIM) GO TO 280
+        IF (KDFLG.EQ.1) IFLAG = 2
+        IF (DABS(RS1).LT.ALIM) GO TO 240
+C-----------------------------------------------------------------------
+C     REFINE  TEST AND SCALE
+C-----------------------------------------------------------------------
+        APHI = ZABS(COMPLEX(PHIDR,PHIDI))
+        AARG = ZABS(COMPLEX(ARGDR,ARGDI))
+        RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC
+        IF (DABS(RS1).GT.ELIM) GO TO 280
+        IF (KDFLG.EQ.1) IFLAG = 1
+        IF (RS1.LT.0.0D0) GO TO 240
+        IF (KDFLG.EQ.1) IFLAG = 3
+  240   CONTINUE
+        CALL ZAIRY(ARGDR, ARGDI, 0, 2, AIR, AII, NAI, IDUM)
+        CALL ZAIRY(ARGDR, ARGDI, 1, 2, DAIR, DAII, NDAI, IDUM)
+        STR = DAIR*BSUMDR - DAII*BSUMDI
+        STI = DAIR*BSUMDI + DAII*BSUMDR
+        STR = STR + (AIR*ASUMDR-AII*ASUMDI)
+        STI = STI + (AIR*ASUMDI+AII*ASUMDR)
+        PTR = STR*PHIDR - STI*PHIDI
+        PTI = STR*PHIDI + STI*PHIDR
+        S2R = PTR*CSR - PTI*CSI
+        S2I = PTR*CSI + PTI*CSR
+        STR = DEXP(S1R)*CSSR(IFLAG)
+        S1R = STR*DCOS(S1I)
+        S1I = STR*DSIN(S1I)
+        STR = S2R*S1R - S2I*S1I
+        S2I = S2R*S1I + S2I*S1R
+        S2R = STR
+        IF (IFLAG.NE.1) GO TO 250
+        CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL)
+        IF (NW.EQ.0) GO TO 250
+        S2R = ZEROR
+        S2I = ZEROI
+  250   CONTINUE
+        IF (YY.LE.0.0D0) S2I = -S2I
+        CYR(KDFLG) = S2R
+        CYI(KDFLG) = S2I
+        C2R = S2R
+        C2I = S2I
+        S2R = S2R*CSRR(IFLAG)
+        S2I = S2I*CSRR(IFLAG)
+C-----------------------------------------------------------------------
+C     ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N
+C-----------------------------------------------------------------------
+        S1R = YR(KK)
+        S1I = YI(KK)
+        IF (KODE.EQ.1) GO TO 270
+        CALL ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NW, ASC, ALIM, IUF)
+        NZ = NZ + NW
+  270   CONTINUE
+        YR(KK) = S1R*CSPNR - S1I*CSPNI + S2R
+        YI(KK) = S1R*CSPNI + S1I*CSPNR + S2I
+        KK = KK - 1
+        CSPNR = -CSPNR
+        CSPNI = -CSPNI
+        STR = CSI
+        CSI = -CSR
+        CSR = STR
+        IF (C2R.NE.0.0D0 .OR. C2I.NE.0.0D0) GO TO 255
+        KDFLG = 1
+        GO TO 290
+  255   CONTINUE
+        IF (KDFLG.EQ.2) GO TO 295
+        KDFLG = 2
+        GO TO 290
+  280   CONTINUE
+        IF (RS1.GT.0.0D0) GO TO 320
+        S2R = ZEROR
+        S2I = ZEROI
+        GO TO 250
+  290 CONTINUE
+      K = N
+  295 CONTINUE
+      IL = N - K
+      IF (IL.EQ.0) RETURN
+C-----------------------------------------------------------------------
+C     RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE
+C     K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP
+C     INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES.
+C-----------------------------------------------------------------------
+      S1R = CYR(1)
+      S1I = CYI(1)
+      S2R = CYR(2)
+      S2I = CYI(2)
+      CSR = CSRR(IFLAG)
+      ASCLE = BRY(IFLAG)
+      FN = DBLE(FLOAT(INU+IL))
+      DO 310 I=1,IL
+        C2R = S2R
+        C2I = S2I
+        S2R = S1R + (FN+FNF)*(RZR*C2R-RZI*C2I)
+        S2I = S1I + (FN+FNF)*(RZR*C2I+RZI*C2R)
+        S1R = C2R
+        S1I = C2I
+        FN = FN - 1.0D0
+        C2R = S2R*CSR
+        C2I = S2I*CSR
+        CKR = C2R
+        CKI = C2I
+        C1R = YR(KK)
+        C1I = YI(KK)
+        IF (KODE.EQ.1) GO TO 300
+        CALL ZS1S2(ZRR, ZRI, C1R, C1I, C2R, C2I, NW, ASC, ALIM, IUF)
+        NZ = NZ + NW
+  300   CONTINUE
+        YR(KK) = C1R*CSPNR - C1I*CSPNI + C2R
+        YI(KK) = C1R*CSPNI + C1I*CSPNR + C2I
+        KK = KK - 1
+        CSPNR = -CSPNR
+        CSPNI = -CSPNI
+        IF (IFLAG.GE.3) GO TO 310
+        C2R = DABS(CKR)
+        C2I = DABS(CKI)
+        C2M = DMAX1(C2R,C2I)
+        IF (C2M.LE.ASCLE) GO TO 310
+        IFLAG = IFLAG + 1
+        ASCLE = BRY(IFLAG)
+        S1R = S1R*CSR
+        S1I = S1I*CSR
+        S2R = CKR
+        S2I = CKI
+        S1R = S1R*CSSR(IFLAG)
+        S1I = S1I*CSSR(IFLAG)
+        S2R = S2R*CSSR(IFLAG)
+        S2I = S2I*CSSR(IFLAG)
+        CSR = CSRR(IFLAG)
+  310 CONTINUE
+      RETURN
+  320 CONTINUE
+      NZ = -1
+      RETURN
+      END

amos/zuoik.f

@@ -0,0 +1,194 @@
+      SUBROUTINE ZUOIK(ZR, ZI, FNU, KODE, IKFLG, N, YR, YI, NUF, TOL,
+     * ELIM, ALIM)
+C***BEGIN PROLOGUE  ZUOIK
+C***REFER TO  ZBESI,ZBESK,ZBESH
+C
+C     ZUOIK COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC
+C     EXPANSIONS FOR THE I AND K FUNCTIONS AND COMPARES THEM
+C     (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW
+C     WHERE ALIM.LT.ELIM. IF THE MAGNITUDE, BASED ON THE LEADING
+C     EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN
+C     THE RESULT IS ON SCALE. IF NOT, THEN A REFINED TEST USING OTHER
+C     MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE
+C     EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)=
+C     EXP(-ELIM)/TOL
+C
+C     IKFLG=1 MEANS THE I SEQUENCE IS TESTED
+C          =2 MEANS THE K SEQUENCE IS TESTED
+C     NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE
+C         =-1 MEANS AN OVERFLOW WOULD OCCUR
+C     IKFLG=1 AND NUF.GT.0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO
+C             THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE
+C     IKFLG=2 AND NUF.EQ.N MEANS ALL Y VALUES WERE SET TO ZERO
+C     IKFLG=2 AND 0.LT.NUF.LT.N NOT CONSIDERED. Y MUST BE SET BY
+C             ANOTHER ROUTINE
+C
+C***ROUTINES CALLED  ZUCHK,ZUNHJ,ZUNIK,D1MACH,ZABS,ZLOG
+C***END PROLOGUE  ZUOIK
+C     COMPLEX ARG,ASUM,BSUM,CWRK,CZ,CZERO,PHI,SUM,Y,Z,ZB,ZETA1,ZETA2,ZN,
+C    *ZR
+      DOUBLE PRECISION AARG, AIC, ALIM, APHI, ARGI, ARGR, ASUMI, ASUMR,
+     * ASCLE, AX, AY, BSUMI, BSUMR, CWRKI, CWRKR, CZI, CZR, ELIM, FNN,
+     * FNU, GNN, GNU, PHII, PHIR, RCZ, STR, STI, SUMI, SUMR, TOL, YI,
+     * YR, ZBI, ZBR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI,
+     * ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS
+      INTEGER I, IDUM, IFORM, IKFLG, INIT, KODE, N, NN, NUF, NW
+      DIMENSION YR(N), YI(N), CWRKR(16), CWRKI(16)
+      DATA ZEROR,ZEROI / 0.0D0, 0.0D0 /
+      DATA AIC / 1.265512123484645396D+00 /
+      NUF = 0
+      NN = N
+      ZRR = ZR
+      ZRI = ZI
+      IF (ZR.GE.0.0D0) GO TO 10
+      ZRR = -ZR
+      ZRI = -ZI
+   10 CONTINUE
+      ZBR = ZRR
+      ZBI = ZRI
+      AX = DABS(ZR)*1.7321D0
+      AY = DABS(ZI)
+      IFORM = 1
+      IF (AY.GT.AX) IFORM = 2
+      GNU = DMAX1(FNU,1.0D0)
+      IF (IKFLG.EQ.1) GO TO 20
+      FNN = DBLE(FLOAT(NN))
+      GNN = FNU + FNN - 1.0D0
+      GNU = DMAX1(GNN,FNN)
+   20 CONTINUE
+C-----------------------------------------------------------------------
+C     ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE
+C     REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET
+C     THE SIGN OF THE IMAGINARY PART CORRECT.
+C-----------------------------------------------------------------------
+      IF (IFORM.EQ.2) GO TO 30
+      INIT = 0
+      CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII,
+     * ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI)
+      CZR = -ZETA1R + ZETA2R
+      CZI = -ZETA1I + ZETA2I
+      GO TO 50
+   30 CONTINUE
+      ZNR = ZRI
+      ZNI = -ZRR
+      IF (ZI.GT.0.0D0) GO TO 40
+      ZNR = -ZNR
+   40 CONTINUE
+      CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R,
+     * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI)
+      CZR = -ZETA1R + ZETA2R
+      CZI = -ZETA1I + ZETA2I
+      AARG = ZABS(COMPLEX(ARGR,ARGI))
+   50 CONTINUE
+      IF (KODE.EQ.1) GO TO 60
+      CZR = CZR - ZBR
+      CZI = CZI - ZBI
+   60 CONTINUE
+      IF (IKFLG.EQ.1) GO TO 70
+      CZR = -CZR
+      CZI = -CZI
+   70 CONTINUE
+      APHI = ZABS(COMPLEX(PHIR,PHII))
+      RCZ = CZR
+C-----------------------------------------------------------------------
+C     OVERFLOW TEST
+C-----------------------------------------------------------------------
+      IF (RCZ.GT.ELIM) GO TO 210
+      IF (RCZ.LT.ALIM) GO TO 80
+      RCZ = RCZ + DLOG(APHI)
+      IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC
+      IF (RCZ.GT.ELIM) GO TO 210
+      GO TO 130
+   80 CONTINUE
+C-----------------------------------------------------------------------
+C     UNDERFLOW TEST
+C-----------------------------------------------------------------------
+      IF (RCZ.LT.(-ELIM)) GO TO 90
+      IF (RCZ.GT.(-ALIM)) GO TO 130
+      RCZ = RCZ + DLOG(APHI)
+      IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC
+      IF (RCZ.GT.(-ELIM)) GO TO 110
+   90 CONTINUE
+      DO 100 I=1,NN
+        YR(I) = ZEROR
+        YI(I) = ZEROI
+  100 CONTINUE
+      NUF = NN
+      RETURN
+  110 CONTINUE
+      ASCLE = 1.0D+3*D1MACH(1)/TOL
+      CALL ZLOG(PHIR, PHII, STR, STI, IDUM)
+      CZR = CZR + STR
+      CZI = CZI + STI
+      IF (IFORM.EQ.1) GO TO 120
+      CALL ZLOG(ARGR, ARGI, STR, STI, IDUM)
+      CZR = CZR - 0.25D0*STR - AIC
+      CZI = CZI - 0.25D0*STI
+  120 CONTINUE
+      AX = DEXP(RCZ)/TOL
+      AY = CZI
+      CZR = AX*DCOS(AY)
+      CZI = AX*DSIN(AY)
+      CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL)
+      IF (NW.NE.0) GO TO 90
+  130 CONTINUE
+      IF (IKFLG.EQ.2) RETURN
+      IF (N.EQ.1) RETURN
+C-----------------------------------------------------------------------
+C     SET UNDERFLOWS ON I SEQUENCE
+C-----------------------------------------------------------------------
+  140 CONTINUE
+      GNU = FNU + DBLE(FLOAT(NN-1))
+      IF (IFORM.EQ.2) GO TO 150
+      INIT = 0
+      CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII,
+     * ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI)
+      CZR = -ZETA1R + ZETA2R
+      CZI = -ZETA1I + ZETA2I
+      GO TO 160
+  150 CONTINUE
+      CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R,
+     * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI)
+      CZR = -ZETA1R + ZETA2R
+      CZI = -ZETA1I + ZETA2I
+      AARG = ZABS(COMPLEX(ARGR,ARGI))
+  160 CONTINUE
+      IF (KODE.EQ.1) GO TO 170
+      CZR = CZR - ZBR
+      CZI = CZI - ZBI
+  170 CONTINUE
+      APHI = ZABS(COMPLEX(PHIR,PHII))
+      RCZ = CZR
+      IF (RCZ.LT.(-ELIM)) GO TO 180
+      IF (RCZ.GT.(-ALIM)) RETURN
+      RCZ = RCZ + DLOG(APHI)
+      IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC
+      IF (RCZ.GT.(-ELIM)) GO TO 190
+  180 CONTINUE
+      YR(NN) = ZEROR
+      YI(NN) = ZEROI
+      NN = NN - 1
+      NUF = NUF + 1
+      IF (NN.EQ.0) RETURN
+      GO TO 140
+  190 CONTINUE
+      ASCLE = 1.0D+3*D1MACH(1)/TOL
+      CALL ZLOG(PHIR, PHII, STR, STI, IDUM)
+      CZR = CZR + STR
+      CZI = CZI + STI
+      IF (IFORM.EQ.1) GO TO 200
+      CALL ZLOG(ARGR, ARGI, STR, STI, IDUM)
+      CZR = CZR - 0.25D0*STR - AIC
+      CZI = CZI - 0.25D0*STI
+  200 CONTINUE
+      AX = DEXP(RCZ)/TOL
+      AY = CZI
+      CZR = AX*DCOS(AY)
+      CZI = AX*DSIN(AY)
+      CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL)
+      IF (NW.NE.0) GO TO 180
+      RETURN
+  210 CONTINUE
+      NUF = -1
+      RETURN
+      END

amos/zwrsk.f

@@ -0,0 +1,94 @@
+      SUBROUTINE ZWRSK(ZRR, ZRI, FNU, KODE, N, YR, YI, NZ, CWR, CWI,
+     * TOL, ELIM, ALIM)
+C***BEGIN PROLOGUE  ZWRSK
+C***REFER TO  ZBESI,ZBESK
+C
+C     ZWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY
+C     NORMALIZING THE I FUNCTION RATIOS FROM ZRATI BY THE WRONSKIAN
+C
+C***ROUTINES CALLED  D1MACH,ZBKNU,ZRATI,ZABS
+C***END PROLOGUE  ZWRSK
+C     COMPLEX CINU,CSCL,CT,CW,C1,C2,RCT,ST,Y,ZR
+      DOUBLE PRECISION ACT, ACW, ALIM, ASCLE, CINUI, CINUR, CSCLR, CTI,
+     * CTR, CWI, CWR, C1I, C1R, C2I, C2R, ELIM, FNU, PTI, PTR, RACT,
+     * STI, STR, TOL, YI, YR, ZRI, ZRR, ZABS, D1MACH
+      INTEGER I, KODE, N, NW, NZ
+      DIMENSION YR(N), YI(N), CWR(2), CWI(2)
+C-----------------------------------------------------------------------
+C     I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS
+C     Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM CRATI NORMALIZED BY THE
+C     WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM CBKNU.
+C-----------------------------------------------------------------------
+      NZ = 0
+      CALL ZBKNU(ZRR, ZRI, FNU, KODE, 2, CWR, CWI, NW, TOL, ELIM, ALIM)
+      IF (NW.NE.0) GO TO 50
+      CALL ZRATI(ZRR, ZRI, FNU, N, YR, YI, TOL)
+C-----------------------------------------------------------------------
+C     RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z),
+C     R(FNU+J-1,Z)=Y(J),  J=1,...,N
+C-----------------------------------------------------------------------
+      CINUR = 1.0D0
+      CINUI = 0.0D0
+      IF (KODE.EQ.1) GO TO 10
+      CINUR = DCOS(ZRI)
+      CINUI = DSIN(ZRI)
+   10 CONTINUE
+C-----------------------------------------------------------------------
+C     ON LOW EXPONENT MACHINES THE K FUNCTIONS CAN BE CLOSE TO BOTH
+C     THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE
+C     SCALED TO PREVENT OVER OR UNDERFLOW. CUOIK HAS DETERMINED THAT
+C     THE RESULT IS ON SCALE.
+C-----------------------------------------------------------------------
+      ACW = ZABS(COMPLEX(CWR(2),CWI(2)))
+      ASCLE = 1.0D+3*D1MACH(1)/TOL
+      CSCLR = 1.0D0
+      IF (ACW.GT.ASCLE) GO TO 20
+      CSCLR = 1.0D0/TOL
+      GO TO 30
+   20 CONTINUE
+      ASCLE = 1.0D0/ASCLE
+      IF (ACW.LT.ASCLE) GO TO 30
+      CSCLR = TOL
+   30 CONTINUE
+      C1R = CWR(1)*CSCLR
+      C1I = CWI(1)*CSCLR
+      C2R = CWR(2)*CSCLR
+      C2I = CWI(2)*CSCLR
+      STR = YR(1)
+      STI = YI(1)
+C-----------------------------------------------------------------------
+C     CINU=CINU*(CONJG(CT)/CABS(CT))*(1.0D0/CABS(CT) PREVENTS
+C     UNDER- OR OVERFLOW PREMATURELY BY SQUARING CABS(CT)
+C-----------------------------------------------------------------------
+      PTR = STR*C1R - STI*C1I
+      PTI = STR*C1I + STI*C1R
+      PTR = PTR + C2R
+      PTI = PTI + C2I
+      CTR = ZRR*PTR - ZRI*PTI
+      CTI = ZRR*PTI + ZRI*PTR
+      ACT = ZABS(COMPLEX(CTR,CTI))
+      RACT = 1.0D0/ACT
+      CTR = CTR*RACT
+      CTI = -CTI*RACT
+      PTR = CINUR*RACT
+      PTI = CINUI*RACT
+      CINUR = PTR*CTR - PTI*CTI
+      CINUI = PTR*CTI + PTI*CTR
+      YR(1) = CINUR*CSCLR
+      YI(1) = CINUI*CSCLR
+      IF (N.EQ.1) RETURN
+      DO 40 I=2,N
+        PTR = STR*CINUR - STI*CINUI
+        CINUI = STR*CINUI + STI*CINUR
+        CINUR = PTR
+        STR = YR(I)
+        STI = YI(I)
+        YR(I) = CINUR*CSCLR
+        YI(I) = CINUI*CSCLR
+   40 CONTINUE
+      RETURN
+   50 CONTINUE
+      NZ = -1
+      IF(NW.EQ.(-2)) NZ=-2
+      RETURN
+      END