!! ------- COMBINED FORTRAN CODE USING PYTHON SCRIPT BY P. WIECHA, 2016 ---------


FUNCTION D1MACH (I)
!
!! D1MACH returns floating point machine dependent constants.
!
!***LIBRARY   SLATEC
!***CATEGORY  R1
!***TYPE      DOUBLE PRECISION (R1MACH-S, D1MACH-D)
!***KEYWORDS  MACHINE CONSTANTS
!***AUTHOR  Fox, P. A., (Bell Labs)
!           Hall, A. D., (Bell Labs)
!           Schryer, N. L., (Bell Labs)
!***DESCRIPTION
!
!   D1MACH can be used to obtain machine-dependent parameters for the
!   local machine environment.  It is a function subprogram with one
!   (input) argument, and can be referenced as follows:
!
!        D = D1MACH(I)
!
!   where I=1,...,5.  The (output) value of D above is determined by
!   the (input) value of I.  The results for various values of I are
!   discussed below.
!
!   D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude.
!   D1MACH( 2) = B**EMAX*(1 - B**(-T)), the largest magnitude.
!   D1MACH( 3) = B**(-T), the smallest relative spacing.
!   D1MACH( 4) = B**(1-T), the largest relative spacing.
!   D1MACH( 5) = LOG10(B)
!
!   Assume double precision numbers are represented in the T-digit,
!   base-B form
!
!              sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
!
!   where 0  <=  X(I)  <  B for I=1,...,T, 0  <  X(1), and
!   EMIN  <=  E  <=  EMAX.
!
!   The values of B, T, EMIN and EMAX are provided in I1MACH as
!   follows:
!   I1MACH(10) = B, the base.
!   I1MACH(14) = T, the number of base-B digits.
!   I1MACH(15) = EMIN, the smallest exponent E.
!   I1MACH(16) = EMAX, the largest exponent E.
!
!   To alter this function for a particular environment, the desired
!   set of DATA statements should be activated by removing the C from
!   column 1.  Also, the values of D1MACH(1) - D1MACH(4) should be
!   checked for consistency with the local operating system.
!
!***REFERENCES  P. A. Fox, A. D. Hall and N. L. Schryer, Framework for
!                 a portable library, ACM Transactions on Mathematical
!                 Software 4, 2 (June 1978), pp. 177-188.
!***ROUTINES CALLED  XERMSG
!***REVISION HISTORY  (YYMMDD)
!   750101  DATE WRITTEN
!   890213  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
!   900618  Added DEC RISC constants.  (WRB)
!   900723  Added IBM RS 6000 constants.  (WRB)
!   900911  Added SUN 386i constants.  (WRB)
!   910710  Added HP 730 constants.  (SMR)
!   911114  Added Convex IEEE constants.  (WRB)
!   920121  Added SUN -r8 compiler option constants.  (WRB)
!   920229  Added Touchstone Delta i860 constants.  (WRB)
!   920501  Reformatted the REFERENCES section.  (WRB)
!   920625  Added CONVEX -p8 and -pd8 compiler option constants.
!           (BKS, WRB)
!   930201  Added DEC Alpha and SGI constants.  (RWC and WRB)
!***END PROLOGUE  D1MACH
!
  double precision d1mach
  integer i
  INTEGER SMALL(4)
  INTEGER LARGE(4)
  INTEGER RIGHT(4)
  INTEGER DIVER(4)
  INTEGER LOG10(4)
!
  DOUBLE PRECISION DMACH(5)
  SAVE DMACH
!
  EQUIVALENCE (DMACH(1),SMALL(1))
  EQUIVALENCE (DMACH(2),LARGE(1))
  EQUIVALENCE (DMACH(3),RIGHT(1))
  EQUIVALENCE (DMACH(4),DIVER(1))
  EQUIVALENCE (DMACH(5),LOG10(1))
!
!     MACHINE CONSTANTS FOR THE AMIGA
!     ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION
!
!     DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' /
!     DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' /
!     DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' /
!     DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' /
!     DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' /
!
!     MACHINE CONSTANTS FOR THE AMIGA
!     ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT
!
!     DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' /
!     DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' /
!     DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' /
!     DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' /
!     DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' /
!
!     MACHINE CONSTANTS FOR THE APOLLO
!
!     DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 /
!     DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF /
!     DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 /
!     DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 /
!     DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF /
!
!     MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM
!
!     DATA SMALL(1) / ZC00800000 /
!     DATA SMALL(2) / Z000000000 /
!     DATA LARGE(1) / ZDFFFFFFFF /
!     DATA LARGE(2) / ZFFFFFFFFF /
!     DATA RIGHT(1) / ZCC5800000 /
!     DATA RIGHT(2) / Z000000000 /
!     DATA DIVER(1) / ZCC6800000 /
!     DATA DIVER(2) / Z000000000 /
!     DATA LOG10(1) / ZD00E730E7 /
!     DATA LOG10(2) / ZC77800DC0 /
!
!     MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM
!
!     DATA SMALL(1) / O1771000000000000 /
!     DATA SMALL(2) / O0000000000000000 /
!     DATA LARGE(1) / O0777777777777777 /
!     DATA LARGE(2) / O0007777777777777 /
!     DATA RIGHT(1) / O1461000000000000 /
!     DATA RIGHT(2) / O0000000000000000 /
!     DATA DIVER(1) / O1451000000000000 /
!     DATA DIVER(2) / O0000000000000000 /
!     DATA LOG10(1) / O1157163034761674 /
!     DATA LOG10(2) / O0006677466732724 /
!
!     MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS
!
!     DATA SMALL(1) / O1771000000000000 /
!     DATA SMALL(2) / O7770000000000000 /
!     DATA LARGE(1) / O0777777777777777 /
!     DATA LARGE(2) / O7777777777777777 /
!     DATA RIGHT(1) / O1461000000000000 /
!     DATA RIGHT(2) / O0000000000000000 /
!     DATA DIVER(1) / O1451000000000000 /
!     DATA DIVER(2) / O0000000000000000 /
!     DATA LOG10(1) / O1157163034761674 /
!     DATA LOG10(2) / O0006677466732724 /
!
!     MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE
!
!     DATA SMALL(1) / Z"3001800000000000" /
!     DATA SMALL(2) / Z"3001000000000000" /
!     DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" /
!     DATA LARGE(2) / Z"4FFE000000000000" /
!     DATA RIGHT(1) / Z"3FD2800000000000" /
!     DATA RIGHT(2) / Z"3FD2000000000000" /
!     DATA DIVER(1) / Z"3FD3800000000000" /
!     DATA DIVER(2) / Z"3FD3000000000000" /
!     DATA LOG10(1) / Z"3FFF9A209A84FBCF" /
!     DATA LOG10(2) / Z"3FFFF7988F8959AC" /
!
!     MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES
!
!     DATA SMALL(1) / 00564000000000000000B /
!     DATA SMALL(2) / 00000000000000000000B /
!     DATA LARGE(1) / 37757777777777777777B /
!     DATA LARGE(2) / 37157777777777777777B /
!     DATA RIGHT(1) / 15624000000000000000B /
!     DATA RIGHT(2) / 00000000000000000000B /
!     DATA DIVER(1) / 15634000000000000000B /
!     DATA DIVER(2) / 00000000000000000000B /
!     DATA LOG10(1) / 17164642023241175717B /
!     DATA LOG10(2) / 16367571421742254654B /
!
!     MACHINE CONSTANTS FOR THE CELERITY C1260
!
!     DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' /
!     DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' /
!     DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' /
!     DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' /
!     DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' /
!
!     MACHINE CONSTANTS FOR THE CONVEX
!     USING THE -fn OR -pd8 COMPILER OPTION
!
!     DATA DMACH(1) / Z'0010000000000000' /
!     DATA DMACH(2) / Z'7FFFFFFFFFFFFFFF' /
!     DATA DMACH(3) / Z'3CC0000000000000' /
!     DATA DMACH(4) / Z'3CD0000000000000' /
!     DATA DMACH(5) / Z'3FF34413509F79FF' /
!
!     MACHINE CONSTANTS FOR THE CONVEX
!     USING THE -fi COMPILER OPTION
!
!     DATA DMACH(1) / Z'0010000000000000' /
!     DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' /
!     DATA DMACH(3) / Z'3CA0000000000000' /
!     DATA DMACH(4) / Z'3CB0000000000000' /
!     DATA DMACH(5) / Z'3FD34413509F79FF' /
!
!     MACHINE CONSTANTS FOR THE CONVEX
!     USING THE -p8 COMPILER OPTION
!
!     DATA DMACH(1) / Z'00010000000000000000000000000000' /
!     DATA DMACH(2) / Z'7FFFFFFFFFFFFFFFFFFFFFFFFFFFFFFF' /
!     DATA DMACH(3) / Z'3F900000000000000000000000000000' /
!     DATA DMACH(4) / Z'3F910000000000000000000000000000' /
!     DATA DMACH(5) / Z'3FFF34413509F79FEF311F12B35816F9' /
!
!     MACHINE CONSTANTS FOR THE CRAY
!
!     DATA SMALL(1) / 201354000000000000000B /
!     DATA SMALL(2) / 000000000000000000000B /
!     DATA LARGE(1) / 577767777777777777777B /
!     DATA LARGE(2) / 000007777777777777774B /
!     DATA RIGHT(1) / 376434000000000000000B /
!     DATA RIGHT(2) / 000000000000000000000B /
!     DATA DIVER(1) / 376444000000000000000B /
!     DATA DIVER(2) / 000000000000000000000B /
!     DATA LOG10(1) / 377774642023241175717B /
!     DATA LOG10(2) / 000007571421742254654B /
!
!     MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
!     NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD -
!     STATIC DMACH(5)
!
!     DATA SMALL /    20K, 3*0 /
!     DATA LARGE / 77777K, 3*177777K /
!     DATA RIGHT / 31420K, 3*0 /
!     DATA DIVER / 32020K, 3*0 /
!     DATA LOG10 / 40423K, 42023K, 50237K, 74776K /
!
!     MACHINE CONSTANTS FOR THE DEC ALPHA
!     USING G_FLOAT
!
!     DATA DMACH(1) / '0000000000000010'X /
!     DATA DMACH(2) / 'FFFFFFFFFFFF7FFF'X /
!     DATA DMACH(3) / '0000000000003CC0'X /
!     DATA DMACH(4) / '0000000000003CD0'X /
!     DATA DMACH(5) / '79FF509F44133FF3'X /
!
!     MACHINE CONSTANTS FOR THE DEC ALPHA
!     USING IEEE_FORMAT
!
      DATA DMACH(1) / Z'0010000000000000' /
      DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' /
      DATA DMACH(3) / Z'3CA0000000000000' /
      DATA DMACH(4) / Z'3CB0000000000000' /
      DATA DMACH(5) / Z'3FD34413509F79FF' /
!
!     MACHINE CONSTANTS FOR THE DEC RISC
!
!     DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000'/
!     DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF'/
!     DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000'/
!     DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000'/
!     DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413'/
!
!     MACHINE CONSTANTS FOR THE DEC VAX
!     USING D_FLOATING
!     (EXPRESSED IN INTEGER AND HEXADECIMAL)
!     THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS
!     THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS
!
!     DATA SMALL(1), SMALL(2) /        128,           0 /
!     DATA LARGE(1), LARGE(2) /     -32769,          -1 /
!     DATA RIGHT(1), RIGHT(2) /       9344,           0 /
!     DATA DIVER(1), DIVER(2) /       9472,           0 /
!     DATA LOG10(1), LOG10(2) /  546979738,  -805796613 /
!
!     DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 /
!     DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF /
!     DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 /
!     DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 /
!     DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB /
!
!     MACHINE CONSTANTS FOR THE DEC VAX
!     USING G_FLOATING
!     (EXPRESSED IN INTEGER AND HEXADECIMAL)
!     THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSTEMS
!     THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS
!
!     DATA SMALL(1), SMALL(2) /         16,           0 /
!     DATA LARGE(1), LARGE(2) /     -32769,          -1 /
!     DATA RIGHT(1), RIGHT(2) /      15552,           0 /
!     DATA DIVER(1), DIVER(2) /      15568,           0 /
!     DATA LOG10(1), LOG10(2) /  1142112243, 2046775455 /
!
!     DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 /
!     DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF /
!     DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 /
!     DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 /
!     DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F /
!
!     MACHINE CONSTANTS FOR THE ELXSI 6400
!     (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION)
!
!     DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X /
!     DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X /
!     DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X /
!     DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X /
!     DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X /
!
!     MACHINE CONSTANTS FOR THE HARRIS 220
!
!     DATA SMALL(1), SMALL(2) / '20000000, '00000201 /
!     DATA LARGE(1), LARGE(2) / '37777777, '37777577 /
!     DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 /
!     DATA DIVER(1), DIVER(2) / '20000000, '00000334 /
!     DATA LOG10(1), LOG10(2) / '23210115, '10237777 /
!
!     MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES
!
!     DATA SMALL(1), SMALL(2) / O402400000000, O000000000000 /
!     DATA LARGE(1), LARGE(2) / O376777777777, O777777777777 /
!     DATA RIGHT(1), RIGHT(2) / O604400000000, O000000000000 /
!     DATA DIVER(1), DIVER(2) / O606400000000, O000000000000 /
!     DATA LOG10(1), LOG10(2) / O776464202324, O117571775714 /
!
!     MACHINE CONSTANTS FOR THE HP 730
!
!     DATA DMACH(1) / Z'0010000000000000' /
!     DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' /
!     DATA DMACH(3) / Z'3CA0000000000000' /
!     DATA DMACH(4) / Z'3CB0000000000000' /
!     DATA DMACH(5) / Z'3FD34413509F79FF' /
!
!     MACHINE CONSTANTS FOR THE HP 2100
!     THREE WORD DOUBLE PRECISION OPTION WITH FTN4
!
!     DATA SMALL(1), SMALL(2), SMALL(3) / 40000B,       0,       1 /
!     DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B /
!     DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B,       0,    265B /
!     DATA DIVER(1), DIVER(2), DIVER(3) / 40000B,       0,    276B /
!     DATA LOG10(1), LOG10(2), LOG10(3) / 46420B,  46502B,  77777B /
!
!     MACHINE CONSTANTS FOR THE HP 2100
!     FOUR WORD DOUBLE PRECISION OPTION WITH FTN4
!
!     DATA SMALL(1), SMALL(2) /  40000B,       0 /
!     DATA SMALL(3), SMALL(4) /       0,       1 /
!     DATA LARGE(1), LARGE(2) /  77777B, 177777B /
!     DATA LARGE(3), LARGE(4) / 177777B, 177776B /
!     DATA RIGHT(1), RIGHT(2) /  40000B,       0 /
!     DATA RIGHT(3), RIGHT(4) /       0,    225B /
!     DATA DIVER(1), DIVER(2) /  40000B,       0 /
!     DATA DIVER(3), DIVER(4) /       0,    227B /
!     DATA LOG10(1), LOG10(2) /  46420B,  46502B /
!     DATA LOG10(3), LOG10(4) /  76747B, 176377B /
!
!     MACHINE CONSTANTS FOR THE HP 9000
!
!     DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B /
!     DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B /
!     DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B /
!     DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B /
!     DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B /
!
!     MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
!     THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND
!     THE PERKIN ELMER (INTERDATA) 7/32.
!
!     DATA SMALL(1), SMALL(2) / Z00100000, Z00000000 /
!     DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF /
!     DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 /
!     DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 /
!     DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF /
!
!     MACHINE CONSTANTS FOR THE IBM PC
!     ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION
!     ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087.
!
!     DATA SMALL(1) / 2.23D-308  /
!     DATA LARGE(1) / 1.79D+308  /
!     DATA RIGHT(1) / 1.11D-16   /
!     DATA DIVER(1) / 2.22D-16   /
!     DATA LOG10(1) / 0.301029995663981195D0 /
!
!     MACHINE CONSTANTS FOR THE IBM RS 6000
!
!     DATA DMACH(1) / Z'0010000000000000' /
!     DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' /
!     DATA DMACH(3) / Z'3CA0000000000000' /
!     DATA DMACH(4) / Z'3CB0000000000000' /
!     DATA DMACH(5) / Z'3FD34413509F79FF' /
!
!     MACHINE CONSTANTS FOR THE INTEL i860
!
!     DATA DMACH(1) / Z'0010000000000000' /
!     DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' /
!     DATA DMACH(3) / Z'3CA0000000000000' /
!     DATA DMACH(4) / Z'3CB0000000000000' /
!     DATA DMACH(5) / Z'3FD34413509F79FF' /
!
!     MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR)
!
!     DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 /
!     DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 /
!     DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 /
!     DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 /
!     DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 /
!
!     MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR)
!
!     DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 /
!     DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 /
!     DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 /
!     DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 /
!     DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 /
!
!     MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING
!     32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL).
!
!     DATA SMALL(1), SMALL(2) /    8388608,           0 /
!     DATA LARGE(1), LARGE(2) / 2147483647,          -1 /
!     DATA RIGHT(1), RIGHT(2) /  612368384,           0 /
!     DATA DIVER(1), DIVER(2) /  620756992,           0 /
!     DATA LOG10(1), LOG10(2) / 1067065498, -2063872008 /
!
!     DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 /
!     DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 /
!     DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 /
!     DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 /
!     DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 /
!
!     MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING
!     16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL).
!
!     DATA SMALL(1), SMALL(2) /    128,      0 /
!     DATA SMALL(3), SMALL(4) /      0,      0 /
!     DATA LARGE(1), LARGE(2) /  32767,     -1 /
!     DATA LARGE(3), LARGE(4) /     -1,     -1 /
!     DATA RIGHT(1), RIGHT(2) /   9344,      0 /
!     DATA RIGHT(3), RIGHT(4) /      0,      0 /
!     DATA DIVER(1), DIVER(2) /   9472,      0 /
!     DATA DIVER(3), DIVER(4) /      0,      0 /
!     DATA LOG10(1), LOG10(2) /  16282,   8346 /
!     DATA LOG10(3), LOG10(4) / -31493, -12296 /
!
!     DATA SMALL(1), SMALL(2) / O000200, O000000 /
!     DATA SMALL(3), SMALL(4) / O000000, O000000 /
!     DATA LARGE(1), LARGE(2) / O077777, O177777 /
!     DATA LARGE(3), LARGE(4) / O177777, O177777 /
!     DATA RIGHT(1), RIGHT(2) / O022200, O000000 /
!     DATA RIGHT(3), RIGHT(4) / O000000, O000000 /
!     DATA DIVER(1), DIVER(2) / O022400, O000000 /
!     DATA DIVER(3), DIVER(4) / O000000, O000000 /
!     DATA LOG10(1), LOG10(2) / O037632, O020232 /
!     DATA LOG10(3), LOG10(4) / O102373, O147770 /
!
!     MACHINE CONSTANTS FOR THE SILICON GRAPHICS
!
!     DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' /
!     DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' /
!     DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' /
!     DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' /
!     DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' /
!
!     MACHINE CONSTANTS FOR THE SUN
!
!     DATA DMACH(1) / Z'0010000000000000' /
!     DATA DMACH(2) / Z'7FEFFFFFFFFFFFFF' /
!     DATA DMACH(3) / Z'3CA0000000000000' /
!     DATA DMACH(4) / Z'3CB0000000000000' /
!     DATA DMACH(5) / Z'3FD34413509F79FF' /
!
!     MACHINE CONSTANTS FOR THE SUN
!     USING THE -r8 COMPILER OPTION
!
!     DATA DMACH(1) / Z'00010000000000000000000000000000' /
!     DATA DMACH(2) / Z'7FFEFFFFFFFFFFFFFFFFFFFFFFFFFFFF' /
!     DATA DMACH(3) / Z'3F8E0000000000000000000000000000' /
!     DATA DMACH(4) / Z'3F8F0000000000000000000000000000' /
!     DATA DMACH(5) / Z'3FFD34413509F79FEF311F12B35816F9' /
!
!     MACHINE CONSTANTS FOR THE SUN 386i
!
!     DATA SMALL(1), SMALL(2) / Z'FFFFFFFD', Z'000FFFFF' /
!     DATA LARGE(1), LARGE(2) / Z'FFFFFFB0', Z'7FEFFFFF' /
!     DATA RIGHT(1), RIGHT(2) / Z'000000B0', Z'3CA00000' /
!     DATA DIVER(1), DIVER(2) / Z'FFFFFFCB', Z'3CAFFFFF'
!     DATA LOG10(1), LOG10(2) / Z'509F79E9', Z'3FD34413' /
!
!     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER
!
!     DATA SMALL(1), SMALL(2) / O000040000000, O000000000000 /
!     DATA LARGE(1), LARGE(2) / O377777777777, O777777777777 /
!     DATA RIGHT(1), RIGHT(2) / O170540000000, O000000000000 /
!     DATA DIVER(1), DIVER(2) / O170640000000, O000000000000 /
!     DATA LOG10(1), LOG10(2) / O177746420232, O411757177572 /
!
!***FIRST EXECUTABLE STATEMENT  D1MACH
!
  if ( I < 1 .OR. I > 5 ) then
    call XERMSG ('SLATEC', 'D1MACH', 'I OUT OF BOUNDS', 1, 2)
  end if

  D1MACH = DMACH(I)

  return
end



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



subroutine FDUMP
!
!! FDUMP makes a symbolic dump (should be locally written).
!
!***LIBRARY   SLATEC (XERROR)
!***CATEGORY  R3
!***TYPE      ALL (FDUMP-A)
!***KEYWORDS  ERROR, XERMSG
!***AUTHOR  Jones, R. E., (SNLA)
!***DESCRIPTION
!
!        ***Note*** Machine Dependent Routine
!        FDUMP is intended to be replaced by a locally written
!        version which produces a symbolic dump.  Failing this,
!        it should be replaced by a version which prints the
!        subprogram nesting list.  Note that this dump must be
!        printed on each of up to five files, as indicated by the
!        XGETUA routine.  See XSETUA and XGETUA for details.
!
!     Written by Ron Jones, with SLATEC Common Math Library Subcommittee
!
!***REFERENCES  (NONE)
!***ROUTINES CALLED  (NONE)
!***REVISION HISTORY  (YYMMDD)
!   790801  DATE WRITTEN
!   861211  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!***END PROLOGUE  FDUMP
!***FIRST EXECUTABLE STATEMENT  FDUMP
  return
end



FUNCTION I1MACH (I)
!
!! I1MACH returns integer machine dependent constants.
!
!***LIBRARY   SLATEC
!***CATEGORY  R1
!***TYPE      INTEGER (I1MACH-I)
!***KEYWORDS  MACHINE CONSTANTS
!***AUTHOR  Fox, P. A., (Bell Labs)
!           Hall, A. D., (Bell Labs)
!           Schryer, N. L., (Bell Labs)
!***DESCRIPTION
!
!   I1MACH can be used to obtain machine-dependent parameters for the
!   local machine environment.  It is a function subprogram with one
!   (input) argument and can be referenced as follows:
!
!        K = I1MACH(I)
!
!   where I=1,...,16.  The (output) value of K above is determined by
!   the (input) value of I.  The results for various values of I are
!   discussed below.
!
!   I/O unit numbers:
!     I1MACH( 1) = the standard input unit.
!     I1MACH( 2) = the standard output unit.
!     I1MACH( 3) = the standard punch unit.
!     I1MACH( 4) = the standard error message unit.
!
!   Words:
!     I1MACH( 5) = the number of bits per integer storage unit.
!     I1MACH( 6) = the number of characters per integer storage unit.
!
!   Integers:
!     assume integers are represented in the S-digit, base-A form
!
!                sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
!
!                where 0  <=  X(I)  <  A for I=0,...,S-1.
!     I1MACH( 7) = A, the base.
!     I1MACH( 8) = S, the number of base-A digits.
!     I1MACH( 9) = A**S - 1, the largest magnitude.
!
!   Floating-Point Numbers:
!     Assume floating-point numbers are represented in the T-digit,
!     base-B form
!                sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
!
!                where 0  <=  X(I)  <  B for I=1,...,T,
!                0  <  X(1), and EMIN  <=  E  <=  EMAX.
!     I1MACH(10) = B, the base.
!
!   Single-Precision:
!     I1MACH(11) = T, the number of base-B digits.
!     I1MACH(12) = EMIN, the smallest exponent E.
!     I1MACH(13) = EMAX, the largest exponent E.
!
!   Double-Precision:
!     I1MACH(14) = T, the number of base-B digits.
!     I1MACH(15) = EMIN, the smallest exponent E.
!     I1MACH(16) = EMAX, the largest exponent E.
!
!   To alter this function for a particular environment, the desired
!   set of DATA statements should be activated by removing the C from
!   column 1.  Also, the values of I1MACH(1) - I1MACH(4) should be
!   checked for consistency with the local operating system.
!
!***REFERENCES  P. A. Fox, A. D. Hall and N. L. Schryer, Framework for
!                 a portable library, ACM Transactions on Mathematical
!                 Software 4, 2 (June 1978), pp. 177-188.
!***ROUTINES CALLED  (NONE)
!***REVISION HISTORY  (YYMMDD)
!   750101  DATE WRITTEN
!   891012  Added VAX G-floating constants.  (WRB)
!   891012  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900618  Added DEC RISC constants.  (WRB)
!   900723  Added IBM RS 6000 constants.  (WRB)
!   901009  Correct I1MACH(7) for IBM Mainframes. Should be 2 not 16.
!           (RWC)
!   910710  Added HP 730 constants.  (SMR)
!   911114  Added Convex IEEE constants.  (WRB)
!   920121  Added SUN -r8 compiler option constants.  (WRB)
!   920229  Added Touchstone Delta i860 constants.  (WRB)
!   920501  Reformatted the REFERENCES section.  (WRB)
!   920625  Added Convex -p8 and -pd8 compiler option constants.
!           (BKS, WRB)
!   930201  Added DEC Alpha and SGI constants.  (RWC and WRB)
!   930618  Corrected I1MACH(5) for Convex -p8 and -pd8 compiler
!           options.  (DWL, RWC and WRB).
!***END PROLOGUE  I1MACH
!
  
  integer i1mach
  integer i
  INTEGER IMACH(16),OUTPUT
  SAVE IMACH
  EQUIVALENCE (IMACH(4),OUTPUT)
!
!     MACHINE CONSTANTS FOR THE AMIGA
!     ABSOFT COMPILER
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          5 /
!     DATA IMACH( 4) /          6 /
!     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) /       -126 /
!     DATA IMACH(13) /        127 /
!     DATA IMACH(14) /         53 /
!     DATA IMACH(15) /      -1022 /
!     DATA IMACH(16) /       1023 /
!
!     MACHINE CONSTANTS FOR THE APOLLO
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          6 /
!     DATA IMACH( 4) /          6 /
!     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) /        129 /
!     DATA IMACH(14) /         53 /
!     DATA IMACH(15) /      -1021 /
!     DATA IMACH(16) /       1025 /
!
!     MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM
!
!     DATA IMACH( 1) /          7 /
!     DATA IMACH( 2) /          2 /
!     DATA IMACH( 3) /          2 /
!     DATA IMACH( 4) /          2 /
!     DATA IMACH( 5) /         36 /
!     DATA IMACH( 6) /          4 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         33 /
!     DATA IMACH( 9) / Z1FFFFFFFF /
!     DATA IMACH(10) /          2 /
!     DATA IMACH(11) /         24 /
!     DATA IMACH(12) /       -256 /
!     DATA IMACH(13) /        255 /
!     DATA IMACH(14) /         60 /
!     DATA IMACH(15) /       -256 /
!     DATA IMACH(16) /        255 /
!
!     MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          7 /
!     DATA IMACH( 4) /          6 /
!     DATA IMACH( 5) /         48 /
!     DATA IMACH( 6) /          6 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         39 /
!     DATA IMACH( 9) / O0007777777777777 /
!     DATA IMACH(10) /          8 /
!     DATA IMACH(11) /         13 /
!     DATA IMACH(12) /        -50 /
!     DATA IMACH(13) /         76 /
!     DATA IMACH(14) /         26 /
!     DATA IMACH(15) /        -50 /
!     DATA IMACH(16) /         76 /
!
!     MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          7 /
!     DATA IMACH( 4) /          6 /
!     DATA IMACH( 5) /         48 /
!     DATA IMACH( 6) /          6 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         39 /
!     DATA IMACH( 9) / O0007777777777777 /
!     DATA IMACH(10) /          8 /
!     DATA IMACH(11) /         13 /
!     DATA IMACH(12) /        -50 /
!     DATA IMACH(13) /         76 /
!     DATA IMACH(14) /         26 /
!     DATA IMACH(15) /     -32754 /
!     DATA IMACH(16) /      32780 /
!
!     MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          7 /
!     DATA IMACH( 4) /          6 /
!     DATA IMACH( 5) /         64 /
!     DATA IMACH( 6) /          8 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         63 /
!     DATA IMACH( 9) / 9223372036854775807 /
!     DATA IMACH(10) /          2 /
!     DATA IMACH(11) /         47 /
!     DATA IMACH(12) /      -4095 /
!     DATA IMACH(13) /       4094 /
!     DATA IMACH(14) /         94 /
!     DATA IMACH(15) /      -4095 /
!     DATA IMACH(16) /       4094 /
!
!     MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          7 /
!     DATA IMACH( 4) /    6LOUTPUT/
!     DATA IMACH( 5) /         60 /
!     DATA IMACH( 6) /         10 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         48 /
!     DATA IMACH( 9) / 00007777777777777777B /
!     DATA IMACH(10) /          2 /
!     DATA IMACH(11) /         47 /
!     DATA IMACH(12) /       -929 /
!     DATA IMACH(13) /       1070 /
!     DATA IMACH(14) /         94 /
!     DATA IMACH(15) /       -929 /
!     DATA IMACH(16) /       1069 /
!
!     MACHINE CONSTANTS FOR THE CELERITY C1260
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          6 /
!     DATA IMACH( 4) /          0 /
!     DATA IMACH( 5) /         32 /
!     DATA IMACH( 6) /          4 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         31 /
!     DATA IMACH( 9) / Z'7FFFFFFF' /
!     DATA IMACH(10) /          2 /
!     DATA IMACH(11) /         24 /
!     DATA IMACH(12) /       -126 /
!     DATA IMACH(13) /        127 /
!     DATA IMACH(14) /         53 /
!     DATA IMACH(15) /      -1022 /
!     DATA IMACH(16) /       1023 /
!
!     MACHINE CONSTANTS FOR THE CONVEX
!     USING THE -fn COMPILER OPTION
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          7 /
!     DATA IMACH( 4) /          6 /
!     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) /       -127 /
!     DATA IMACH(13) /        127 /
!     DATA IMACH(14) /         53 /
!     DATA IMACH(15) /      -1023 /
!     DATA IMACH(16) /       1023 /
!
!     MACHINE CONSTANTS FOR THE CONVEX
!     USING THE -fi COMPILER OPTION
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          7 /
!     DATA IMACH( 4) /          6 /
!     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) /        128 /
!     DATA IMACH(14) /         53 /
!     DATA IMACH(15) /      -1021 /
!     DATA IMACH(16) /       1024 /
!
!     MACHINE CONSTANTS FOR THE CONVEX
!     USING THE -p8 COMPILER OPTION
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          7 /
!     DATA IMACH( 4) /          6 /
!     DATA IMACH( 5) /         64 /
!     DATA IMACH( 6) /          4 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         63 /
!     DATA IMACH( 9) / 9223372036854775807 /
!     DATA IMACH(10) /          2 /
!     DATA IMACH(11) /         53 /
!     DATA IMACH(12) /      -1023 /
!     DATA IMACH(13) /       1023 /
!     DATA IMACH(14) /        113 /
!     DATA IMACH(15) /     -16383 /
!     DATA IMACH(16) /      16383 /
!
!     MACHINE CONSTANTS FOR THE CONVEX
!     USING THE -pd8 COMPILER OPTION
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          7 /
!     DATA IMACH( 4) /          6 /
!     DATA IMACH( 5) /         64 /
!     DATA IMACH( 6) /          4 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         63 /
!     DATA IMACH( 9) / 9223372036854775807 /
!     DATA IMACH(10) /          2 /
!     DATA IMACH(11) /         53 /
!     DATA IMACH(12) /      -1023 /
!     DATA IMACH(13) /       1023 /
!     DATA IMACH(14) /         53 /
!     DATA IMACH(15) /      -1023 /
!     DATA IMACH(16) /       1023 /
!
!     MACHINE CONSTANTS FOR THE CRAY
!     USING THE 46 BIT INTEGER COMPILER OPTION
!
!     DATA IMACH( 1) /        100 /
!     DATA IMACH( 2) /        101 /
!     DATA IMACH( 3) /        102 /
!     DATA IMACH( 4) /        101 /
!     DATA IMACH( 5) /         64 /
!     DATA IMACH( 6) /          8 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         46 /
!     DATA IMACH( 9) / 1777777777777777B /
!     DATA IMACH(10) /          2 /
!     DATA IMACH(11) /         47 /
!     DATA IMACH(12) /      -8189 /
!     DATA IMACH(13) /       8190 /
!     DATA IMACH(14) /         94 /
!     DATA IMACH(15) /      -8099 /
!     DATA IMACH(16) /       8190 /
!
!     MACHINE CONSTANTS FOR THE CRAY
!     USING THE 64 BIT INTEGER COMPILER OPTION
!
!     DATA IMACH( 1) /        100 /
!     DATA IMACH( 2) /        101 /
!     DATA IMACH( 3) /        102 /
!     DATA IMACH( 4) /        101 /
!     DATA IMACH( 5) /         64 /
!     DATA IMACH( 6) /          8 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         63 /
!     DATA IMACH( 9) / 777777777777777777777B /
!     DATA IMACH(10) /          2 /
!     DATA IMACH(11) /         47 /
!     DATA IMACH(12) /      -8189 /
!     DATA IMACH(13) /       8190 /
!     DATA IMACH(14) /         94 /
!     DATA IMACH(15) /      -8099 /
!     DATA IMACH(16) /       8190 /
!
!     MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
!
!     DATA IMACH( 1) /         11 /
!     DATA IMACH( 2) /         12 /
!     DATA IMACH( 3) /          8 /
!     DATA IMACH( 4) /         10 /
!     DATA IMACH( 5) /         16 /
!     DATA IMACH( 6) /          2 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         15 /
!     DATA IMACH( 9) /      32767 /
!     DATA IMACH(10) /         16 /
!     DATA IMACH(11) /          6 /
!     DATA IMACH(12) /        -64 /
!     DATA IMACH(13) /         63 /
!     DATA IMACH(14) /         14 /
!     DATA IMACH(15) /        -64 /
!     DATA IMACH(16) /         63 /
!
!     MACHINE CONSTANTS FOR THE DEC ALPHA
!     USING G_FLOAT
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          5 /
!     DATA IMACH( 4) /          6 /
!     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) /       -127 /
!     DATA IMACH(13) /        127 /
!     DATA IMACH(14) /         53 /
!     DATA IMACH(15) /      -1023 /
!     DATA IMACH(16) /       1023 /
!
!     MACHINE CONSTANTS FOR THE DEC ALPHA
!     USING IEEE_FLOAT
!
      DATA IMACH( 1) /          5 /
      DATA IMACH( 2) /          6 /
      DATA IMACH( 3) /          6 /
      DATA IMACH( 4) /          6 /
      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) /        128 /
      DATA IMACH(14) /         53 /
      DATA IMACH(15) /      -1021 /
      DATA IMACH(16) /       1024 /
!
!     MACHINE CONSTANTS FOR THE DEC RISC
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          6 /
!     DATA IMACH( 4) /          6 /
!     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) /        128 /
!     DATA IMACH(14) /         53 /
!     DATA IMACH(15) /      -1021 /
!     DATA IMACH(16) /       1024 /
!
!     MACHINE CONSTANTS FOR THE DEC VAX
!     USING D_FLOATING
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          5 /
!     DATA IMACH( 4) /          6 /
!     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) /       -127 /
!     DATA IMACH(13) /        127 /
!     DATA IMACH(14) /         56 /
!     DATA IMACH(15) /       -127 /
!     DATA IMACH(16) /        127 /
!
!     MACHINE CONSTANTS FOR THE DEC VAX
!     USING G_FLOATING
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          5 /
!     DATA IMACH( 4) /          6 /
!     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) /       -127 /
!     DATA IMACH(13) /        127 /
!     DATA IMACH(14) /         53 /
!     DATA IMACH(15) /      -1023 /
!     DATA IMACH(16) /       1023 /
!
!     MACHINE CONSTANTS FOR THE ELXSI 6400
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          6 /
!     DATA IMACH( 4) /          6 /
!     DATA IMACH( 5) /         32 /
!     DATA IMACH( 6) /          4 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         32 /
!     DATA IMACH( 9) / 2147483647 /
!     DATA IMACH(10) /          2 /
!     DATA IMACH(11) /         24 /
!     DATA IMACH(12) /       -126 /
!     DATA IMACH(13) /        127 /
!     DATA IMACH(14) /         53 /
!     DATA IMACH(15) /      -1022 /
!     DATA IMACH(16) /       1023 /
!
!     MACHINE CONSTANTS FOR THE HARRIS 220
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          0 /
!     DATA IMACH( 4) /          6 /
!     DATA IMACH( 5) /         24 /
!     DATA IMACH( 6) /          3 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         23 /
!     DATA IMACH( 9) /    8388607 /
!     DATA IMACH(10) /          2 /
!     DATA IMACH(11) /         23 /
!     DATA IMACH(12) /       -127 /
!     DATA IMACH(13) /        127 /
!     DATA IMACH(14) /         38 /
!     DATA IMACH(15) /       -127 /
!     DATA IMACH(16) /        127 /
!
!     MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /         43 /
!     DATA IMACH( 4) /          6 /
!     DATA IMACH( 5) /         36 /
!     DATA IMACH( 6) /          6 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         35 /
!     DATA IMACH( 9) / O377777777777 /
!     DATA IMACH(10) /          2 /
!     DATA IMACH(11) /         27 /
!     DATA IMACH(12) /       -127 /
!     DATA IMACH(13) /        127 /
!     DATA IMACH(14) /         63 /
!     DATA IMACH(15) /       -127 /
!     DATA IMACH(16) /        127 /
!
!     MACHINE CONSTANTS FOR THE HP 730
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          6 /
!     DATA IMACH( 4) /          6 /
!     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) /        128 /
!     DATA IMACH(14) /         53 /
!     DATA IMACH(15) /      -1021 /
!     DATA IMACH(16) /       1024 /
!
!     MACHINE CONSTANTS FOR THE HP 2100
!     3 WORD DOUBLE PRECISION OPTION WITH FTN4
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          4 /
!     DATA IMACH( 4) /          1 /
!     DATA IMACH( 5) /         16 /
!     DATA IMACH( 6) /          2 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         15 /
!     DATA IMACH( 9) /      32767 /
!     DATA IMACH(10) /          2 /
!     DATA IMACH(11) /         23 /
!     DATA IMACH(12) /       -128 /
!     DATA IMACH(13) /        127 /
!     DATA IMACH(14) /         39 /
!     DATA IMACH(15) /       -128 /
!     DATA IMACH(16) /        127 /
!
!     MACHINE CONSTANTS FOR THE HP 2100
!     4 WORD DOUBLE PRECISION OPTION WITH FTN4
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          4 /
!     DATA IMACH( 4) /          1 /
!     DATA IMACH( 5) /         16 /
!     DATA IMACH( 6) /          2 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         15 /
!     DATA IMACH( 9) /      32767 /
!     DATA IMACH(10) /          2 /
!     DATA IMACH(11) /         23 /
!     DATA IMACH(12) /       -128 /
!     DATA IMACH(13) /        127 /
!     DATA IMACH(14) /         55 /
!     DATA IMACH(15) /       -128 /
!     DATA IMACH(16) /        127 /
!
!     MACHINE CONSTANTS FOR THE HP 9000
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          6 /
!     DATA IMACH( 4) /          7 /
!     DATA IMACH( 5) /         32 /
!     DATA IMACH( 6) /          4 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         32 /
!     DATA IMACH( 9) / 2147483647 /
!     DATA IMACH(10) /          2 /
!     DATA IMACH(11) /         24 /
!     DATA IMACH(12) /       -126 /
!     DATA IMACH(13) /        127 /
!     DATA IMACH(14) /         53 /
!     DATA IMACH(15) /      -1015 /
!     DATA IMACH(16) /       1017 /
!
!     MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
!     THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND
!     THE PERKIN ELMER (INTERDATA) 7/32.
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          7 /
!     DATA IMACH( 4) /          6 /
!     DATA IMACH( 5) /         32 /
!     DATA IMACH( 6) /          4 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         31 /
!     DATA IMACH( 9) /  Z7FFFFFFF /
!     DATA IMACH(10) /         16 /
!     DATA IMACH(11) /          6 /
!     DATA IMACH(12) /        -64 /
!     DATA IMACH(13) /         63 /
!     DATA IMACH(14) /         14 /
!     DATA IMACH(15) /        -64 /
!     DATA IMACH(16) /         63 /
!
!     MACHINE CONSTANTS FOR THE IBM PC
!
!     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 /
!
!     MACHINE CONSTANTS FOR THE IBM RS 6000
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          6 /
!     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) /        128 /
!     DATA IMACH(14) /         53 /
!     DATA IMACH(15) /      -1021 /
!     DATA IMACH(16) /       1024 /
!
!     MACHINE CONSTANTS FOR THE INTEL i860
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          6 /
!     DATA IMACH( 4) /          6 /
!     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) /        128 /
!     DATA IMACH(14) /         53 /
!     DATA IMACH(15) /      -1021 /
!     DATA IMACH(16) /       1024 /
!
!     MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR)
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          5 /
!     DATA IMACH( 4) /          6 /
!     DATA IMACH( 5) /         36 /
!     DATA IMACH( 6) /          5 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         35 /
!     DATA IMACH( 9) / "377777777777 /
!     DATA IMACH(10) /          2 /
!     DATA IMACH(11) /         27 /
!     DATA IMACH(12) /       -128 /
!     DATA IMACH(13) /        127 /
!     DATA IMACH(14) /         54 /
!     DATA IMACH(15) /       -101 /
!     DATA IMACH(16) /        127 /
!
!     MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR)
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          5 /
!     DATA IMACH( 4) /          6 /
!     DATA IMACH( 5) /         36 /
!     DATA IMACH( 6) /          5 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         35 /
!     DATA IMACH( 9) / "377777777777 /
!     DATA IMACH(10) /          2 /
!     DATA IMACH(11) /         27 /
!     DATA IMACH(12) /       -128 /
!     DATA IMACH(13) /        127 /
!     DATA IMACH(14) /         62 /
!     DATA IMACH(15) /       -128 /
!     DATA IMACH(16) /        127 /
!
!     MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING
!     32-BIT INTEGER ARITHMETIC.
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          5 /
!     DATA IMACH( 4) /          6 /
!     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) /       -127 /
!     DATA IMACH(13) /        127 /
!     DATA IMACH(14) /         56 /
!     DATA IMACH(15) /       -127 /
!     DATA IMACH(16) /        127 /
!
!     MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING
!     16-BIT INTEGER ARITHMETIC.
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          5 /
!     DATA IMACH( 4) /          6 /
!     DATA IMACH( 5) /         16 /
!     DATA IMACH( 6) /          2 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         15 /
!     DATA IMACH( 9) /      32767 /
!     DATA IMACH(10) /          2 /
!     DATA IMACH(11) /         24 /
!     DATA IMACH(12) /       -127 /
!     DATA IMACH(13) /        127 /
!     DATA IMACH(14) /         56 /
!     DATA IMACH(15) /       -127 /
!     DATA IMACH(16) /        127 /
!
!     MACHINE CONSTANTS FOR THE SILICON GRAPHICS
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          6 /
!     DATA IMACH( 4) /          6 /
!     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) /        128 /
!     DATA IMACH(14) /         53 /
!     DATA IMACH(15) /      -1021 /
!     DATA IMACH(16) /       1024 /
!
!     MACHINE CONSTANTS FOR THE SUN
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          6 /
!     DATA IMACH( 4) /          6 /
!     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) /        128 /
!     DATA IMACH(14) /         53 /
!     DATA IMACH(15) /      -1021 /
!     DATA IMACH(16) /       1024 /
!
!     MACHINE CONSTANTS FOR THE SUN
!     USING THE -r8 COMPILER OPTION
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          6 /
!     DATA IMACH( 4) /          6 /
!     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) /         53 /
!     DATA IMACH(12) /      -1021 /
!     DATA IMACH(13) /       1024 /
!     DATA IMACH(14) /        113 /
!     DATA IMACH(15) /     -16381 /
!     DATA IMACH(16) /      16384 /
!
!     MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER
!
!     DATA IMACH( 1) /          5 /
!     DATA IMACH( 2) /          6 /
!     DATA IMACH( 3) /          1 /
!     DATA IMACH( 4) /          6 /
!     DATA IMACH( 5) /         36 /
!     DATA IMACH( 6) /          4 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         35 /
!     DATA IMACH( 9) / O377777777777 /
!     DATA IMACH(10) /          2 /
!     DATA IMACH(11) /         27 /
!     DATA IMACH(12) /       -128 /
!     DATA IMACH(13) /        127 /
!     DATA IMACH(14) /         60 /
!     DATA IMACH(15) /      -1024 /
!     DATA IMACH(16) /       1023 /
!
!     MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR
!
!     DATA IMACH( 1) /          1 /
!     DATA IMACH( 2) /          1 /
!     DATA IMACH( 3) /          0 /
!     DATA IMACH( 4) /          1 /
!     DATA IMACH( 5) /         16 /
!     DATA IMACH( 6) /          2 /
!     DATA IMACH( 7) /          2 /
!     DATA IMACH( 8) /         15 /
!     DATA IMACH( 9) /      32767 /
!     DATA IMACH(10) /          2 /
!     DATA IMACH(11) /         24 /
!     DATA IMACH(12) /       -127 /
!     DATA IMACH(13) /        127 /
!     DATA IMACH(14) /         56 /
!     DATA IMACH(15) /       -127 /
!     DATA IMACH(16) /        127 /
!
!***FIRST EXECUTABLE STATEMENT  I1MACH
!
  if ( I < 1 .OR. I > 16 ) then
    WRITE (UNIT = OUTPUT, FMT = 9000)
 9000 FORMAT ('1ERROR    1 IN I1MACH - I OUT OF BOUNDS')
    STOP
  end if

  I1MACH = IMACH(I)

  return
end



function J4SAVE (IWHICH, IVALUE, ISET)
!
!! J4SAVE saves or recalls global variables needed by error handling routines.
!
!***LIBRARY   SLATEC (XERROR)
!***TYPE      INTEGER (J4SAVE-I)
!***KEYWORDS  ERROR MESSAGES, ERROR NUMBER, RECALL, SAVE, XERROR
!***AUTHOR  Jones, R. E., (SNLA)
!***DESCRIPTION
!
!     Abstract
!        J4SAVE saves and recalls several global variables needed
!        by the library error handling routines.
!
!     Description of Parameters
!      --Input--
!        IWHICH - Index of item desired.
!                = 1 Refers to current error number.
!                = 2 Refers to current error control flag.
!                = 3 Refers to current unit number to which error
!                    messages are to be sent.  (0 means use standard.)
!                = 4 Refers to the maximum number of times any
!                     message is to be printed (as set by XERMAX).
!                = 5 Refers to the total number of units to which
!                     each error message is to be written.
!                = 6 Refers to the 2nd unit for error messages
!                = 7 Refers to the 3rd unit for error messages
!                = 8 Refers to the 4th unit for error messages
!                = 9 Refers to the 5th unit for error messages
!        IVALUE - The value to be set for the IWHICH-th parameter,
!                 if ISET is .TRUE. .
!        ISET   - If ISET=.TRUE., the IWHICH-th parameter will BE
!                 given the value, IVALUE.  If ISET=.FALSE., the
!                 IWHICH-th parameter will be unchanged, and IVALUE
!                 is a dummy parameter.
!      --Output--
!        The (old) value of the IWHICH-th parameter will be returned
!        in the function value, J4SAVE.
!
!***SEE ALSO  XERMSG
!***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
!                 Error-handling Package, SAND82-0800, Sandia
!                 Laboratories, 1982.
!***ROUTINES CALLED  (NONE)
!***REVISION HISTORY  (YYMMDD)
!   790801  DATE WRITTEN
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900205  Minor modifications to prologue.  (WRB)
!   900402  Added TYPE section.  (WRB)
!   910411  Added KEYWORDS section.  (WRB)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  J4SAVE
  LOGICAL ISET
  integer IWHICH, IVALUE
  integer J4SAVE
  INTEGER IPARAM(9)
  SAVE IPARAM
  DATA IPARAM(1),IPARAM(2),IPARAM(3),IPARAM(4)/0,2,0,10/
  DATA IPARAM(5)/1/
  DATA IPARAM(6),IPARAM(7),IPARAM(8),IPARAM(9)/0,0,0,0/
!***FIRST EXECUTABLE STATEMENT  J4SAVE
  J4SAVE = IPARAM(IWHICH)
  if (ISET) IPARAM(IWHICH) = IVALUE
  return
end



subroutine XERCNT (LIBRAR, SUBROU, MESSG, NERR, LEVEL, KONTRL)
!
!! XERCNT allows user control over handling of XERROR errors.
!
!***LIBRARY   SLATEC (XERROR)
!***CATEGORY  R3C
!***TYPE      ALL (XERCNT-A)
!***KEYWORDS  ERROR, XERROR
!***AUTHOR  Jones, R. E., (SNLA)
!***DESCRIPTION
!
!     Abstract
!        Allows user control over handling of individual errors.
!        Just after each message is recorded, but before it is
!        processed any further (i.e., before it is printed or
!        a decision to abort is made), a call is made to XERCNT.
!        If the user has provided his own version of XERCNT, he
!        can then override the value of KONTROL used in processing
!        this message by redefining its value.
!        KONTRL may be set to any value from -2 to 2.
!        The meanings for KONTRL are the same as in XSETF, except
!        that the value of KONTRL changes only for this message.
!        If KONTRL is set to a value outside the range from -2 to 2,
!        it will be moved back into that range.
!
!     Description of Parameters
!
!      --Input--
!        LIBRAR - the library that the routine is in.
!        SUBROU - the subroutine that XERMSG is being called from
!        MESSG  - the first 20 characters of the error message.
!        NERR   - same as in the call to XERMSG.
!        LEVEL  - same as in the call to XERMSG.
!        KONTRL - the current value of the control flag as set
!                 by a call to XSETF.
!
!      --Output--
!        KONTRL - the new value of KONTRL.  If KONTRL is not
!                 defined, it will remain at its original value.
!                 This changed value of control affects only
!                 the current occurrence of the current message.
!
!***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
!                 Error-handling Package, SAND82-0800, Sandia
!                 Laboratories, 1982.
!***ROUTINES CALLED  (NONE)
!***REVISION HISTORY  (YYMMDD)
!   790801  DATE WRITTEN
!   861211  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900206  Routine changed from user-callable to subsidiary.  (WRB)
!   900510  Changed calling sequence to include LIBRARY and SUBROUTINE
!           names, changed routine name from XERCTL to XERCNT.  (RWC)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  XERCNT
  CHARACTER*(*) LIBRAR, SUBROU, MESSG
!***FIRST EXECUTABLE STATEMENT  XERCNT
  return
end



subroutine XERHLT (MESSG)
!
!! XERHLT aborts program execution after printing XERROR error message.
!
!***LIBRARY   SLATEC (XERROR)
!***CATEGORY  R3C
!***TYPE      ALL (XERHLT-A)
!***KEYWORDS  ABORT PROGRAM EXECUTION, ERROR, XERROR
!***AUTHOR  Jones, R. E., (SNLA)
!***DESCRIPTION
!
!     Abstract
!        ***Note*** machine dependent routine
!        XERHLT aborts the execution of the program.
!        The error message causing the abort is given in the calling
!        sequence, in case one needs it for printing on a dayfile,
!        for example.
!
!     Description of Parameters
!        MESSG is as in XERMSG.
!
!***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
!                 Error-handling Package, SAND82-0800, Sandia
!                 Laboratories, 1982.
!***ROUTINES CALLED  (NONE)
!***REVISION HISTORY  (YYMMDD)
!   790801  DATE WRITTEN
!   861211  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900206  Routine changed from user-callable to subsidiary.  (WRB)
!   900510  Changed calling sequence to delete length of character
!           and changed routine name from XERABT to XERHLT.  (RWC)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  XERHLT
  CHARACTER*(*) MESSG
!***FIRST EXECUTABLE STATEMENT  XERHLT
  STOP
end



subroutine XERMSG (LIBRAR, SUBROU, MESSG, NERR, LEVEL)

!! XERMSG processes XERROR messages.
!
!***LIBRARY   SLATEC (XERROR)
!***CATEGORY  R3C
!***TYPE      ALL (XERMSG-A)
!***KEYWORDS  ERROR MESSAGE, XERROR
!***AUTHOR  Fong, Kirby, (NMFECC at LLNL)
!***DESCRIPTION
!
!   XERMSG processes a diagnostic message in a manner determined by the
!   value of LEVEL and the current value of the library error control
!   flag, KONTRL.  See subroutine XSETF for details.
!
!    LIBRAR   A character constant (or character variable) with the name
!             of the library.  This will be 'SLATEC' for the SLATEC
!             Common Math Library.  The error handling package is
!             general enough to be used by many libraries
!             simultaneously, so it is desirable for the routine that
!             detects and reports an error to identify the library name
!             as well as the routine name.
!
!    SUBROU   A character constant (or character variable) with the name
!             of the routine that detected the error.  Usually it is the
!             name of the routine that is calling XERMSG.  There are
!             some instances where a user callable library routine calls
!             lower level subsidiary routines where the error is
!             detected.  In such cases it may be more informative to
!             supply the name of the routine the user called rather than
!             the name of the subsidiary routine that detected the
!             error.
!
!    MESSG    A character constant (or character variable) with the text
!             of the error or warning message.  In the example below,
!             the message is a character constant that contains a
!             generic message.
!
!                   call XERMSG ('SLATEC', 'MMPY',
!                  *'THE ORDER OF THE MATRIX EXCEEDS THE ROW DIMENSION',
!                  *3, 1)
!
!             It is possible (and is sometimes desirable) to generate a
!             specific message--e.g., one that contains actual numeric
!             values.  Specific numeric values can be converted into
!             character strings using formatted WRITE statements into
!             character variables.  This is called standard Fortran
!             internal file I/O and is exemplified in the first three
!             lines of the following example.  You can also catenate
!             substrings of characters to construct the error message.
!             Here is an example showing the use of both writing to
!             an internal file and catenating character strings.
!
!                   CHARACTER*5 CHARN, CHARL
!                   WRITE (CHARN,10) N
!                   WRITE (CHARL,10) LDA
!                10 FORMAT(I5)
!                   call XERMSG ('SLATEC', 'MMPY', 'THE ORDER'//CHARN//
!                  *   ' OF THE MATRIX EXCEEDS ITS ROW DIMENSION OF'//
!                  *   CHARL, 3, 1)
!
!             There are two subtleties worth mentioning.  One is that
!             the // for character catenation is used to construct the
!             error message so that no single character constant is
!             continued to the next line.  This avoids confusion as to
!             whether there are trailing blanks at the end of the line.
!             The second is that by catenating the parts of the message
!             as an actual argument rather than encoding the entire
!             message into one large character variable, we avoid
!             having to know how long the message will be in order to
!             declare an adequate length for that large character
!             variable.  XERMSG calls XERPRN to print the message using
!             multiple lines if necessary.  If the message is very long,
!             XERPRN will break it into pieces of 72 characters (as
!             requested by XERMSG) for printing on multiple lines.
!             Also, XERMSG asks XERPRN to prefix each line with ' *  '
!             so that the total line length could be 76 characters.
!             Note also that XERPRN scans the error message backwards
!             to ignore trailing blanks.  Another feature is that
!             the substring '$$' is treated as a new line sentinel
!             by XERPRN.  If you want to construct a multiline
!             message without having to count out multiples of 72
!             characters, just use '$$' as a separator.  '$$'
!             obviously must occur within 72 characters of the
!             start of each line to have its intended effect since
!             XERPRN is asked to wrap around at 72 characters in
!             addition to looking for '$$'.
!
!    NERR     An integer value that is chosen by the library routine's
!             author.  It must be in the range -99 to 999 (three
!             printable digits).  Each distinct error should have its
!             own error number.  These error numbers should be described
!             in the machine readable documentation for the routine.
!             The error numbers need be unique only within each routine,
!             so it is reasonable for each routine to start enumerating
!             errors from 1 and proceeding to the next integer.
!
!    LEVEL    An integer value in the range 0 to 2 that indicates the
!             level (severity) of the error.  Their meanings are
!
!            -1  A warning message.  This is used if it is not clear
!                that there really is an error, but the user's attention
!                may be needed.  An attempt is made to only print this
!                message once.
!
!             0  A warning message.  This is used if it is not clear
!                that there really is an error, but the user's attention
!                may be needed.
!
!             1  A recoverable error.  This is used even if the error is
!                so serious that the routine cannot return any useful
!                answer.  If the user has told the error package to
!                return after recoverable errors, then XERMSG will
!                return to the Library routine which can then return to
!                the user's routine.  The user may also permit the error
!                package to terminate the program upon encountering a
!                recoverable error.
!
!             2  A fatal error.  XERMSG will not return to its caller
!                after it receives a fatal error.  This level should
!                hardly ever be used; it is much better to allow the
!                user a chance to recover.  An example of one of the few
!                cases in which it is permissible to declare a level 2
!                error is a reverse communication Library routine that
!                is likely to be called repeatedly until it integrates
!                across some interval.  If there is a serious error in
!                the input such that another step cannot be taken and
!                the Library routine is called again without the input
!                error having been corrected by the caller, the Library
!                routine will probably be called forever with improper
!                input.  In this case, it is reasonable to declare the
!                error to be fatal.
!
!    Each of the arguments to XERMSG is input; none will be modified by
!    XERMSG.  A routine may make multiple calls to XERMSG with warning
!    level messages; however, after a call to XERMSG with a recoverable
!    error, the routine should return to the user.  Do not try to call
!    XERMSG with a second recoverable error after the first recoverable
!    error because the error package saves the error number.  The user
!    can retrieve this error number by calling another entry point in
!    the error handling package and then clear the error number when
!    recovering from the error.  Calling XERMSG in succession causes the
!    old error number to be overwritten by the latest error number.
!    This is considered harmless for error numbers associated with
!    warning messages but must not be done for error numbers of serious
!    errors.  After a call to XERMSG with a recoverable error, the user
!    must be given a chance to call NUMXER or XERCLR to retrieve or
!    clear the error number.
!***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
!                 Error-handling Package, SAND82-0800, Sandia
!                 Laboratories, 1982.
!***ROUTINES CALLED  FDUMP, J4SAVE, XERCNT, XERHLT, XERPRN, XERSVE
!***REVISION HISTORY  (YYMMDD)
!   880101  DATE WRITTEN
!   880621  REVISED AS DIRECTED AT SLATEC CML MEETING OF FEBRUARY 1988.
!           THERE ARE TWO BASIC CHANGES.
!           1.  A NEW ROUTINE, XERPRN, IS USED INSTEAD OF XERPRT TO
!               PRINT MESSAGES.  THIS ROUTINE WILL BREAK LONG MESSAGES
!               INTO PIECES FOR PRINTING ON MULTIPLE LINES.  '$$' IS
!               ACCEPTED AS A NEW LINE SENTINEL.  A PREFIX CAN BE
!               ADDED TO EACH LINE TO BE PRINTED.  XERMSG USES EITHER
!               ' ***' OR ' *  ' AND LONG MESSAGES ARE BROKEN EVERY
!               72 CHARACTERS (AT MOST) SO THAT THE MAXIMUM LINE
!               LENGTH OUTPUT CAN NOW BE AS GREAT AS 76.
!           2.  THE TEXT OF ALL MESSAGES IS NOW IN UPPER CASE SINCE THE
!               FORTRAN STANDARD DOCUMENT DOES NOT ADMIT THE EXISTENCE
!               OF LOWER CASE.
!   880708  REVISED AFTER THE SLATEC CML MEETING OF JUNE 29 AND 30.
!           THE PRINCIPAL CHANGES ARE
!           1.  CLARIFY COMMENTS IN THE PROLOGUES
!           2.  RENAME XRPRNT TO XERPRN
!           3.  REWORK HANDLING OF '$$' IN XERPRN TO HANDLE BLANK LINES
!               SIMILAR TO THE WAY FORMAT STATEMENTS HANDLE THE /
!               CHARACTER FOR NEW RECORDS.
!   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
!           CLEAN UP THE CODING.
!   890721  REVISED TO USE NEW FEATURE IN XERPRN TO COUNT CHARACTERS IN
!           PREFIX.
!   891013  REVISED TO CORRECT COMMENTS.
!   891214  Prologue converted to Version 4.0 format.  (WRB)
!   900510  Changed test on NERR to be -9999999 < NERR < 99999999, but
!           NERR .ne. 0, and on LEVEL to be -2 < LEVEL < 3.  Added
!           LEVEL=-1 logic, changed calls to XERSAV to XERSVE, and
!           XERCTL to XERCNT.  (RWC)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  XERMSG
  CHARACTER*(*) LIBRAR, SUBROU, MESSG
  CHARACTER*8 XLIBR, XSUBR
  CHARACTER*72  TEMP
  CHARACTER*20  LFIRST
!***FIRST EXECUTABLE STATEMENT  XERMSG
  LKNTRL = J4SAVE (2, 0, .FALSE.)
  MAXMES = J4SAVE (4, 0, .FALSE.)
!
!       LKNTRL IS A LOCAL COPY OF THE CONTROL FLAG KONTRL.
!       MAXMES IS THE MAXIMUM NUMBER OF TIMES ANY PARTICULAR MESSAGE
!          SHOULD BE PRINTED.
!
!       WE PRINT A FATAL ERROR MESSAGE AND TERMINATE FOR AN ERROR IN
!          CALLING XERMSG.  THE ERROR NUMBER SHOULD BE POSITIVE,
!          AND THE LEVEL SHOULD BE BETWEEN 0 AND 2.
!
  if (NERR < -9999999 .OR. NERR > 99999999 .OR. NERR == 0 .OR. &
     LEVEL < -1 .OR. LEVEL > 2) THEN
     call XERPRN (' ***', -1, 'FATAL ERROR IN...$$ ' // &
        'XERMSG -- INVALID ERROR NUMBER OR LEVEL$$ '// &
        'JOB ABORT DUE TO FATAL ERROR.', 72)
     call XERSVE (' ', ' ', ' ', 0, 0, 0, KDUMMY)
     call XERHLT (' ***XERMSG -- INVALID INPUT')
     return
  end if
!
!       RECORD THE MESSAGE.
!
  I = J4SAVE (1, NERR, .TRUE.)
  call XERSVE (LIBRAR, SUBROU, MESSG, 1, NERR, LEVEL, KOUNT)
!
!       HANDLE PRINT-ONCE WARNING MESSAGES.
!
  if (LEVEL == -1 .AND. KOUNT > 1) RETURN
!
!       ALLOW TEMPORARY USER OVERRIDE OF THE CONTROL FLAG.
!
  XLIBR  = LIBRAR
  XSUBR  = SUBROU
  LFIRST = MESSG
  LERR   = NERR
  LLEVEL = LEVEL
  call XERCNT (XLIBR, XSUBR, LFIRST, LERR, LLEVEL, LKNTRL)
!
  LKNTRL = MAX(-2, MIN(2,LKNTRL))
  MKNTRL = ABS(LKNTRL)
!
!       SKIP PRINTING if THE CONTROL FLAG VALUE AS RESET IN XERCNT IS
!       ZERO AND THE ERROR IS NOT FATAL.
!
  if (LEVEL < 2 .AND. LKNTRL == 0) go to 30
  if (LEVEL == 0 .AND. KOUNT > MAXMES) go to 30
  if (LEVEL == 1 .AND. KOUNT > MAXMES .AND. MKNTRL == 1) go to 30
  if (LEVEL == 2 .AND. KOUNT > MAX(1,MAXMES)) go to 30
!
!       ANNOUNCE THE NAMES OF THE LIBRARY AND SUBROUTINE BY BUILDING A
!       MESSAGE IN CHARACTER VARIABLE TEMP (NOT EXCEEDING 66 CHARACTERS)
!       AND SENDING IT OUT VIA XERPRN.  PRINT ONLY if CONTROL FLAG
!       IS NOT ZERO.
!
  if (LKNTRL  /=  0) THEN
     TEMP(1:21) = 'MESSAGE FROM ROUTINE '
     I = MIN(LEN(SUBROU), 16)
     TEMP(22:21+I) = SUBROU(1:I)
     TEMP(22+I:33+I) = ' IN LIBRARY '
     LTEMP = 33 + I
     I = MIN(LEN(LIBRAR), 16)
     TEMP(LTEMP+1:LTEMP+I) = LIBRAR (1:I)
     TEMP(LTEMP+I+1:LTEMP+I+1) = '.'
     LTEMP = LTEMP + I + 1
     call XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
  end if
!
!       if LKNTRL IS POSITIVE, PRINT AN INTRODUCTORY LINE BEFORE
!       PRINTING THE MESSAGE.  THE INTRODUCTORY LINE TELLS THE CHOICE
!       FROM EACH OF THE FOLLOWING THREE OPTIONS.
!       1.  LEVEL OF THE MESSAGE
!              'INFORMATIVE MESSAGE'
!              'POTENTIALLY RECOVERABLE ERROR'
!              'FATAL ERROR'
!       2.  WHETHER CONTROL FLAG WILL ALLOW PROGRAM TO CONTINUE
!              'PROG CONTINUES'
!              'PROG ABORTED'
!       3.  WHETHER OR NOT A TRACEBACK WAS REQUESTED.  (THE TRACEBACK
!           MAY NOT BE IMPLEMENTED AT SOME SITES, SO THIS ONLY TELLS
!           WHAT WAS REQUESTED, NOT WHAT WAS DELIVERED.)
!              'TRACEBACK REQUESTED'
!              'TRACEBACK NOT REQUESTED'
!       NOTICE THAT THE LINE INCLUDING FOUR PREFIX CHARACTERS WILL NOT
!       EXCEED 74 CHARACTERS.
!       WE SKIP THE NEXT BLOCK if THE INTRODUCTORY LINE IS NOT NEEDED.
!
  if (LKNTRL  >  0) THEN
!
!       THE FIRST PART OF THE MESSAGE TELLS ABOUT THE LEVEL.
!
     if (LEVEL  <=  0) THEN
        TEMP(1:20) = 'INFORMATIVE MESSAGE,'
        LTEMP = 20
     ELSEIF (LEVEL  ==  1) THEN
        TEMP(1:30) = 'POTENTIALLY RECOVERABLE ERROR,'
        LTEMP = 30
     ELSE
        TEMP(1:12) = 'FATAL ERROR,'
        LTEMP = 12
     ENDIF
!
!       THEN WHETHER THE PROGRAM WILL CONTINUE.
!
     if ((MKNTRL == 2 .AND. LEVEL >= 1) .OR. &
         (MKNTRL == 1 .AND. LEVEL == 2)) THEN
        TEMP(LTEMP+1:LTEMP+14) = ' PROG ABORTED,'
        LTEMP = LTEMP + 14
     ELSE
        TEMP(LTEMP+1:LTEMP+16) = ' PROG CONTINUES,'
        LTEMP = LTEMP + 16
     ENDIF
!
!       FINALLY TELL WHETHER THERE SHOULD BE A TRACEBACK.
!
     if (LKNTRL  >  0) THEN
        TEMP(LTEMP+1:LTEMP+20) = ' TRACEBACK REQUESTED'
        LTEMP = LTEMP + 20
     ELSE
        TEMP(LTEMP+1:LTEMP+24) = ' TRACEBACK NOT REQUESTED'
        LTEMP = LTEMP + 24
     ENDIF
     call XERPRN (' ***', -1, TEMP(1:LTEMP), 72)
  end if
!
!       NOW SEND OUT THE MESSAGE.
!
  call XERPRN (' *  ', -1, MESSG, 72)
!
!       if LKNTRL IS POSITIVE, WRITE THE ERROR NUMBER AND REQUEST A
!          TRACEBACK.
!
  if (LKNTRL  >  0) THEN
     WRITE (TEMP, '(''ERROR NUMBER = '', I8)') NERR
     DO 10 I=16,22
        if (TEMP(I:I)  /=  ' ') go to 20
   10    CONTINUE
!
   20    call XERPRN (' *  ', -1, TEMP(1:15) // TEMP(I:23), 72)
     call FDUMP
  end if
!
!       if LKNTRL IS NOT ZERO, PRINT A BLANK LINE AND AN END OF MESSAGE.
!
  if (LKNTRL  /=  0) THEN
     call XERPRN (' *  ', -1, ' ', 72)
     call XERPRN (' ***', -1, 'END OF MESSAGE', 72)
     call XERPRN ('    ',  0, ' ', 72)
  end if
!
!       if THE ERROR IS NOT FATAL OR THE ERROR IS RECOVERABLE AND THE
!       CONTROL FLAG IS SET FOR RECOVERY, THEN RETURN.
!
   30 if (LEVEL <= 0 .OR. (LEVEL == 1 .AND. MKNTRL <= 1)) RETURN
!
!       THE PROGRAM WILL BE STOPPED DUE TO AN UNRECOVERED ERROR OR A
!       FATAL ERROR.  PRINT THE REASON FOR THE ABORT AND THE ERROR
!       SUMMARY if THE CONTROL FLAG AND THE MAXIMUM ERROR COUNT PERMIT.
!
  if (LKNTRL > 0 .AND. KOUNT < MAX(1,MAXMES)) THEN
     if (LEVEL  ==  1) THEN
        call XERPRN &
           (' ***', -1, 'JOB ABORT DUE TO UNRECOVERED ERROR.', 72)
     ELSE
        call XERPRN(' ***', -1, 'JOB ABORT DUE TO FATAL ERROR.', 72)
     ENDIF
     call XERSVE (' ', ' ', ' ', -1, 0, 0, KDUMMY)
     call XERHLT (' ')
  ELSE
     call XERHLT (MESSG)
  end if
  return
end



subroutine XERPRN (PREFIX, NPREF, MESSG, NWRAP)
!
!! XERPRN prints XERROR error messages processed by XERMSG.
!
!***LIBRARY   SLATEC (XERROR)
!***CATEGORY  R3C
!***TYPE      ALL (XERPRN-A)
!***KEYWORDS  ERROR MESSAGES, PRINTING, XERROR
!***AUTHOR  Fong, Kirby, (NMFECC at LLNL)
!***DESCRIPTION
!
! This routine sends one or more lines to each of the (up to five)
! logical units to which error messages are to be sent.  This routine
! is called several times by XERMSG, sometimes with a single line to
! print and sometimes with a (potentially very long) message that may
! wrap around into multiple lines.
!
! PREFIX  Input argument of type CHARACTER.  This argument contains
!         characters to be put at the beginning of each line before
!         the body of the message.  No more than 16 characters of
!         PREFIX will be used.
!
! NPREF   Input argument of type INTEGER.  This argument is the number
!         of characters to use from PREFIX.  If it is negative, the
!         intrinsic function LEN is used to determine its length.  If
!         it is zero, PREFIX is not used.  If it exceeds 16 or if
!         LEN(PREFIX) exceeds 16, only the first 16 characters will be
!         used.  If NPREF is positive and the length of PREFIX is less
!         than NPREF, a copy of PREFIX extended with blanks to length
!         NPREF will be used.
!
! MESSG   Input argument of type CHARACTER.  This is the text of a
!         message to be printed.  If it is a long message, it will be
!         broken into pieces for printing on multiple lines.  Each line
!         will start with the appropriate prefix and be followed by a
!         piece of the message.  NWRAP is the number of characters per
!         piece; that is, after each NWRAP characters, we break and
!         start a new line.  In addition the characters '$$' embedded
!         in MESSG are a sentinel for a new line.  The counting of
!         characters up to NWRAP starts over for each new line.  The
!         value of NWRAP typically used by XERMSG is 72 since many
!         older error messages in the SLATEC Library are laid out to
!         rely on wrap-around every 72 characters.
!
! NWRAP   Input argument of type INTEGER.  This gives the maximum size
!         piece into which to break MESSG for printing on multiple
!         lines.  An embedded '$$' ends a line, and the count restarts
!         at the following character.  If a line break does not occur
!         on a blank (it would split a word) that word is moved to the
!         next line.  Values of NWRAP less than 16 will be treated as
!         16.  Values of NWRAP greater than 132 will be treated as 132.
!         The actual line length will be NPREF + NWRAP after NPREF has
!         been adjusted to fall between 0 and 16 and NWRAP has been
!         adjusted to fall between 16 and 132.
!
!***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
!                 Error-handling Package, SAND82-0800, Sandia
!                 Laboratories, 1982.
!***ROUTINES CALLED  I1MACH, XGETUA
!***REVISION HISTORY  (YYMMDD)
!   880621  DATE WRITTEN
!   880708  REVISED AFTER THE SLATEC CML SUBCOMMITTEE MEETING OF
!           JUNE 29 AND 30 TO CHANGE THE NAME TO XERPRN AND TO REWORK
!           THE HANDLING OF THE NEW LINE SENTINEL TO BEHAVE LIKE THE
!           SLASH CHARACTER IN FORMAT STATEMENTS.
!   890706  REVISED WITH THE HELP OF FRED FRITSCH AND REG CLEMENS TO
!           STREAMLINE THE CODING AND FIX A BUG THAT CAUSED EXTRA BLANK
!           LINES TO BE PRINTED.
!   890721  REVISED TO ADD A NEW FEATURE.  A NEGATIVE VALUE OF NPREF
!           CAUSES LEN(PREFIX) TO BE USED AS THE LENGTH.
!   891013  REVISED TO CORRECT ERROR IN CALCULATING PREFIX LENGTH.
!   891214  Prologue converted to Version 4.0 format.  (WRB)
!   900510  Added code to break messages between words.  (RWC)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  XERPRN
  CHARACTER*(*) PREFIX, MESSG
  INTEGER NPREF, NWRAP
  CHARACTER*148 CBUFF
  INTEGER IU(5), NUNIT
  CHARACTER*2 NEWLIN
  PARAMETER (NEWLIN = '$$')
!***FIRST EXECUTABLE STATEMENT  XERPRN
  call XGETUA(IU,NUNIT)
!
!       A ZERO VALUE FOR A LOGICAL UNIT NUMBER MEANS TO USE THE STANDARD
!       ERROR MESSAGE UNIT INSTEAD.  I1MACH(4) RETRIEVES THE STANDARD
!       ERROR MESSAGE UNIT.
!
  N = I1MACH(4)
  DO 10 I=1,NUNIT
     if (IU(I)  ==  0) IU(I) = N
   10 CONTINUE
!
!       LPREF IS THE LENGTH OF THE PREFIX.  THE PREFIX IS PLACED AT THE
!       BEGINNING OF CBUFF, THE CHARACTER BUFFER, AND KEPT THERE DURING
!       THE REST OF THIS ROUTINE.
!
  if ( NPREF  <  0 ) THEN
     LPREF = LEN(PREFIX)
  ELSE
     LPREF = NPREF
  end if
  LPREF = MIN(16, LPREF)
  if (LPREF  /=  0) CBUFF(1:LPREF) = PREFIX
!
!       LWRAP IS THE MAXIMUM NUMBER OF CHARACTERS WE WANT TO TAKE AT ONE
!       TIME FROM MESSG TO PRINT ON ONE LINE.
!
  LWRAP = MAX(16, MIN(132, NWRAP))
!
!       SET LENMSG TO THE LENGTH OF MESSG, IGNORE ANY TRAILING BLANKS.
!
  LENMSG = LEN(MESSG)
  N = LENMSG
  DO 20 I=1,N
     if (MESSG(LENMSG:LENMSG)  /=  ' ') go to 30
     LENMSG = LENMSG - 1
   20 CONTINUE
   30 CONTINUE
!
!       if THE MESSAGE IS ALL BLANKS, THEN PRINT ONE BLANK LINE.
!
  if (LENMSG  ==  0) THEN
     CBUFF(LPREF+1:LPREF+1) = ' '
     DO 40 I=1,NUNIT
        WRITE(IU(I), '(A)') CBUFF(1:LPREF+1)
   40    CONTINUE
     return
  end if
!
!       SET NEXTC TO THE POSITION IN MESSG WHERE THE NEXT SUBSTRING
!       STARTS.  FROM THIS POSITION WE SCAN FOR THE NEW LINE SENTINEL.
!       WHEN NEXTC EXCEEDS LENMSG, THERE IS NO MORE TO PRINT.
!       WE LOOP BACK TO LABEL 50 UNTIL ALL PIECES HAVE BEEN PRINTED.
!
!       WE LOOK FOR THE NEXT OCCURRENCE OF THE NEW LINE SENTINEL.  THE
!       INDEX INTRINSIC FUNCTION RETURNS ZERO if THERE IS NO OCCURRENCE
!       OR if THE LENGTH OF THE FIRST ARGUMENT IS LESS THAN THE LENGTH
!       OF THE SECOND ARGUMENT.
!
!       THERE ARE SEVERAL CASES WHICH SHOULD BE CHECKED FOR IN THE
!       FOLLOWING ORDER.  WE ARE ATTEMPTING TO SET LPIECE TO THE NUMBER
!       OF CHARACTERS THAT SHOULD BE TAKEN FROM MESSG STARTING AT
!       POSITION NEXTC.
!
!       LPIECE  ==  0   THE NEW LINE SENTINEL DOES NOT OCCUR IN THE
!                       REMAINDER OF THE CHARACTER STRING.  LPIECE
!                       SHOULD BE SET TO LWRAP OR LENMSG+1-NEXTC,
!                       WHICHEVER IS LESS.
!
!       LPIECE  ==  1   THE NEW LINE SENTINEL STARTS AT MESSG(NEXTC:
!                       NEXTC).  LPIECE IS EFFECTIVELY ZERO, AND WE
!                       PRINT NOTHING TO AVOID PRODUCING UNNECESSARY
!                       BLANK LINES.  THIS TAKES CARE OF THE SITUATION
!                       WHERE THE LIBRARY ROUTINE HAS A MESSAGE OF
!                       EXACTLY 72 CHARACTERS FOLLOWED BY A NEW LINE
!                       SENTINEL FOLLOWED BY MORE CHARACTERS.  NEXTC
!                       SHOULD BE INCREMENTED BY 2.
!
!       LPIECE  >  LWRAP+1  REDUCE LPIECE TO LWRAP.
!
!       ELSE            THIS LAST CASE MEANS 2  <=  LPIECE  <=  LWRAP+1
!                       RESET LPIECE = LPIECE-1.  NOTE THAT THIS
!                       PROPERLY HANDLES THE END CASE WHERE LPIECE  ==
!                       LWRAP+1.  THAT IS, THE SENTINEL FALLS EXACTLY
!                       AT THE END OF A LINE.
!
  NEXTC = 1
   50 LPIECE = INDEX(MESSG(NEXTC:LENMSG), NEWLIN)
  if (LPIECE  ==  0) THEN
!
!       THERE WAS NO NEW LINE SENTINEL FOUND.
!
     IDELTA = 0
     LPIECE = MIN(LWRAP, LENMSG+1-NEXTC)
     if (LPIECE  <  LENMSG+1-NEXTC) THEN
        DO 52 I=LPIECE+1,2,-1
           if (MESSG(NEXTC+I-1:NEXTC+I-1)  ==  ' ') THEN
              LPIECE = I-1
              IDELTA = 1
              GOTO 54
           ENDIF
   52       CONTINUE
     ENDIF
   54    CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
     NEXTC = NEXTC + LPIECE + IDELTA
  ELSEIF (LPIECE  ==  1) THEN
!
!       WE HAVE A NEW LINE SENTINEL AT MESSG(NEXTC:NEXTC+1).
!       DON'T PRINT A BLANK LINE.
!
     NEXTC = NEXTC + 2
     go to 50
  ELSEIF (LPIECE  >  LWRAP+1) THEN
!
!       LPIECE SHOULD BE SET DOWN TO LWRAP.
!
     IDELTA = 0
     LPIECE = LWRAP
     DO 56 I=LPIECE+1,2,-1
        if (MESSG(NEXTC+I-1:NEXTC+I-1)  ==  ' ') THEN
           LPIECE = I-1
           IDELTA = 1
           GOTO 58
        ENDIF
   56    CONTINUE
   58    CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
     NEXTC = NEXTC + LPIECE + IDELTA
  ELSE
!
!       if WE ARRIVE HERE, IT MEANS 2  <=  LPIECE  <=  LWRAP+1.
!       WE SHOULD DECREMENT LPIECE BY ONE.
!
     LPIECE = LPIECE - 1
     CBUFF(LPREF+1:LPREF+LPIECE) = MESSG(NEXTC:NEXTC+LPIECE-1)
     NEXTC  = NEXTC + LPIECE + 2
  end if
!
!       PRINT
!
  DO 60 I=1,NUNIT
     WRITE(IU(I), '(A)') CBUFF(1:LPREF+LPIECE)
   60 CONTINUE
!
  if (NEXTC  <=  LENMSG) go to 50
  return
end



subroutine XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, &
     ICOUNT)
!
!! XERSVE records that an XERROR error has occurred.
!
!***LIBRARY   SLATEC (XERROR)
!***CATEGORY  R3
!***TYPE      ALL (XERSVE-A)
!***KEYWORDS  ERROR, XERROR
!***AUTHOR  Jones, R. E., (SNLA)
!***DESCRIPTION
!
! *Usage:
!
!        INTEGER  KFLAG, NERR, LEVEL, ICOUNT
!        CHARACTER * (len) LIBRAR, SUBROU, MESSG
!
!        call XERSVE (LIBRAR, SUBROU, MESSG, KFLAG, NERR, LEVEL, ICOUNT)
!
! *Arguments:
!
!        LIBRAR :IN    is the library that the message is from.
!        SUBROU :IN    is the subroutine that the message is from.
!        MESSG  :IN    is the message to be saved.
!        KFLAG  :IN    indicates the action to be performed.
!                      when KFLAG > 0, the message in MESSG is saved.
!                      when KFLAG=0 the tables will be dumped and
!                      cleared.
!                      when KFLAG < 0, the tables will be dumped and
!                      not cleared.
!        NERR   :IN    is the error number.
!        LEVEL  :IN    is the error severity.
!        ICOUNT :OUT   the number of times this message has been seen,
!                      or zero if the table has overflowed and does not
!                      contain this message specifically.  When KFLAG=0,
!                      ICOUNT will not be altered.
!
! *Description:
!
!   Record that this error occurred and possibly dump and clear the
!   tables.
!
!***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
!                 Error-handling Package, SAND82-0800, Sandia
!                 Laboratories, 1982.
!***ROUTINES CALLED  I1MACH, XGETUA
!***REVISION HISTORY  (YYMMDD)
!   800319  DATE WRITTEN
!   861211  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   900413  Routine modified to remove reference to KFLAG.  (WRB)
!   900510  Changed to add LIBRARY NAME and SUBROUTINE to calling
!           sequence, use IF-THEN-ELSE, make number of saved entries
!           easily changeable, changed routine name from XERSAV to
!           XERSVE.  (RWC)
!   910626  Added LIBTAB and SUBTAB to SAVE statement.  (BKS)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  XERSVE
  PARAMETER (LENTAB=10)
  INTEGER LUN(5)
  CHARACTER*(*) LIBRAR, SUBROU, MESSG
  CHARACTER*8  LIBTAB(LENTAB), SUBTAB(LENTAB), LIB, SUB
  CHARACTER*20 MESTAB(LENTAB), MES
  DIMENSION NERTAB(LENTAB), LEVTAB(LENTAB), KOUNT(LENTAB)
  SAVE LIBTAB, SUBTAB, MESTAB, NERTAB, LEVTAB, KOUNT, KOUNTX, NMSG
  DATA KOUNTX/0/, NMSG/0/
!***FIRST EXECUTABLE STATEMENT  XERSVE
!
  if (KFLAG <= 0) THEN
!
!        Dump the table.
!
     if (NMSG == 0) RETURN
!
!        Print to each unit.
!
     call XGETUA (LUN, NUNIT)
     DO 20 KUNIT = 1,NUNIT
        IUNIT = LUN(KUNIT)
        if (IUNIT == 0) IUNIT = I1MACH(4)
!
!           Print the table header.
!
        WRITE (IUNIT,9000)
!
!           Print body of table.
!
        DO 10 I = 1,NMSG
           WRITE (IUNIT,9010) LIBTAB(I), SUBTAB(I), MESTAB(I), &
              NERTAB(I),LEVTAB(I),KOUNT(I)
   10       CONTINUE
!
!           Print number of other errors.
!
        if (KOUNTX /= 0) WRITE (IUNIT,9020) KOUNTX
        WRITE (IUNIT,9030)
   20    CONTINUE
!
!        Clear the error tables.
!
     if (KFLAG == 0) THEN
        NMSG = 0
        KOUNTX = 0
     ENDIF
  ELSE
!
!        PROCESS A MESSAGE...
!        SEARCH FOR THIS MESSG, OR ELSE AN EMPTY SLOT FOR THIS MESSG,
!        OR ELSE DETERMINE THAT THE ERROR TABLE IS FULL.
!
     LIB = LIBRAR
     SUB = SUBROU
     MES = MESSG
     DO 30 I = 1,NMSG
        if (LIB == LIBTAB(I) .AND. SUB == SUBTAB(I) .AND. &
           MES == MESTAB(I) .AND. NERR == NERTAB(I) .AND. &
           LEVEL == LEVTAB(I)) THEN
              KOUNT(I) = KOUNT(I) + 1
              ICOUNT = KOUNT(I)
              return
        ENDIF
   30    CONTINUE
!
     if (NMSG < LENTAB) THEN
!
!           Empty slot found for new message.
!
        NMSG = NMSG + 1
        LIBTAB(I) = LIB
        SUBTAB(I) = SUB
        MESTAB(I) = MES
        NERTAB(I) = NERR
        LEVTAB(I) = LEVEL
        KOUNT (I) = 1
        ICOUNT    = 1
     ELSE
!
!           Table is full.
!
        KOUNTX = KOUNTX+1
        ICOUNT = 0
     ENDIF
  end if
  return
!
!     Formats.
!
 9000 FORMAT ('0          ERROR MESSAGE SUMMARY' / &
     ' LIBRARY    SUBROUTINE MESSAGE START             NERR', &
     '     LEVEL     COUNT')
 9010 FORMAT (1X,A,3X,A,3X,A,3I10)
 9020 FORMAT ('0OTHER ERRORS NOT INDIVIDUALLY TABULATED = ', I10)
 9030 FORMAT (1X)
end



subroutine XGETUA (IUNITA, N)
!
!! XGETUA returns unit numbers to which XERROR messages are sent.
!
!***LIBRARY   SLATEC (XERROR)
!***CATEGORY  R3C
!***TYPE      ALL (XGETUA-A)
!***KEYWORDS  ERROR, XERROR
!***AUTHOR  Jones, R. E., (SNLA)
!***DESCRIPTION
!
!     Abstract
!        XGETUA may be called to determine the unit number or numbers
!        to which error messages are being sent.
!        These unit numbers may have been set by a call to XSETUN,
!        or a call to XSETUA, or may be a default value.
!
!     Description of Parameters
!      --Output--
!        IUNIT - an array of one to five unit numbers, depending
!                on the value of N.  A value of zero refers to the
!                default unit, as defined by the I1MACH machine
!                constant routine.  Only IUNIT(1),...,IUNIT(N) are
!                defined by XGETUA.  The values of IUNIT(N+1),...,
!                IUNIT(5) are not defined (for N  <  5) or altered
!                in any way by XGETUA.
!        N     - the number of units to which copies of the
!                error messages are being sent.  N will be in the
!                range from 1 to 5.
!
!***REFERENCES  R. E. Jones and D. K. Kahaner, XERROR, the SLATEC
!                 Error-handling Package, SAND82-0800, Sandia
!                 Laboratories, 1982.
!***ROUTINES CALLED  J4SAVE
!***REVISION HISTORY  (YYMMDD)
!   790801  DATE WRITTEN
!   861211  REVISION DATE from Version 3.2
!   891214  Prologue converted to Version 4.0 format.  (BAB)
!   920501  Reformatted the REFERENCES section.  (WRB)
!***END PROLOGUE  XGETUA
  DIMENSION IUNITA(5)
!***FIRST EXECUTABLE STATEMENT  XGETUA
  N = J4SAVE(5,0,.FALSE.)
  DO 30 I=1,N
     INDEX = I+4
     if (I == 1) INDEX = 3
     IUNITA(I) = J4SAVE(INDEX,0,.FALSE.)
   30 CONTINUE
  return
end



  DOUBLE PRECISION FUNCTION ZABS (ZR, ZI)
!
!! ZABS is subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and ZBIRY.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (ZABS-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     ZABS COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE
!     PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI)
!
!***SEE ALSO  ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY
!***ROUTINES CALLED  (NONE)
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!***END PROLOGUE  ZABS
  DOUBLE PRECISION ZR, ZI, U, V, Q, S
!***FIRST EXECUTABLE STATEMENT  ZABS
  U = ABS(ZR)
  V = ABS(ZI)
  S = U + V
!-----------------------------------------------------------------------
!     S*1.0D0 MAKES AN UNNORMALIZED UNDERFLOW ON CDC MACHINES INTO A
!     TRUE FLOATING ZERO
!-----------------------------------------------------------------------
  S = S*1.0D+0
  if (S == 0.0D+0) go to 20
  if (U > V) go to 10
  Q = U/V
  ZABS = V*SQRT(1.D+0+Q*Q)
  return
   10 Q = V/U
  ZABS = U*SQRT(1.D+0+Q*Q)
  return
   20 ZABS = 0.0D+0
  return
end



subroutine ZACAI (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, TOL, &
     ELIM, ALIM)
!
!! ZACAI is subsidiary to ZAIRY
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CACAI-A, ZACAI-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     ZACAI APPLIES THE ANALYTIC CONTINUATION FORMULA
!
!         K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN)
!                 MP=PI*MR*CMPLX(0.0,1.0)
!
!     TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT
!     HALF Z PLANE FOR USE WITH ZAIRY WHERE FNU=1/3 OR 2/3 AND N=1.
!     ZACAI IS THE SAME AS ZACON WITH THE PARTS FOR LARGER ORDERS AND
!     RECURRENCE REMOVED. A RECURSIVE call TO ZACON CAN RESULT if ZACON
!     IS CALLED FROM ZAIRY.
!
!***SEE ALSO  ZAIRY
!***ROUTINES CALLED  D1MACH, ZABS, ZASYI, ZBKNU, ZMLRI, ZS1S2, ZSERI
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!***END PROLOGUE  ZACAI
!     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)
  EXTERNAL ZABS
  DATA PI / 3.14159265358979324D0 /
!***FIRST EXECUTABLE STATEMENT  ZACAI
  NZ = 0
  ZNR = -ZR
  ZNI = -ZI
  AZ = ZABS(ZR,ZI)
  NN = N
  DFNU = FNU + (N-1)
  if (AZ <= 2.0D0) go to 10
  if (AZ*AZ*0.25D0 > DFNU+1.0D0) go to 20
   10 CONTINUE
!-----------------------------------------------------------------------
!     POWER SERIES FOR THE I FUNCTION
!-----------------------------------------------------------------------
  call ZSERI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL, ELIM, ALIM)
  go to 40
   20 CONTINUE
  if (AZ < RL) go to 30
!-----------------------------------------------------------------------
!     ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I FUNCTION
!-----------------------------------------------------------------------
  call ZASYI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, TOL, ELIM, &
   ALIM)
  if (NW < 0) go to 80
  go to 40
   30 CONTINUE
!-----------------------------------------------------------------------
!     MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION
!-----------------------------------------------------------------------
  call ZMLRI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL)
  if ( NW < 0) go to 80
   40 CONTINUE
!-----------------------------------------------------------------------
!     ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION
!-----------------------------------------------------------------------
  call ZBKNU(ZNR, ZNI, FNU, KODE, 1, CYR, CYI, NW, TOL, ELIM, ALIM)
  if (NW /= 0) go to 80
  FMR = MR
  SGN = -DSIGN(PI,FMR)
  CSGNR = 0.0D0
  CSGNI = SGN
  if (KODE == 1) go to 50
  YY = -ZNI
  CSGNR = -CSGNI*SIN(YY)
  CSGNI = CSGNI*COS(YY)
   50 CONTINUE
!-----------------------------------------------------------------------
!     CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
!     WHEN FNU IS LARGE
!-----------------------------------------------------------------------
  INU = FNU
  ARG = (FNU-INU)*SGN
  CSPNR = COS(ARG)
  CSPNI = SIN(ARG)
  if (MOD(INU,2) == 0) go to 60
  CSPNR = -CSPNR
  CSPNI = -CSPNI
   60 CONTINUE
  C1R = CYR(1)
  C1I = CYI(1)
  C2R = YR(1)
  C2I = YI(1)
  if (KODE == 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 == (-2)) NZ=-2
  return
end



subroutine ZACON (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, FNUL, &
     TOL, ELIM, ALIM)
!
!! ZACON is subsidiary to ZBESH and ZBESK
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CACON-A, ZACON-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     ZACON APPLIES THE ANALYTIC CONTINUATION FORMULA
!
!         K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN)
!                 MP=PI*MR*CMPLX(0.0,1.0)
!
!     TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT
!     HALF Z PLANE
!
!***SEE ALSO  ZBESH, ZBESK
!***ROUTINES CALLED  D1MACH, ZABS, ZBINU, ZBKNU, ZMLT, ZS1S2
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!***END PROLOGUE  ZACON
!     COMPLEX CK,CONE,CSCL,CSCR,CSGN,CSPN,CY,CZERO,C1,C2,RZ,SC1,SC2,ST,
!    *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)
  EXTERNAL ZABS
  DATA PI / 3.14159265358979324D0 /
  DATA ZEROR,CONER / 0.0D0,1.0D0 /
!***FIRST EXECUTABLE STATEMENT  ZACON
  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 < 0) go to 90
!-----------------------------------------------------------------------
!     ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION
!-----------------------------------------------------------------------
  NN = MIN(2,N)
  call ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM)
  if (NW /= 0) go to 90
  S1R = CYR(1)
  S1I = CYI(1)
  FMR = MR
  SGN = -DSIGN(PI,FMR)
  CSGNR = ZEROR
  CSGNI = SGN
  if (KODE == 1) go to 10
  YY = -ZNI
  CPN = COS(YY)
  SPN = SIN(YY)
  call ZMLT(CSGNR, CSGNI, CPN, SPN, CSGNR, CSGNI)
   10 CONTINUE
!-----------------------------------------------------------------------
!     CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
!     WHEN FNU IS LARGE
!-----------------------------------------------------------------------
  INU = FNU
  ARG = (FNU-INU)*SGN
  CPN = COS(ARG)
  SPN = SIN(ARG)
  CSPNR = CPN
  CSPNI = SPN
  if (MOD(INU,2) == 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 == 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 == 1) RETURN
  CSPNR = -CSPNR
  CSPNI = -CSPNI
  S2R = CYR(2)
  S2I = CYI(2)
  C1R = S2R
  C1I = S2I
  C2R = YR(2)
  C2I = YI(2)
  if (KODE == 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 == 2) RETURN
  CSPNR = -CSPNR
  CSPNI = -CSPNI
  AZN = ZABS(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
!-----------------------------------------------------------------------
!     SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS
!-----------------------------------------------------------------------
  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(S2R,S2I)
  KFLAG = 2
  if (AS2 > BRY(1)) go to 50
  KFLAG = 1
  go to 60
   50 CONTINUE
  if (AS2 < 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 == 1) go to 70
    if (IUF < 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 /= 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 >= 3) go to 80
    PTR = ABS(C1R)
    PTI = ABS(C1I)
    C1M = MAX(PTR,PTI)
    if (C1M <= 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 == (-2)) NZ=-2
  return
end



subroutine ZAIRY (ZR, ZI, ID, KODE, AIR, AII, NZ, IERR)
!
!! ZAIRY computes the Airy function Ai(z) or its derivative dAi/dz ...
!            for complex argument z.  A scaling option is available ...
!            to help avoid underflow and overflow.
!
!***LIBRARY   SLATEC
!***CATEGORY  C10D
!***TYPE      COMPLEX (CAIRY-C, ZAIRY-C)
!***KEYWORDS  AIRY FUNCTION, BESSEL FUNCTION OF ORDER ONE THIRD,
!             BESSEL FUNCTION OF ORDER TWO THIRDS
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!                      ***A DOUBLE PRECISION ROUTINE***
!         On KODE=1, ZAIRY computes the complex Airy function Ai(z)
!         or its derivative dAi/dz on ID=0 or ID=1 respectively. On
!         KODE=2, a scaling option exp(zeta)*Ai(z) or exp(zeta)*dAi/dz
!         is provided to remove the exponential decay in -pi/3<arg(z)
!         <pi/3 and the exponential growth in pi/3<abs(arg(z))<pi where
!         zeta=(2/3)*z**(3/2).
!
!         While the Airy functions Ai(z) and dAi/dz are analytic in
!         the whole z-plane, the corresponding scaled functions defined
!         for KODE=2 have a cut along the negative real axis.
!
!         Input
!           ZR     - DOUBLE PRECISION real part of argument Z
!           ZI     - DOUBLE PRECISION imag part of argument Z
!           ID     - Order of derivative, ID=0 or ID=1
!           KODE   - A parameter to indicate the scaling option
!                    KODE=1  returns
!                            AI=Ai(z)  on ID=0
!                            AI=dAi/dz on ID=1
!                            at z=Z
!                        =2  returns
!                            AI=exp(zeta)*Ai(z)  on ID=0
!                            AI=exp(zeta)*dAi/dz on ID=1
!                            at z=Z where zeta=(2/3)*z**(3/2)
!
!         Output
!           AIR    - DOUBLE PRECISION real part of result
!           AII    - DOUBLE PRECISION imag part of result
!           NZ     - Underflow indicator
!                    NZ=0    Normal return
!                    NZ=1    AI=0 due to underflow in
!                            -pi/3<arg(Z)<pi/3 on KODE=1
!           IERR   - Error flag
!                    IERR=0  Normal return     - COMPUTATION COMPLETED
!                    IERR=1  Input error       - NO COMPUTATION
!                    IERR=2  Overflow          - NO COMPUTATION
!                            (Re(Z) too large with KODE=1)
!                    IERR=3  Precision warning - COMPUTATION COMPLETED
!                            (Result has less than half precision)
!                    IERR=4  Precision error   - NO COMPUTATION
!                            (Result has no precision)
!                    IERR=5  Algorithmic error - NO COMPUTATION
!                            (Termination condition not met)
!
! *Long Description:
!
!         Ai(z) and dAi/dz are computed from K Bessel functions by
!
!                Ai(z) =  c*sqrt(z)*K(1/3,zeta)
!               dAi/dz = -c*   z   *K(2/3,zeta)
!                    c =  1/(pi*sqrt(3))
!                 zeta =  (2/3)*z**(3/2)
!
!         when abs(z)>1 and from power series when abs(z)<=1.
!
!         In most complex variable computation, one must evaluate ele-
!         mentary functions.  When the magnitude of Z is large, losses
!         of significance by argument reduction occur.  Consequently, if
!         the magnitude of ZETA=(2/3)*Z**(3/2) exceeds U1=SQRT(0.5/UR),
!         then losses exceeding half precision are likely and an error
!         flag IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is
!         double precision unit roundoff limited to 18 digits precision.
!         Also, if the magnitude of ZETA is larger than U2=0.5/UR, then
!         all significance is lost and IERR=4.  In order to use the INT
!         function, ZETA must be further restricted not to exceed
!         U3=I1MACH(9)=LARGEST INTEGER.  Thus, the magnitude of ZETA
!         must be restricted by MIN(U2,U3).  In IEEE arithmetic, U1,U2,
!         and U3 are approximately 2.0E+3, 4.2E+6, 2.1E+9 in single
!         precision and 4.7E+7, 2.3E+15, 2.1E+9 in double precision.
!         This makes U2 limiting is single precision and U3 limiting
!         in double precision.  This means that the magnitude of Z
!         cannot exceed approximately 3.4E+4 in single precision and
!         2.1E+6 in double precision.  This also means that one can
!         expect to retain, in the worst cases on 32-bit machines,
!         no digits in single precision and only 6 digits in double
!         precision.
!
!         The approximate relative error in the magnitude of a complex
!         Bessel function can be expressed as P*10**S where P=MAX(UNIT
!         ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre-
!         sents the increase in error due to argument reduction in the
!         elementary functions.  Here, S=MAX(1,ABS(LOG10(ABS(Z))),
!         ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF
!         ABS(Z),ABS(EXPONENT OF FNU)) ).  However, the phase angle may
!         have only absolute accuracy.  This is most likely to occur
!         when one component (in magnitude) is larger than the other by
!         several orders of magnitude.  If one component is 10**K larger
!         than the other, then one can expect only MAX(ABS(LOG10(P))-K,
!         0) significant digits; or, stated another way, when K exceeds
!         the exponent of P, no significant digits remain in the smaller
!         component.  However, the phase angle retains absolute accuracy
!         because, in complex arithmetic with precision P, the smaller
!         component will not (as a rule) decrease below P times the
!         magnitude of the larger component. In these extreme cases,
!         the principal phase angle is on the order of +P, -P, PI/2-P,
!         or -PI/2+P.
!
!***REFERENCES  1. M. Abramowitz and I. A. Stegun, Handbook of Mathe-
!                 matical Functions, National Bureau of Standards
!                 Applied Mathematics Series 55, U. S. Department
!                 of Commerce, Tenth Printing (1972) or later.
!               2. D. E. Amos, Computation of Bessel Functions of
!                 Complex Argument and Large Order, Report SAND83-0643,
!                 Sandia National Laboratories, Albuquerque, NM, May
!                 1983.
!               3. D. E. Amos, A Subroutine Package for Bessel Functions
!                 of a Complex Argument and Nonnegative Order, Report
!                 SAND85-1018, Sandia National Laboratory, Albuquerque,
!                 NM, May 1985.
!               4. D. E. Amos, A portable package for Bessel functions
!                 of a complex argument and nonnegative order, ACM
!                 Transactions on Mathematical Software, 12 (September
!                 1986), pp. 265-273.
!
!***ROUTINES CALLED  D1MACH, I1MACH, ZABS, ZACAI, ZBKNU, ZEXP, ZSQRT
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   890801  REVISION DATE from Version 3.2
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!   920128  Category corrected.  (WRB)
!   920811  Prologue revised.  (DWL)
!   930122  Added ZEXP and ZSQRT to EXTERNAL statement.  (RWC)
!***END PROLOGUE  ZAIRY
!     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)
  EXTERNAL ZABS, ZEXP, ZSQRT
  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/
!***FIRST EXECUTABLE STATEMENT  ZAIRY
  IERR = 0
  NZ=0
  if (ID < 0 .OR. ID > 1) IERR=1
  if (KODE < 1 .OR. KODE > 2) IERR=1
  if (IERR /= 0) RETURN
  AZ = ZABS(ZR,ZI)
  TOL = MAX(D1MACH(4),1.0D-18)
  FID = ID
  if (AZ > 1.0D0) go to 70
!-----------------------------------------------------------------------
!     POWER SERIES FOR ABS(Z) <= 1.
!-----------------------------------------------------------------------
  S1R = CONER
  S1I = CONEI
  S2R = CONER
  S2I = CONEI
  if (AZ < TOL) go to 170
  AA = AZ*AZ
  if (AA < 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 = MIN(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 = MIN(D1,D2)
    if (ATRM < TOL*AD) go to 40
    AK = AK + 18.0D0
    BK = BK + 18.0D0
   30 CONTINUE
   40 CONTINUE
  if (ID == 1) go to 50
  AIR = S1R*C1 - C2*(ZR*S2R-ZI*S2I)
  AII = S1I*C1 - C2*(ZR*S2I+ZI*S2R)
  if (KODE == 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 <= 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 == 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
!-----------------------------------------------------------------------
!     CASE FOR ABS(Z) > 1.0
!-----------------------------------------------------------------------
   70 CONTINUE
  FNU = (1.0D0+FID)/3.0D0
!-----------------------------------------------------------------------
!     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
!     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0D-18.
!     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
!     EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL    AND
!     EXP(ELIM) > EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
!     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
!     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
!     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
!-----------------------------------------------------------------------
  K1 = I1MACH(15)
  K2 = I1MACH(16)
  R1M5 = D1MACH(5)
  K = MIN(ABS(K1),ABS(K2))
  ELIM = 2.303D0*(K*R1M5-3.0D0)
  K1 = I1MACH(14) - 1
  AA = R1M5*K1
  DIG = MIN(AA,18.0D0)
  AA = AA*2.303D0
  ALIM = ELIM + MAX(-AA,-41.45D0)
  RL = 1.2D0*DIG + 3.0D0
  ALAZ = LOG(AZ)
!-----------------------------------------------------------------------
!     TEST FOR PROPER RANGE
!-----------------------------------------------------------------------
  AA=0.5D0/TOL
  BB=I1MACH(9)*0.5D0
  AA=MIN(AA,BB)
  AA=AA**TTH
  if (AZ > AA) go to 260
  AA=SQRT(AA)
  if (AZ > AA) IERR=3
  call ZSQRT(ZR, ZI, CSQR, CSQI)
  ZTAR = TTH*(ZR*CSQR-ZI*CSQI)
  ZTAI = TTH*(ZR*CSQI+ZI*CSQR)
!-----------------------------------------------------------------------
!     RE(ZTA) <= 0 WHEN RE(Z) < 0, ESPECIALLY WHEN IM(Z) IS SMALL
!-----------------------------------------------------------------------
  IFLAG = 0
  SFAC = 1.0D0
  AK = ZTAI
  if (ZR >= 0.0D0) go to 80
  BK = ZTAR
  CK = -ABS(BK)
  ZTAR = CK
  ZTAI = AK
   80 CONTINUE
  if (ZI /= 0.0D0) go to 90
  if (ZR > 0.0D0) go to 90
  ZTAR = 0.0D0
  ZTAI = AK
   90 CONTINUE
  AA = ZTAR
  if (AA >= 0.0D0 .AND. ZR > 0.0D0) go to 110
  if (KODE == 2) go to 100
!-----------------------------------------------------------------------
!     OVERFLOW TEST
!-----------------------------------------------------------------------
  if (AA > (-ALIM)) go to 100
  AA = -AA + 0.25D0*ALAZ
  IFLAG = 1
  SFAC = TOL
  if (AA > ELIM) go to 270
  100 CONTINUE
!-----------------------------------------------------------------------
!     CBKNU AND CACON RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2
!-----------------------------------------------------------------------
  MR = 1
  if (ZI < 0.0D0) MR = -1
  call ZACAI(ZTAR, ZTAI, FNU, KODE, MR, 1, CYR, CYI, NN, RL, TOL, &
   ELIM, ALIM)
  if (NN < 0) go to 280
  NZ = NZ + NN
  go to 130
  110 CONTINUE
  if (KODE == 2) go to 120
!-----------------------------------------------------------------------
!     UNDERFLOW TEST
!-----------------------------------------------------------------------
  if (AA < ALIM) go to 120
  AA = -AA - 0.25D0*ALAZ
  IFLAG = 2
  SFAC = 1.0D0/TOL
  if (AA < (-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 /= 0) go to 150
  if (ID == 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 == 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 == 1) go to 190
  if (AZ <= 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 = SQRT(AA)
  if (AZ <= 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 == (-1)) go to 270
  NZ=0
  IERR=5
  return
  260 CONTINUE
  IERR=4
  NZ=0
  return
end



subroutine ZASYI (ZR, ZI, FNU, KODE, N, YR, YI, NZ, RL, TOL, ELIM, &
     ALIM)
!
!! ZASYI is subsidiary to ZBESI and ZBESK.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CASYI-A, ZASYI-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     ZASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z) >= 0.0 BY
!     MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE ABS(Z) IN THE
!     REGION ABS(Z) > MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL RETURN.
!     NZ < 0 INDICATES AN OVERFLOW ON KODE=1.
!
!***SEE ALSO  ZBESI, ZBESK
!***ROUTINES CALLED  D1MACH, ZABS, ZDIV, ZEXP, ZMLT, ZSQRT
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!   930122  Added ZEXP and ZSQRT to EXTERNAL statement.  (RWC)
!***END PROLOGUE  ZASYI
!     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)
  EXTERNAL ZABS, ZEXP, ZSQRT
  DATA PI, RTPI  /3.14159265358979324D0 , 0.159154943091895336D0 /
  DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
!***FIRST EXECUTABLE STATEMENT  ZASYI
  NZ = 0
  AZ = ZABS(ZR,ZI)
  ARM = 1.0D+3*D1MACH(1)
  RTR1 = SQRT(ARM)
  IL = MIN(2,N)
  DFNU = FNU + (N-IL)
!-----------------------------------------------------------------------
!     OVERFLOW TEST
!-----------------------------------------------------------------------
  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 /= 2) go to 10
  CZR = ZEROR
  CZI = ZI
   10 CONTINUE
  if (ABS(CZR) > ELIM) go to 100
  DNU2 = DFNU + DFNU
  KODED = 1
  if ((ABS(CZR) > ALIM) .AND. (N > 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 > RTR1) FDN = DNU2*DNU2
  EZR = ZR*8.0D0
  EZI = ZI*8.0D0
!-----------------------------------------------------------------------
!     WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO THE
!     FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF THE
!     EXPANSION FOR THE IMAGINARY PART.
!-----------------------------------------------------------------------
  AEZ = 8.0D0*AZ
  S = TOL/AEZ
  JL = RL+RL + 2
  P1R = ZEROR
  P1I = ZEROI
  if (ZI == 0.0D0) go to 30
!-----------------------------------------------------------------------
!     CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF
!     SIGNIFICANCE WHEN FNU OR N IS LARGE
!-----------------------------------------------------------------------
  INU = FNU
  ARG = (FNU-INU)*PI
  INU = INU + N - IL
  AK = -SIN(ARG)
  BK = COS(ARG)
  if (ZI < 0.0D0) BK = -BK
  P1R = AK
  P1I = BK
  if (MOD(INU,2) == 0) go to 30
  P1R = -P1R
  P1I = -P1I
   30 CONTINUE
  DO 70 K=1,IL
    SQK = FDN - 1.0D0
    ATOL = S*ABS(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*ABS(SQK)/BB
      BB = BB + AEZ
      AK = AK + 8.0D0
      SQK = SQK - AK
      if (AA <= ATOL) go to 50
   40   CONTINUE
    go to 110
   50   CONTINUE
    S2R = CS1R
    S2I = CS1I
    if (ZR+ZR >= 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 <= 2) RETURN
  NN = N
  K = NN - 2
  AK = 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 == 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



subroutine ZBESH (ZR, ZI, FNU, KODE, M, N, CYR, CYI, NZ, IERR)
!
!! ZBESH computes a sequence of the Hankel functions H(m,a,z) ...
!            for superscript m=1 or 2, real nonnegative orders a=b, ...
!            b+1,... where b>0, and nonzero complex argument z.  A ...
!            scaling option is available to help avoid overflow.
!
!***LIBRARY   SLATEC
!***CATEGORY  C10A4
!***TYPE      COMPLEX (CBESH-C, ZBESH-C)
!***KEYWORDS  BESSEL FUNCTIONS OF COMPLEX ARGUMENT,
!             BESSEL FUNCTIONS OF THE THIRD KIND, H BESSEL FUNCTIONS,
!             HANKEL FUNCTIONS
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!                      ***A DOUBLE PRECISION ROUTINE***
!         On KODE=1, ZBESH computes an N member sequence of complex
!         Hankel (Bessel) functions CY(L)=H(M,FNU+L-1,Z) for super-
!         script M=1 or 2, real nonnegative orders FNU+L-1, L=1,...,
!         N, and complex nonzero Z in the cut plane -pi<arg(Z)<=pi
!         where Z=ZR+i*ZI.  On KODE=2, CBESH returns the scaled
!         functions
!
!            CY(L) = H(M,FNU+L-1,Z)*exp(-(3-2*M)*Z*i),  i**2=-1
!
!         which removes the exponential behavior in both the upper
!         and lower half planes.  Definitions and notation are found
!         in the NBS Handbook of Mathematical Functions (Ref. 1).
!
!         Input
!           ZR     - DOUBLE PRECISION real part of nonzero argument Z
!           ZI     - DOUBLE PRECISION imag part of nonzero argument Z
!           FNU    - DOUBLE PRECISION initial order, FNU>=0
!           KODE   - A parameter to indicate the scaling option
!                    KODE=1  returns
!                            CY(L)=H(M,FNU+L-1,Z), L=1,...,N
!                        =2  returns
!                            CY(L)=H(M,FNU+L-1,Z)*exp(-(3-2M)*Z*i),
!                            L=1,...,N
!           M      - Superscript of Hankel function, M=1 or 2
!           N      - Number of terms in the sequence, N>=1
!
!         Output
!           CYR    - DOUBLE PRECISION real part of result vector
!           CYI    - DOUBLE PRECISION imag part of result vector
!           NZ     - Number of underflows set to zero
!                    NZ=0    Normal return
!                    NZ>0    CY(L)=0 for NZ values of L (if M=1 and
!                            Im(Z)>0 or if M=2 and Im(Z)<0, then
!                            CY(L)=0 for L=1,...,NZ; in the com-
!                            plementary half planes, the underflows
!                            may not be in an uninterrupted sequence)
!           IERR   - Error flag
!                    IERR=0  Normal return     - COMPUTATION COMPLETED
!                    IERR=1  Input error       - NO COMPUTATION
!                    IERR=2  Overflow          - NO COMPUTATION
!                            (abs(Z) too small and/or FNU+N-1
!                            too large)
!                    IERR=3  Precision warning - COMPUTATION COMPLETED
!                            (Result has half precision or less
!                            because abs(Z) or FNU+N-1 is large)
!                    IERR=4  Precision error   - NO COMPUTATION
!                            (Result has no precision because
!                            abs(Z) or FNU+N-1 is too large)
!                    IERR=5  Algorithmic error - NO COMPUTATION
!                            (Termination condition not met)
!
! *Long Description:
!
!         The computation is carried out by the formula
!
!            H(m,a,z) = (1/t)*exp(-a*t)*K(a,z*exp(-t))
!                   t = (3-2*m)*i*pi/2
!
!         where the K Bessel function is computed as described in the
!         prologue to CBESK.
!
!         Exponential decay of H(m,a,z) occurs in the upper half z
!         plane for m=1 and the lower half z plane for m=2.  Exponential
!         growth occurs in the complementary half planes.  Scaling
!         by exp(-(3-2*m)*z*i) removes the exponential behavior in the
!         whole z plane as z goes to infinity.
!
!         For negative orders, the formula
!
!            H(m,-a,z) = H(m,a,z)*exp((3-2*m)*a*pi*i)
!
!         can be used.
!
!         In most complex variable computation, one must evaluate ele-
!         mentary functions.  When the magnitude of Z or FNU+N-1 is
!         large, losses of significance by argument reduction occur.
!         Consequently, if either one exceeds U1=SQRT(0.5/UR), then
!         losses exceeding half precision are likely and an error flag
!         IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double
!         precision unit roundoff limited to 18 digits precision.  Also,
!         if either is larger than U2=0.5/UR, then all significance is
!         lost and IERR=4.  In order to use the INT function, arguments
!         must be further restricted not to exceed the largest machine
!         integer, U3=I1MACH(9).  Thus, the magnitude of Z and FNU+N-1
!         is restricted by MIN(U2,U3).  In IEEE arithmetic, U1,U2, and
!         U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision
!         and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision.  This
!         makes U2 limiting in single precision and U3 limiting in
!         double precision.  This means that one can expect to retain,
!         in the worst cases on IEEE machines, no digits in single pre-
!         cision and only 6 digits in double precision.  Similar con-
!         siderations hold for other machines.
!
!         The approximate relative error in the magnitude of a complex
!         Bessel function can be expressed as P*10**S where P=MAX(UNIT
!         ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre-
!         sents the increase in error due to argument reduction in the
!         elementary functions.  Here, S=MAX(1,ABS(LOG10(ABS(Z))),
!         ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF
!         ABS(Z),ABS(EXPONENT OF FNU)) ).  However, the phase angle may
!         have only absolute accuracy.  This is most likely to occur
!         when one component (in magnitude) is larger than the other by
!         several orders of magnitude.  If one component is 10**K larger
!         than the other, then one can expect only MAX(ABS(LOG10(P))-K,
!         0) significant digits; or, stated another way, when K exceeds
!         the exponent of P, no significant digits remain in the smaller
!         component.  However, the phase angle retains absolute accuracy
!         because, in complex arithmetic with precision P, the smaller
!         component will not (as a rule) decrease below P times the
!         magnitude of the larger component.  In these extreme cases,
!         the principal phase angle is on the order of +P, -P, PI/2-P,
!         or -PI/2+P.
!
!***REFERENCES  1. M. Abramowitz and I. A. Stegun, Handbook of Mathe-
!                 matical Functions, National Bureau of Standards
!                 Applied Mathematics Series 55, U. S. Department
!                 of Commerce, Tenth Printing (1972) or later.
!               2. D. E. Amos, Computation of Bessel Functions of
!                 Complex Argument, Report SAND83-0086, Sandia National
!                 Laboratories, Albuquerque, NM, May 1983.
!               3. D. E. Amos, Computation of Bessel Functions of
!                 Complex Argument and Large Order, Report SAND83-0643,
!                 Sandia National Laboratories, Albuquerque, NM, May
!                 1983.
!               4. D. E. Amos, A Subroutine Package for Bessel Functions
!                 of a Complex Argument and Nonnegative Order, Report
!                 SAND85-1018, Sandia National Laboratory, Albuquerque,
!                 NM, May 1985.
!               5. D. E. Amos, A portable package for Bessel functions
!                 of a complex argument and nonnegative order, ACM
!                 Transactions on Mathematical Software, 12 (September
!                 1986), pp. 265-273.
!
!***ROUTINES CALLED  D1MACH, I1MACH, ZABS, ZACON, ZBKNU, ZBUNK, ZUOIK
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   890801  REVISION DATE from Version 3.2
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!   920128  Category corrected.  (WRB)
!   920811  Prologue revised.  (DWL)
!***END PROLOGUE  ZBESH
!
!     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)
  EXTERNAL ZABS
!
  DATA HPI /1.57079632679489662D0/
!
!***FIRST EXECUTABLE STATEMENT  ZBESH
  IERR = 0
  NZ=0
  if (ZR == 0.0D0 .AND. ZI == 0.0D0) IERR=1
  if (FNU < 0.0D0) IERR=1
  if (M < 1 .OR. M > 2) IERR=1
  if (KODE < 1 .OR. KODE > 2) IERR=1
  if (N < 1) IERR=1
  if (IERR /= 0) RETURN
  NN = N
!-----------------------------------------------------------------------
!     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
!     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
!     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
!     EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL    AND
!     EXP(ELIM) > EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
!     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
!     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
!     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
!     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU
!-----------------------------------------------------------------------
  TOL = MAX(D1MACH(4),1.0D-18)
  K1 = I1MACH(15)
  K2 = I1MACH(16)
  R1M5 = D1MACH(5)
  K = MIN(ABS(K1),ABS(K2))
  ELIM = 2.303D0*(K*R1M5-3.0D0)
  K1 = I1MACH(14) - 1
  AA = R1M5*K1
  DIG = MIN(AA,18.0D0)
  AA = AA*2.303D0
  ALIM = ELIM + MAX(-AA,-41.45D0)
  FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
  RL = 1.2D0*DIG + 3.0D0
  FN = FNU + (NN-1)
  MM = 3 - M - M
  FMM = MM
  ZNR = FMM*ZI
  ZNI = -FMM*ZR
!-----------------------------------------------------------------------
!     TEST FOR PROPER RANGE
!-----------------------------------------------------------------------
  AZ = ZABS(ZR,ZI)
  AA = 0.5D0/TOL
  BB = I1MACH(9)*0.5D0
  AA = MIN(AA,BB)
  if (AZ > AA) go to 260
  if (FN > AA) go to 260
  AA = SQRT(AA)
  if (AZ > AA) IERR=3
  if (FN > AA) IERR=3
!-----------------------------------------------------------------------
!     OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE
!-----------------------------------------------------------------------
  UFL = D1MACH(1)*1.0D+3
  if (AZ < UFL) go to 230
  if (FNU > FNUL) go to 90
  if (FN <= 1.0D0) go to 70
  if (FN > 2.0D0) go to 60
  if (AZ > TOL) go to 70
  ARG = 0.5D0*AZ
  ALN = -FN*LOG(ARG)
  if (ALN > 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 < 0) go to 230
  NZ = NZ + NUF
  NN = NN - NUF
!-----------------------------------------------------------------------
!     HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK
!     if NUF=NN, THEN CY(I)=CZERO FOR ALL I
!-----------------------------------------------------------------------
  if (NN == 0) go to 140
   70 CONTINUE
  if ((ZNR < 0.0D0) .OR. (ZNR == 0.0D0 .AND. ZNI < 0.0D0 .AND. &
   M == 2)) go to 80
!-----------------------------------------------------------------------
!     RIGHT HALF PLANE COMPUTATION, XN >= 0. .AND. (XN /= 0. .OR.
!     YN >= 0. .OR. M=1)
!-----------------------------------------------------------------------
  call ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NZ, TOL, ELIM, ALIM)
  go to 110
!-----------------------------------------------------------------------
!     LEFT HALF PLANE COMPUTATION
!-----------------------------------------------------------------------
   80 CONTINUE
  MR = -MM
  call ZACON(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL, &
   TOL, ELIM, ALIM)
  if (NW < 0) go to 240
  NZ=NW
  go to 110
   90 CONTINUE
!-----------------------------------------------------------------------
!     UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU > FNUL
!-----------------------------------------------------------------------
  MR = 0
  if ((ZNR >= 0.0D0) .AND. (ZNR /= 0.0D0 .OR. ZNI >= 0.0D0 .OR. &
   M /= 2)) go to 100
  MR = -MM
  if (ZNR /= 0.0D0 .OR. ZNI >= 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 < 0) go to 240
  NZ = NZ + NW
  110 CONTINUE
!-----------------------------------------------------------------------
!     H(M,FNU,Z) = -FMM*(I/HPI)*(ZT**FNU)*K(FNU,-Z*ZT)
!
!     ZT=EXP(-FMM*HPI*I) = CMPLX(0.0,-FMM), FMM=3-2*M, M=1,2
!-----------------------------------------------------------------------
  SGN = DSIGN(HPI,-FMM)
!-----------------------------------------------------------------------
!     CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
!     WHEN FNU IS LARGE
!-----------------------------------------------------------------------
  INU = FNU
  INUH = INU/2
  IR = INU - 2*INUH
  ARG = (FNU-(INU-IR))*SGN
  RHPI = 1.0D0/SGN
!     ZNI = RHPI*COS(ARG)
!     ZNR = -RHPI*SIN(ARG)
  CSGNI = RHPI*COS(ARG)
  CSGNR = -RHPI*SIN(ARG)
  if (MOD(INUH,2) == 0) go to 120
!     ZNR = -ZNR
!     ZNI = -ZNI
  CSGNR = -CSGNR
  CSGNI = -CSGNI
  120 CONTINUE
  ZTI = -FMM
  RTOL = 1.0D0/TOL
  ASCLE = UFL*RTOL
  DO 130 I=1,NN
!       STR = CYR(I)*ZNR - CYI(I)*ZNI
!       CYI(I) = CYR(I)*ZNI + CYI(I)*ZNR
!       CYR(I) = STR
!       STR = -ZNI*ZTI
!       ZNI = ZNR*ZTI
!       ZNR = STR
    AA = CYR(I)
    BB = CYI(I)
    ATOL = 1.0D0
    if (MAX(ABS(AA),ABS(BB)) > 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 < 0.0D0) go to 230
  return
  230 CONTINUE
  NZ=0
  IERR=2
  return
  240 CONTINUE
  if ( NW == (-1)) go to 230
  NZ=0
  IERR=5
  return
  260 CONTINUE
  NZ=0
  IERR=4
  return
end



subroutine ZBESI (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR)
!
!! ZBESI computes a sequence of the Bessel functions I(a,z) for ...
!            complex argument z and real nonnegative orders a=b,b+1, ...
!            b+2,... where b>0.  A scaling option is available to ...
!            help avoid overflow.
!
!***LIBRARY   SLATEC
!***CATEGORY  C10B4
!***TYPE      COMPLEX (CBESI-C, ZBESI-C)
!***KEYWORDS  BESSEL FUNCTIONS OF COMPLEX ARGUMENT, I BESSEL FUNCTIONS,
!             MODIFIED BESSEL FUNCTIONS
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!                    ***A DOUBLE PRECISION ROUTINE***
!         On KODE=1, ZBESI computes an N-member sequence of complex
!         Bessel functions CY(L)=I(FNU+L-1,Z) for real nonnegative
!         orders FNU+L-1, L=1,...,N and complex Z in the cut plane
!         -pi<arg(Z)<=pi where Z=ZR+i*ZI.  On KODE=2, CBESI returns
!         the scaled functions
!
!            CY(L) = exp(-abs(X))*I(FNU+L-1,Z), L=1,...,N and X=Re(Z)
!
!         which removes the exponential growth in both the left and
!         right half-planes as Z goes to infinity.
!
!         Input
!           ZR     - DOUBLE PRECISION real part of argument Z
!           ZI     - DOUBLE PRECISION imag part of argument Z
!           FNU    - DOUBLE PRECISION initial order, FNU>=0
!           KODE   - A parameter to indicate the scaling option
!                    KODE=1  returns
!                            CY(L)=I(FNU+L-1,Z), L=1,...,N
!                        =2  returns
!                            CY(L)=exp(-abs(X))*I(FNU+L-1,Z), L=1,...,N
!                            where X=Re(Z)
!           N      - Number of terms in the sequence, N>=1
!
!         Output
!           CYR    - DOUBLE PRECISION real part of result vector
!           CYI    - DOUBLE PRECISION imag part of result vector
!           NZ     - Number of underflows set to zero
!                    NZ=0    Normal return
!                    NZ>0    CY(L)=0, L=N-NZ+1,...,N
!           IERR   - Error flag
!                    IERR=0  Normal return     - COMPUTATION COMPLETED
!                    IERR=1  Input error       - NO COMPUTATION
!                    IERR=2  Overflow          - NO COMPUTATION
!                            (Re(Z) too large on KODE=1)
!                    IERR=3  Precision warning - COMPUTATION COMPLETED
!                            (Result has half precision or less
!                            because abs(Z) or FNU+N-1 is large)
!                    IERR=4  Precision error   - NO COMPUTATION
!                            (Result has no precision because
!                            abs(Z) or FNU+N-1 is too large)
!                    IERR=5  Algorithmic error - NO COMPUTATION
!                            (Termination condition not met)
!
! *Long Description:
!
!         The computation of I(a,z) is carried out by the power series
!         for small abs(z), the asymptotic expansion for large abs(z),
!         the Miller algorithm normalized by the Wronskian and a
!         Neumann series for intermediate magnitudes of z, and the
!         uniform asymptotic expansions for I(a,z) and J(a,z) for
!         large orders a.  Backward recurrence is used to generate
!         sequences or reduce orders when necessary.
!
!         The calculations above are done in the right half plane and
!         continued into the left half plane by the formula
!
!            I(a,z*exp(t)) = exp(t*a)*I(a,z), Re(z)>0
!                        t = i*pi or -i*pi
!
!         For negative orders, the formula
!
!            I(-a,z) = I(a,z) + (2/pi)*sin(pi*a)*K(a,z)
!
!         can be used.  However, for large orders close to integers the
!         the function changes radically.  When a is a large positive
!         integer, the magnitude of I(-a,z)=I(a,z) is a large
!         negative power of ten. But when a is not an integer,
!         K(a,z) dominates in magnitude with a large positive power of
!         ten and the most that the second term can be reduced is by
!         unit roundoff from the coefficient. Thus, wide changes can
!         occur within unit roundoff of a large integer for a. Here,
!         large means a>abs(z).
!
!         In most complex variable computation, one must evaluate ele-
!         mentary functions.  When the magnitude of Z or FNU+N-1 is
!         large, losses of significance by argument reduction occur.
!         Consequently, if either one exceeds U1=SQRT(0.5/UR), then
!         losses exceeding half precision are likely and an error flag
!         IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double
!         precision unit roundoff limited to 18 digits precision.  Also,
!         if either is larger than U2=0.5/UR, then all significance is
!         lost and IERR=4.  In order to use the INT function, arguments
!         must be further restricted not to exceed the largest machine
!         integer, U3=I1MACH(9).  Thus, the magnitude of Z and FNU+N-1
!         is restricted by MIN(U2,U3).  In IEEE arithmetic, U1,U2, and
!         U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision
!         and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision.  This
!         makes U2 limiting in single precision and U3 limiting in
!         double precision.  This means that one can expect to retain,
!         in the worst cases on IEEE machines, no digits in single pre-
!         cision and only 6 digits in double precision.  Similar con-
!         siderations hold for other machines.
!
!         The approximate relative error in the magnitude of a complex
!         Bessel function can be expressed as P*10**S where P=MAX(UNIT
!         ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre-
!         sents the increase in error due to argument reduction in the
!         elementary functions.  Here, S=MAX(1,ABS(LOG10(ABS(Z))),
!         ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF
!         ABS(Z),ABS(EXPONENT OF FNU)) ).  However, the phase angle may
!         have only absolute accuracy.  This is most likely to occur
!         when one component (in magnitude) is larger than the other by
!         several orders of magnitude.  If one component is 10**K larger
!         than the other, then one can expect only MAX(ABS(LOG10(P))-K,
!         0) significant digits; or, stated another way, when K exceeds
!         the exponent of P, no significant digits remain in the smaller
!         component.  However, the phase angle retains absolute accuracy
!         because, in complex arithmetic with precision P, the smaller
!         component will not (as a rule) decrease below P times the
!         magnitude of the larger component.  In these extreme cases,
!         the principal phase angle is on the order of +P, -P, PI/2-P,
!         or -PI/2+P.
!
!***REFERENCES  1. M. Abramowitz and I. A. Stegun, Handbook of Mathe-
!                 matical Functions, National Bureau of Standards
!                 Applied Mathematics Series 55, U. S. Department
!                 of Commerce, Tenth Printing (1972) or later.
!               2. D. E. Amos, Computation of Bessel Functions of
!                 Complex Argument, Report SAND83-0086, Sandia National
!                 Laboratories, Albuquerque, NM, May 1983.
!               3. D. E. Amos, Computation of Bessel Functions of
!                 Complex Argument and Large Order, Report SAND83-0643,
!                 Sandia National Laboratories, Albuquerque, NM, May
!                 1983.
!               4. D. E. Amos, A Subroutine Package for Bessel Functions
!                 of a Complex Argument and Nonnegative Order, Report
!                 SAND85-1018, Sandia National Laboratory, Albuquerque,
!                 NM, May 1985.
!               5. D. E. Amos, A portable package for Bessel functions
!                 of a complex argument and nonnegative order, ACM
!                 Transactions on Mathematical Software, 12 (September
!                 1986), pp. 265-273.
!
!***ROUTINES CALLED  D1MACH, I1MACH, ZABS, ZBINU
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   890801  REVISION DATE from Version 3.2
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!   920128  Category corrected.  (WRB)
!   920811  Prologue revised.  (DWL)
!***END PROLOGUE  ZBESI
!     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)
  EXTERNAL ZABS
  DATA PI /3.14159265358979324D0/
  DATA CONER, CONEI /1.0D0,0.0D0/
!
!***FIRST EXECUTABLE STATEMENT  ZBESI
  IERR = 0
  NZ=0
  if (FNU < 0.0D0) IERR=1
  if (KODE < 1 .OR. KODE > 2) IERR=1
  if (N < 1) IERR=1
  if (IERR /= 0) RETURN
!-----------------------------------------------------------------------
!     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
!     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
!     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
!     EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL    AND
!     EXP(ELIM) > EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
!     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
!     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
!     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
!     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU.
!-----------------------------------------------------------------------
  TOL = MAX(D1MACH(4),1.0D-18)
  K1 = I1MACH(15)
  K2 = I1MACH(16)
  R1M5 = D1MACH(5)
  K = MIN(ABS(K1),ABS(K2))
  ELIM = 2.303D0*(K*R1M5-3.0D0)
  K1 = I1MACH(14) - 1
  AA = R1M5*K1
  DIG = MIN(AA,18.0D0)
  AA = AA*2.303D0
  ALIM = ELIM + MAX(-AA,-41.45D0)
  RL = 1.2D0*DIG + 3.0D0
  FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
!-----------------------------------------------------------------------
!     TEST FOR PROPER RANGE
!-----------------------------------------------------------------------
  AZ = ZABS(ZR,ZI)
  FN = FNU+(N-1)
  AA = 0.5D0/TOL
  BB=I1MACH(9)*0.5D0
  AA = MIN(AA,BB)
  if (AZ > AA) go to 260
  if (FN > AA) go to 260
  AA = SQRT(AA)
  if (AZ > AA) IERR=3
  if (FN > AA) IERR=3
  ZNR = ZR
  ZNI = ZI
  CSGNR = CONER
  CSGNI = CONEI
  if (ZR >= 0.0D0) go to 40
  ZNR = -ZR
  ZNI = -ZI
!-----------------------------------------------------------------------
!     CALCULATE CSGN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
!     WHEN FNU IS LARGE
!-----------------------------------------------------------------------
  INU = FNU
  ARG = (FNU-INU)*PI
  if (ZI < 0.0D0) ARG = -ARG
  CSGNR = COS(ARG)
  CSGNI = SIN(ARG)
  if (MOD(INU,2) == 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 < 0) go to 120
  if (ZR >= 0.0D0) RETURN
!-----------------------------------------------------------------------
!     ANALYTIC CONTINUATION TO THE LEFT HALF PLANE
!-----------------------------------------------------------------------
  NN = N - NZ
  if (NN == 0) RETURN
  RTOL = 1.0D0/TOL
  ASCLE = D1MACH(1)*RTOL*1.0D+3
  DO 50 I=1,NN
!       STR = CYR(I)*CSGNR - CYI(I)*CSGNI
!       CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR
!       CYR(I) = STR
    AA = CYR(I)
    BB = CYI(I)
    ATOL = 1.0D0
    if (MAX(ABS(AA),ABS(BB)) > 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 == (-2)) go to 130
  NZ = 0
  IERR=2
  return
  130 CONTINUE
  NZ=0
  IERR=5
  return
  260 CONTINUE
  NZ=0
  IERR=4
  return
end



subroutine ZBESJ (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR)
!
!! ZBESJ computes a sequence of the Bessel functions J(a,z) for ...
!            complex argument z and real nonnegative orders a=b,b+1, ...
!            b+2,... where b>0.  A scaling option is available to ...
!            help avoid overflow.
!
!***LIBRARY   SLATEC
!***CATEGORY  C10A4
!***TYPE      COMPLEX (CBESJ-C, ZBESJ-C)
!***KEYWORDS  BESSEL FUNCTIONS OF COMPLEX ARGUMENT,
!             BESSEL FUNCTIONS OF THE FIRST KIND, J BESSEL FUNCTIONS
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!                      ***A DOUBLE PRECISION ROUTINE***
!         On KODE=1, ZBESJ computes an N member sequence of complex
!         Bessel functions CY(L)=J(FNU+L-1,Z) for real nonnegative
!         orders FNU+L-1, L=1,...,N and complex Z in the cut plane
!         -pi<arg(Z)<=pi where Z=ZR+i*ZI.  On KODE=2, CBESJ returns
!         the scaled functions
!
!            CY(L) = exp(-abs(Y))*J(FNU+L-1,Z),  L=1,...,N and Y=Im(Z)
!
!         which remove the exponential growth in both the upper and
!         lower half planes as Z goes to infinity.  Definitions and
!         notation are found in the NBS Handbook of Mathematical
!         Functions (Ref. 1).
!
!         Input
!           ZR     - DOUBLE PRECISION real part of argument Z
!           ZI     - DOUBLE PRECISION imag part of argument Z
!           FNU    - DOUBLE PRECISION initial order, FNU>=0
!           KODE   - A parameter to indicate the scaling option
!                    KODE=1  returns
!                            CY(L)=J(FNU+L-1,Z), L=1,...,N
!                        =2  returns
!                            CY(L)=J(FNU+L-1,Z)*exp(-abs(Y)), L=1,...,N
!                            where Y=Im(Z)
!           N      - Number of terms in the sequence, N>=1
!
!         Output
!           CYR    - DOUBLE PRECISION real part of result vector
!           CYI    - DOUBLE PRECISION imag part of result vector
!           NZ     - Number of underflows set to zero
!                    NZ=0    Normal return
!                    NZ>0    CY(L)=0, L=N-NZ+1,...,N
!           IERR   - Error flag
!                    IERR=0  Normal return     - COMPUTATION COMPLETED
!                    IERR=1  Input error       - NO COMPUTATION
!                    IERR=2  Overflow          - NO COMPUTATION
!                            (Im(Z) too large on KODE=1)
!                    IERR=3  Precision warning - COMPUTATION COMPLETED
!                            (Result has half precision or less
!                            because abs(Z) or FNU+N-1 is large)
!                    IERR=4  Precision error   - NO COMPUTATION
!                            (Result has no precision because
!                            abs(Z) or FNU+N-1 is too large)
!                    IERR=5  Algorithmic error - NO COMPUTATION
!                            (Termination condition not met)
!
! *Long Description:
!
!         The computation is carried out by the formulae
!
!            J(a,z) = exp( a*pi*i/2)*I(a,-i*z),  Im(z)>=0
!
!            J(a,z) = exp(-a*pi*i/2)*I(a, i*z),  Im(z)<0
!
!         where the I Bessel function is computed as described in the
!         prologue to CBESI.
!
!         For negative orders, the formula
!
!            J(-a,z) = J(a,z)*cos(a*pi) - Y(a,z)*sin(a*pi)
!
!         can be used.  However, for large orders close to integers, the
!         the function changes radically.  When a is a large positive
!         integer, the magnitude of J(-a,z)=J(a,z)*cos(a*pi) is a
!         large negative power of ten.  But when a is not an integer,
!         Y(a,z) dominates in magnitude with a large positive power of
!         ten and the most that the second term can be reduced is by
!         unit roundoff from the coefficient.  Thus, wide changes can
!         occur within unit roundoff of a large integer for a.  Here,
!         large means a>abs(z).
!
!         In most complex variable computation, one must evaluate ele-
!         mentary functions.  When the magnitude of Z or FNU+N-1 is
!         large, losses of significance by argument reduction occur.
!         Consequently, if either one exceeds U1=SQRT(0.5/UR), then
!         losses exceeding half precision are likely and an error flag
!         IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double
!         precision unit roundoff limited to 18 digits precision.  Also,
!         if either is larger than U2=0.5/UR, then all significance is
!         lost and IERR=4.  In order to use the INT function, arguments
!         must be further restricted not to exceed the largest machine
!         integer, U3=I1MACH(9).  Thus, the magnitude of Z and FNU+N-1
!         is restricted by MIN(U2,U3).  In IEEE arithmetic, U1,U2, and
!         U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision
!         and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision.  This
!         makes U2 limiting in single precision and U3 limiting in
!         double precision.  This means that one can expect to retain,
!         in the worst cases on IEEE machines, no digits in single pre-
!         cision and only 6 digits in double precision.  Similar con-
!         siderations hold for other machines.
!
!         The approximate relative error in the magnitude of a complex
!         Bessel function can be expressed as P*10**S where P=MAX(UNIT
!         ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre-
!         sents the increase in error due to argument reduction in the
!         elementary functions.  Here, S=MAX(1,ABS(LOG10(ABS(Z))),
!         ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF
!         ABS(Z),ABS(EXPONENT OF FNU)) ).  However, the phase angle may
!         have only absolute accuracy.  This is most likely to occur
!         when one component (in magnitude) is larger than the other by
!         several orders of magnitude.  If one component is 10**K larger
!         than the other, then one can expect only MAX(ABS(LOG10(P))-K,
!         0) significant digits; or, stated another way, when K exceeds
!         the exponent of P, no significant digits remain in the smaller
!         component.  However, the phase angle retains absolute accuracy
!         because, in complex arithmetic with precision P, the smaller
!         component will not (as a rule) decrease below P times the
!         magnitude of the larger component.  In these extreme cases,
!         the principal phase angle is on the order of +P, -P, PI/2-P,
!         or -PI/2+P.
!
!***REFERENCES  1. M. Abramowitz and I. A. Stegun, Handbook of Mathe-
!                 matical Functions, National Bureau of Standards
!                 Applied Mathematics Series 55, U. S. Department
!                 of Commerce, Tenth Printing (1972) or later.
!               2. D. E. Amos, Computation of Bessel Functions of
!                 Complex Argument, Report SAND83-0086, Sandia National
!                 Laboratories, Albuquerque, NM, May 1983.
!               3. D. E. Amos, Computation of Bessel Functions of
!                 Complex Argument and Large Order, Report SAND83-0643,
!                 Sandia National Laboratories, Albuquerque, NM, May
!                 1983.
!               4. D. E. Amos, A Subroutine Package for Bessel Functions
!                 of a Complex Argument and Nonnegative Order, Report
!                 SAND85-1018, Sandia National Laboratory, Albuquerque,
!                 NM, May 1985.
!               5. D. E. Amos, A portable package for Bessel functions
!                 of a complex argument and nonnegative order, ACM
!                 Transactions on Mathematical Software, 12 (September
!                 1986), pp. 265-273.
!
!***ROUTINES CALLED  D1MACH, I1MACH, ZABS, ZBINU
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   890801  REVISION DATE from Version 3.2
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!   920128  Category corrected.  (WRB)
!   920811  Prologue revised.  (DWL)
!***END PROLOGUE  ZBESJ
!
!     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)
  EXTERNAL ZABS
  DATA HPI /1.57079632679489662D0/
!
!***FIRST EXECUTABLE STATEMENT  ZBESJ
  IERR = 0
  NZ=0
  if (FNU < 0.0D0) IERR=1
  if (KODE < 1 .OR. KODE > 2) IERR=1
  if (N < 1) IERR=1
  if (IERR /= 0) RETURN
!-----------------------------------------------------------------------
!     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
!     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
!     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
!     EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL    AND
!     EXP(ELIM) > EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
!     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
!     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
!     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
!     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU.
!-----------------------------------------------------------------------
  TOL = MAX(D1MACH(4),1.0D-18)
  K1 = I1MACH(15)
  K2 = I1MACH(16)
  R1M5 = D1MACH(5)
  K = MIN(ABS(K1),ABS(K2))
  ELIM = 2.303D0*(K*R1M5-3.0D0)
  K1 = I1MACH(14) - 1
  AA = R1M5*K1
  DIG = MIN(AA,18.0D0)
  AA = AA*2.303D0
  ALIM = ELIM + MAX(-AA,-41.45D0)
  RL = 1.2D0*DIG + 3.0D0
  FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
!-----------------------------------------------------------------------
!     TEST FOR PROPER RANGE
!-----------------------------------------------------------------------
  AZ = ZABS(ZR,ZI)
  FN = FNU+(N-1)
  AA = 0.5D0/TOL
  BB = I1MACH(9)*0.5D0
  AA = MIN(AA,BB)
  if (AZ > AA) go to 260
  if (FN > AA) go to 260
  AA = SQRT(AA)
  if (AZ > AA) IERR=3
  if (FN > AA) IERR=3
!-----------------------------------------------------------------------
!     CALCULATE CSGN=EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
!     WHEN FNU IS LARGE
!-----------------------------------------------------------------------
  CII = 1.0D0
  INU = FNU
  INUH = INU/2
  IR = INU - 2*INUH
  ARG = (FNU-(INU-IR))*HPI
  CSGNR = COS(ARG)
  CSGNI = SIN(ARG)
  if (MOD(INUH,2) == 0) go to 40
  CSGNR = -CSGNR
  CSGNI = -CSGNI
   40 CONTINUE
!-----------------------------------------------------------------------
!     ZN IS IN THE RIGHT HALF PLANE
!-----------------------------------------------------------------------
  ZNR = ZI
  ZNI = -ZR
  if (ZI >= 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 < 0) go to 130
  NL = N - NZ
  if (NL == 0) RETURN
  RTOL = 1.0D0/TOL
  ASCLE = D1MACH(1)*RTOL*1.0D+3
  DO 60 I=1,NL
!       STR = CYR(I)*CSGNR - CYI(I)*CSGNI
!       CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR
!       CYR(I) = STR
    AA = CYR(I)
    BB = CYI(I)
    ATOL = 1.0D0
    if (MAX(ABS(AA),ABS(BB)) > 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 == (-2)) go to 140
  NZ = 0
  IERR = 2
  return
  140 CONTINUE
  NZ=0
  IERR=5
  return
  260 CONTINUE
  NZ=0
  IERR=4
  return
end



subroutine ZBESK (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR)
!
!! ZBESK computes a sequence of the Bessel functions K(a,z) for ...
!            complex argument z and real nonnegative orders a=b,b+1, ...
!            b+2,... where b>0.  A scaling option is available to ...
!            help avoid overflow.
!
!***LIBRARY   SLATEC
!***CATEGORY  C10B4
!***TYPE      COMPLEX (CBESK-C, ZBESK-C)
!***KEYWORDS  BESSEL FUNCTIONS OF COMPLEX ARGUMENT, K BESSEL FUNCTIONS,
!             MODIFIED BESSEL FUNCTIONS
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!                      ***A DOUBLE PRECISION ROUTINE***
!         On KODE=1, ZBESK computes an N member sequence of complex
!         Bessel functions CY(L)=K(FNU+L-1,Z) for real nonnegative
!         orders FNU+L-1, L=1,...,N and complex Z /= 0 in the cut
!         plane -pi<arg(Z)<=pi where Z=ZR+i*ZI.  On KODE=2, CBESJ
!         returns the scaled functions
!
!            CY(L) = exp(Z)*K(FNU+L-1,Z),  L=1,...,N
!
!         which remove the exponential growth in both the left and
!         right half planes as Z goes to infinity.  Definitions and
!         notation are found in the NBS Handbook of Mathematical
!         Functions (Ref. 1).
!
!         Input
!           ZR     - DOUBLE PRECISION real part of nonzero argument Z
!           ZI     - DOUBLE PRECISION imag part of nonzero argument Z
!           FNU    - DOUBLE PRECISION initial order, FNU>=0
!           KODE   - A parameter to indicate the scaling option
!                    KODE=1  returns
!                            CY(L)=K(FNU+L-1,Z), L=1,...,N
!                        =2  returns
!                            CY(L)=K(FNU+L-1,Z)*EXP(Z), L=1,...,N
!           N      - Number of terms in the sequence, N>=1
!
!         Output
!           CYR    - DOUBLE PRECISION real part of result vector
!           CYI    - DOUBLE PRECISION imag part of result vector
!           NZ     - Number of underflows set to zero
!                    NZ=0    Normal return
!                    NZ>0    CY(L)=0 for NZ values of L (if Re(Z)>0
!                            then CY(L)=0 for L=1,...,NZ; in the
!                            complementary half plane the underflows
!                            may not be in an uninterrupted sequence)
!           IERR   - Error flag
!                    IERR=0  Normal return     - COMPUTATION COMPLETED
!                    IERR=1  Input error       - NO COMPUTATION
!                    IERR=2  Overflow          - NO COMPUTATION
!                            (abs(Z) too small and/or FNU+N-1
!                            too large)
!                    IERR=3  Precision warning - COMPUTATION COMPLETED
!                            (Result has half precision or less
!                            because abs(Z) or FNU+N-1 is large)
!                    IERR=4  Precision error   - NO COMPUTATION
!                            (Result has no precision because
!                            abs(Z) or FNU+N-1 is too large)
!                    IERR=5  Algorithmic error - NO COMPUTATION
!                            (Termination condition not met)
!
! *Long Description:
!
!         Equations of the reference are implemented to compute K(a,z)
!         for small orders a and a+1 in the right half plane Re(z)>=0.
!         Forward recurrence generates higher orders.  The formula
!
!            K(a,z*exp((t)) = exp(-t)*K(a,z) - t*I(a,z),  Re(z)>0
!                         t = i*pi or -i*pi
!
!         continues K to the left half plane.
!
!         For large orders, K(a,z) is computed by means of its uniform
!         asymptotic expansion.
!
!         For negative orders, the formula
!
!            K(-a,z) = K(a,z)
!
!         can be used.
!
!         CBESK assumes that a significant digit sinh function is
!         available.
!
!         In most complex variable computation, one must evaluate ele-
!         mentary functions.  When the magnitude of Z or FNU+N-1 is
!         large, losses of significance by argument reduction occur.
!         Consequently, if either one exceeds U1=SQRT(0.5/UR), then
!         losses exceeding half precision are likely and an error flag
!         IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double
!         precision unit roundoff limited to 18 digits precision.  Also,
!         if either is larger than U2=0.5/UR, then all significance is
!         lost and IERR=4.  In order to use the INT function, arguments
!         must be further restricted not to exceed the largest machine
!         integer, U3=I1MACH(9).  Thus, the magnitude of Z and FNU+N-1
!         is restricted by MIN(U2,U3).  In IEEE arithmetic, U1,U2, and
!         U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision
!         and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision.  This
!         makes U2 limiting in single precision and U3 limiting in
!         double precision.  This means that one can expect to retain,
!         in the worst cases on IEEE machines, no digits in single pre-
!         cision and only 6 digits in double precision.  Similar con-
!         siderations hold for other machines.
!
!         The approximate relative error in the magnitude of a complex
!         Bessel function can be expressed as P*10**S where P=MAX(UNIT
!         ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre-
!         sents the increase in error due to argument reduction in the
!         elementary functions.  Here, S=MAX(1,ABS(LOG10(ABS(Z))),
!         ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF
!         ABS(Z),ABS(EXPONENT OF FNU)) ).  However, the phase angle may
!         have only absolute accuracy.  This is most likely to occur
!         when one component (in magnitude) is larger than the other by
!         several orders of magnitude.  If one component is 10**K larger
!         than the other, then one can expect only MAX(ABS(LOG10(P))-K,
!         0) significant digits; or, stated another way, when K exceeds
!         the exponent of P, no significant digits remain in the smaller
!         component.  However, the phase angle retains absolute accuracy
!         because, in complex arithmetic with precision P, the smaller
!         component will not (as a rule) decrease below P times the
!         magnitude of the larger component.  In these extreme cases,
!         the principal phase angle is on the order of +P, -P, PI/2-P,
!         or -PI/2+P.
!
!***REFERENCES  1. M. Abramowitz and I. A. Stegun, Handbook of Mathe-
!                 matical Functions, National Bureau of Standards
!                 Applied Mathematics Series 55, U. S. Department
!                 of Commerce, Tenth Printing (1972) or later.
!               2. D. E. Amos, Computation of Bessel Functions of
!                 Complex Argument, Report SAND83-0086, Sandia National
!                 Laboratories, Albuquerque, NM, May 1983.
!               3. D. E. Amos, Computation of Bessel Functions of
!                 Complex Argument and Large Order, Report SAND83-0643,
!                 Sandia National Laboratories, Albuquerque, NM, May
!                 1983.
!               4. D. E. Amos, A Subroutine Package for Bessel Functions
!                 of a Complex Argument and Nonnegative Order, Report
!                 SAND85-1018, Sandia National Laboratory, Albuquerque,
!                 NM, May 1985.
!               5. D. E. Amos, A portable package for Bessel functions
!                 of a complex argument and nonnegative order, ACM
!                 Transactions on Mathematical Software, 12 (September
!                 1986), pp. 265-273.
!
!***ROUTINES CALLED  D1MACH, I1MACH, ZABS, ZACON, ZBKNU, ZBUNK, ZUOIK
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   890801  REVISION DATE from Version 3.2
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!   920128  Category corrected.  (WRB)
!   920811  Prologue revised.  (DWL)
!***END PROLOGUE  ZBESK
!
!     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)
  EXTERNAL ZABS
!***FIRST EXECUTABLE STATEMENT  ZBESK
  IERR = 0
  NZ=0
  if (ZI == 0.0E0 .AND. ZR == 0.0E0) IERR=1
  if (FNU < 0.0D0) IERR=1
  if (KODE < 1 .OR. KODE > 2) IERR=1
  if (N < 1) IERR=1
  if (IERR /= 0) RETURN
  NN = N
!-----------------------------------------------------------------------
!     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
!     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
!     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
!     EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL    AND
!     EXP(ELIM) > EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
!     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
!     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
!     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
!     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU
!-----------------------------------------------------------------------
  TOL = MAX(D1MACH(4),1.0D-18)
  K1 = I1MACH(15)
  K2 = I1MACH(16)
  R1M5 = D1MACH(5)
  K = MIN(ABS(K1),ABS(K2))
  ELIM = 2.303D0*(K*R1M5-3.0D0)
  K1 = I1MACH(14) - 1
  AA = R1M5*K1
  DIG = MIN(AA,18.0D0)
  AA = AA*2.303D0
  ALIM = ELIM + MAX(-AA,-41.45D0)
  FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
  RL = 1.2D0*DIG + 3.0D0
!-----------------------------------------------------------------------
!     TEST FOR PROPER RANGE
!-----------------------------------------------------------------------
  AZ = ZABS(ZR,ZI)
  FN = FNU + (NN-1)
  AA = 0.5D0/TOL
  BB = I1MACH(9)*0.5D0
  AA = MIN(AA,BB)
  if (AZ > AA) go to 260
  if (FN > AA) go to 260
  AA = SQRT(AA)
  if (AZ > AA) IERR=3
  if (FN > AA) IERR=3
!-----------------------------------------------------------------------
!     OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE
!-----------------------------------------------------------------------
!     UFL = EXP(-ELIM)
  UFL = D1MACH(1)*1.0D+3
  if (AZ < UFL) go to 180
  if (FNU > FNUL) go to 80
  if (FN <= 1.0D0) go to 60
  if (FN > 2.0D0) go to 50
  if (AZ > TOL) go to 60
  ARG = 0.5D0*AZ
  ALN = -FN*LOG(ARG)
  if (ALN > 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 < 0) go to 180
  NZ = NZ + NUF
  NN = NN - NUF
!-----------------------------------------------------------------------
!     HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK
!     if NUF=NN, THEN CY(I)=CZERO FOR ALL I
!-----------------------------------------------------------------------
  if (NN == 0) go to 100
   60 CONTINUE
  if (ZR < 0.0D0) go to 70
!-----------------------------------------------------------------------
!     RIGHT HALF PLANE COMPUTATION, REAL(Z) >= 0.
!-----------------------------------------------------------------------
  call ZBKNU(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM)
  if (NW < 0) go to 200
  NZ=NW
  return
!-----------------------------------------------------------------------
!     LEFT HALF PLANE COMPUTATION
!     PI/2 < ARG(Z) <= PI AND -PI < ARG(Z) < -PI/2.
!-----------------------------------------------------------------------
   70 CONTINUE
  if (NZ /= 0) go to 180
  MR = 1
  if (ZI < 0.0D0) MR = -1
  call ZACON(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL, &
   TOL, ELIM, ALIM)
  if (NW < 0) go to 200
  NZ=NW
  return
!-----------------------------------------------------------------------
!     UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU > FNUL
!-----------------------------------------------------------------------
   80 CONTINUE
  MR = 0
  if (ZR >= 0.0D0) go to 90
  MR = 1
  if (ZI < 0.0D0) MR = -1
   90 CONTINUE
  call ZBUNK(ZR, ZI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM, &
   ALIM)
  if (NW < 0) go to 200
  NZ = NZ + NW
  return
  100 CONTINUE
  if (ZR < 0.0D0) go to 180
  return
  180 CONTINUE
  NZ = 0
  IERR=2
  return
  200 CONTINUE
  if ( NW == (-1)) go to 180
  NZ=0
  IERR=5
  return
  260 CONTINUE
  NZ=0
  IERR=4
  return
end



subroutine ZBESY (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, CWRKR, &
     CWRKI, IERR)
!
!! ZBESY computes a sequence of the Bessel functions Y(a,z) for ...
!            complex argument z and real nonnegative orders a=b,b+1, ...
!            b+2,... where b>0.  A scaling option is available to ...
!            help avoid overflow.
!
!***LIBRARY   SLATEC
!***CATEGORY  C10A4
!***TYPE      COMPLEX (CBESY-C, ZBESY-C)
!***KEYWORDS  BESSEL FUNCTIONS OF COMPLEX ARGUMENT,
!             BESSEL FUNCTIONS OF SECOND KIND, WEBER'S FUNCTION,
!             Y BESSEL FUNCTIONS
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!                      ***A DOUBLE PRECISION ROUTINE***
!         On KODE=1, ZBESY computes an N member sequence of complex
!         Bessel functions CY(L)=Y(FNU+L-1,Z) for real nonnegative
!         orders FNU+L-1, L=1,...,N and complex Z in the cut plane
!         -pi<arg(Z)<=pi where Z=ZR+i*ZI.  On KODE=2, CBESY returns
!         the scaled functions
!
!            CY(L) = exp(-abs(Y))*Y(FNU+L-1,Z),  L=1,...,N, Y=Im(Z)
!
!         which remove the exponential growth in both the upper and
!         lower half planes as Z goes to infinity.  Definitions and
!         notation are found in the NBS Handbook of Mathematical
!         Functions (Ref. 1).
!
!         Input
!           ZR     - DOUBLE PRECISION real part of nonzero argument Z
!           ZI     - DOUBLE PRECISION imag part of nonzero argument Z
!           FNU    - DOUBLE PRECISION initial order, FNU>=0
!           KODE   - A parameter to indicate the scaling option
!                    KODE=1  returns
!                            CY(L)=Y(FNU+L-1,Z), L=1,...,N
!                        =2  returns
!                            CY(L)=Y(FNU+L-1,Z)*exp(-abs(Y)), L=1,...,N
!                            where Y=Im(Z)
!           N      - Number of terms in the sequence, N>=1
!           CWRKR  - DOUBLE PRECISION work vector of dimension N
!           CWRKI  - DOUBLE PRECISION work vector of dimension N
!
!         Output
!           CYR    - DOUBLE PRECISION real part of result vector
!           CYI    - DOUBLE PRECISION imag part of result vector
!           NZ     - Number of underflows set to zero
!                    NZ=0    Normal return
!                    NZ>0    CY(L)=0 for NZ values of L, usually on
!                            KODE=2 (the underflows may not be in an
!                            uninterrupted sequence)
!           IERR   - Error flag
!                    IERR=0  Normal return     - COMPUTATION COMPLETED
!                    IERR=1  Input error       - NO COMPUTATION
!                    IERR=2  Overflow          - NO COMPUTATION
!                            (abs(Z) too small and/or FNU+N-1
!                            too large)
!                    IERR=3  Precision warning - COMPUTATION COMPLETED
!                            (Result has half precision or less
!                            because abs(Z) or FNU+N-1 is large)
!                    IERR=4  Precision error   - NO COMPUTATION
!                            (Result has no precision because
!                            abs(Z) or FNU+N-1 is too large)
!                    IERR=5  Algorithmic error - NO COMPUTATION
!                            (Termination condition not met)
!
! *Long Description:
!
!         The computation is carried out by the formula
!
!            Y(a,z) = (H(1,a,z) - H(2,a,z))/(2*i)
!
!         where the Hankel functions are computed as described in CBESH.
!
!         For negative orders, the formula
!
!            Y(-a,z) = Y(a,z)*cos(a*pi) + J(a,z)*sin(a*pi)
!
!         can be used.  However, for large orders close to half odd
!         integers the function changes radically.  When a is a large
!         positive half odd integer, the magnitude of Y(-a,z)=J(a,z)*
!         sin(a*pi) is a large negative power of ten.  But when a is
!         not a half odd integer, Y(a,z) dominates in magnitude with a
!         large positive power of ten and the most that the second term
!         can be reduced is by unit roundoff from the coefficient.
!         Thus,  wide changes can occur within unit roundoff of a large
!         half odd integer.  Here, large means a>abs(z).
!
!         In most complex variable computation, one must evaluate ele-
!         mentary functions.  When the magnitude of Z or FNU+N-1 is
!         large, losses of significance by argument reduction occur.
!         Consequently, if either one exceeds U1=SQRT(0.5/UR), then
!         losses exceeding half precision are likely and an error flag
!         IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is double
!         precision unit roundoff limited to 18 digits precision.  Also,
!         if either is larger than U2=0.5/UR, then all significance is
!         lost and IERR=4.  In order to use the INT function, arguments
!         must be further restricted not to exceed the largest machine
!         integer, U3=I1MACH(9).  Thus, the magnitude of Z and FNU+N-1
!         is restricted by MIN(U2,U3).  In IEEE arithmetic, U1,U2, and
!         U3 approximate 2.0E+3, 4.2E+6, 2.1E+9 in single precision
!         and 4.7E+7, 2.3E+15 and 2.1E+9 in double precision.  This
!         makes U2 limiting in single precision and U3 limiting in
!         double precision.  This means that one can expect to retain,
!         in the worst cases on IEEE machines, no digits in single pre-
!         cision and only 6 digits in double precision.  Similar con-
!         siderations hold for other machines.
!
!         The approximate relative error in the magnitude of a complex
!         Bessel function can be expressed as P*10**S where P=MAX(UNIT
!         ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre-
!         sents the increase in error due to argument reduction in the
!         elementary functions.  Here, S=MAX(1,ABS(LOG10(ABS(Z))),
!         ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF
!         ABS(Z),ABS(EXPONENT OF FNU)) ).  However, the phase angle may
!         have only absolute accuracy.  This is most likely to occur
!         when one component (in magnitude) is larger than the other by
!         several orders of magnitude.  If one component is 10**K larger
!         than the other, then one can expect only MAX(ABS(LOG10(P))-K,
!         0) significant digits; or, stated another way, when K exceeds
!         the exponent of P, no significant digits remain in the smaller
!         component.  However, the phase angle retains absolute accuracy
!         because, in complex arithmetic with precision P, the smaller
!         component will not (as a rule) decrease below P times the
!         magnitude of the larger component.  In these extreme cases,
!         the principal phase angle is on the order of +P, -P, PI/2-P,
!         or -PI/2+P.
!
!***REFERENCES  1. M. Abramowitz and I. A. Stegun, Handbook of Mathe-
!                 matical Functions, National Bureau of Standards
!                 Applied Mathematics Series 55, U. S. Department
!                 of Commerce, Tenth Printing (1972) or later.
!               2. D. E. Amos, Computation of Bessel Functions of
!                 Complex Argument, Report SAND83-0086, Sandia National
!                 Laboratories, Albuquerque, NM, May 1983.
!               3. D. E. Amos, Computation of Bessel Functions of
!                 Complex Argument and Large Order, Report SAND83-0643,
!                 Sandia National Laboratories, Albuquerque, NM, May
!                 1983.
!               4. D. E. Amos, A Subroutine Package for Bessel Functions
!                 of a Complex Argument and Nonnegative Order, Report
!                 SAND85-1018, Sandia National Laboratory, Albuquerque,
!                 NM, May 1985.
!               5. D. E. Amos, A portable package for Bessel functions
!                 of a complex argument and nonnegative order, ACM
!                 Transactions on Mathematical Software, 12 (September
!                 1986), pp. 265-273.
!
!***ROUTINES CALLED  D1MACH, I1MACH, ZBESH
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   890801  REVISION DATE from Version 3.2
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!   920128  Category corrected.  (WRB)
!   920811  Prologue revised.  (DWL)
!***END PROLOGUE  ZBESY
!
!     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, &
   D1MACH, ASCLE, RTOL, ATOL, AA, BB, TOL, R1M5
  INTEGER I, IERR, K, KODE, K1, K2, N, NZ, NZ1, NZ2, I1MACH
  DIMENSION CYR(N), CYI(N), CWRKR(N), CWRKI(N)
!***FIRST EXECUTABLE STATEMENT  ZBESY
  IERR = 0
  NZ=0
  if (ZR == 0.0D0 .AND. ZI == 0.0D0) IERR=1
  if (FNU < 0.0D0) IERR=1
  if (KODE < 1 .OR. KODE > 2) IERR=1
  if (N < 1) IERR=1
  if (IERR /= 0) RETURN
  HCII = 0.5D0
  call ZBESH(ZR, ZI, FNU, KODE, 1, N, CYR, CYI, NZ1, IERR)
  if (IERR /= 0.AND.IERR /= 3) go to 170
  call ZBESH(ZR, ZI, FNU, KODE, 2, N, CWRKR, CWRKI, NZ2, IERR)
  if (IERR /= 0.AND.IERR /= 3) go to 170
  NZ = MIN(NZ1,NZ2)
  if (KODE == 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 = MAX(D1MACH(4),1.0D-18)
  K1 = I1MACH(15)
  K2 = I1MACH(16)
  K = MIN(ABS(K1),ABS(K2))
  R1M5 = D1MACH(5)
!-----------------------------------------------------------------------
!     ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT
!-----------------------------------------------------------------------
  ELIM = 2.303D0*(K*R1M5-3.0D0)
  EXR = COS(ZR)
  EXI = SIN(ZR)
  EY = 0.0D0
  TAY = ABS(ZI+ZI)
  if (TAY < ELIM) EY = EXP(-TAY)
  if (ZI < 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
!       STR = C1R*CYR(I) - C1I*CYI(I)
!       STI = C1R*CYI(I) + C1I*CYR(I)
!       STR = -STR + C2R*CWRKR(I) - C2I*CWRKI(I)
!       STI = -STI + C2R*CWRKI(I) + C2I*CWRKR(I)
!       CYR(I) = -STI*HCII
!       CYI(I) = STR*HCII
    AA = CWRKR(I)
    BB = CWRKI(I)
    ATOL = 1.0D0
    if (MAX(ABS(AA),ABS(BB)) > 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 (MAX(ABS(AA),ABS(BB)) > 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 == 0.0D0 .AND. STI == 0.0D0 .AND. EY == 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



subroutine ZBINU (ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, &
     TOL, ELIM, ALIM)
!
!! ZBINU is subsidiary to ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK and ZBIRY.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CBINU-A, ZBINU-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     ZBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE
!
!***SEE ALSO  ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBIRY
!***ROUTINES CALLED  ZABS, ZASYI, ZBUNI, ZMLRI, ZSERI, ZUOIK, ZWRSK
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!***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)
  EXTERNAL ZABS
  DATA ZEROR,ZEROI / 0.0D0, 0.0D0 /
!***FIRST EXECUTABLE STATEMENT  ZBINU
  NZ = 0
  AZ = ZABS(ZR,ZI)
  NN = N
  DFNU = FNU + (N-1)
  if (AZ <= 2.0D0) go to 10
  if (AZ*AZ*0.25D0 > DFNU+1.0D0) go to 20
   10 CONTINUE
!-----------------------------------------------------------------------
!     POWER SERIES
!-----------------------------------------------------------------------
  call ZSERI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM)
  INW = ABS(NW)
  NZ = NZ + INW
  NN = NN - INW
  if (NN == 0) RETURN
  if (NW >= 0) go to 120
  DFNU = FNU + (NN-1)
   20 CONTINUE
  if (AZ < RL) go to 40
  if (DFNU <= 1.0D0) go to 30
  if (AZ+AZ < DFNU*DFNU) go to 50
!-----------------------------------------------------------------------
!     ASYMPTOTIC EXPANSION FOR LARGE Z
!-----------------------------------------------------------------------
   30 CONTINUE
  call ZASYI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, RL, TOL, ELIM, &
   ALIM)
  if (NW < 0) go to 130
  go to 120
   40 CONTINUE
  if (DFNU <= 1.0D0) go to 70
   50 CONTINUE
!-----------------------------------------------------------------------
!     OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM
!-----------------------------------------------------------------------
  call ZUOIK(ZR, ZI, FNU, KODE, 1, NN, CYR, CYI, NW, TOL, ELIM, &
   ALIM)
  if (NW < 0) go to 130
  NZ = NZ + NW
  NN = NN - NW
  if (NN == 0) RETURN
  DFNU = FNU+(NN-1)
  if (DFNU > FNUL) go to 110
  if (AZ > FNUL) go to 110
   60 CONTINUE
  if (AZ > RL) go to 80
   70 CONTINUE
!-----------------------------------------------------------------------
!     MILLER ALGORITHM NORMALIZED BY THE SERIES
!-----------------------------------------------------------------------
  call ZMLRI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL)
  if ( NW < 0) go to 130
  go to 120
   80 CONTINUE
!-----------------------------------------------------------------------
!     MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
!     OVERFLOW TEST ON K FUNCTIONS USED IN WRONSKIAN
!-----------------------------------------------------------------------
  call ZUOIK(ZR, ZI, FNU, KODE, 2, 2, CWR, CWI, NW, TOL, ELIM, &
   ALIM)
  if (NW >= 0) go to 100
  NZ = NN
  DO 90 I=1,NN
    CYR(I) = ZEROR
    CYI(I) = ZEROI
   90 CONTINUE
  return
  100 CONTINUE
  if (NW > 0) go to 130
  call ZWRSK(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, CWR, CWI, TOL, &
   ELIM, ALIM)
  if (NW < 0) go to 130
  go to 120
  110 CONTINUE
!-----------------------------------------------------------------------
!     INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD
!-----------------------------------------------------------------------
  NUI = FNUL-DFNU + 1
  NUI = MAX(NUI,0)
  call ZBUNI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, NUI, NLAST, FNUL, &
   TOL, ELIM, ALIM)
  if (NW < 0) go to 130
  NZ = NZ + NW
  if (NLAST == 0) go to 120
  NN = NLAST
  go to 60
  120 CONTINUE
  return
  130 CONTINUE
  NZ = -1
  if ( NW == (-2)) NZ=-2
  return
end



subroutine ZBIRY (ZR, ZI, ID, KODE, BIR, BII, IERR)
!
!! ZBIRY computes the Airy function Bi(z) or its derivative dBi/dz ...
!            for complex argument z.  A scaling option is available ...
!            to help avoid overflow.
!
!***LIBRARY   SLATEC
!***CATEGORY  C10D
!***TYPE      COMPLEX (CBIRY-C, ZBIRY-C)
!***KEYWORDS  AIRY FUNCTION, BESSEL FUNCTION OF ORDER ONE THIRD,
!             BESSEL FUNCTION OF ORDER TWO THIRDS
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!                      ***A DOUBLE PRECISION ROUTINE***
!         On KODE=1, ZBIRY computes the complex Airy function Bi(z)
!         or its derivative dBi/dz on ID=0 or ID=1 respectively.
!         On KODE=2, a scaling option exp(abs(Re(zeta)))*Bi(z) or
!         exp(abs(Re(zeta)))*dBi/dz is provided to remove the
!         exponential behavior in both the left and right half planes
!         where zeta=(2/3)*z**(3/2).
!
!         The Airy functions Bi(z) and dBi/dz are analytic in the
!         whole z-plane, and the scaling option does not destroy this
!         property.
!
!         Input
!           ZR     - DOUBLE PRECISION real part of argument Z
!           ZI     - DOUBLE PRECISION imag part of argument Z
!           ID     - Order of derivative, ID=0 or ID=1
!           KODE   - A parameter to indicate the scaling option
!                    KODE=1  returns
!                            BI=Bi(z)  on ID=0
!                            BI=dBi/dz on ID=1
!                            at z=Z
!                        =2  returns
!                            BI=exp(abs(Re(zeta)))*Bi(z)  on ID=0
!                            BI=exp(abs(Re(zeta)))*dBi/dz on ID=1
!                            at z=Z where zeta=(2/3)*z**(3/2)
!
!         Output
!           BIR    - DOUBLE PRECISION real part of result
!           BII    - DOUBLE PRECISION imag part of result
!           IERR   - Error flag
!                    IERR=0  Normal return     - COMPUTATION COMPLETED
!                    IERR=1  Input error       - NO COMPUTATION
!                    IERR=2  Overflow          - NO COMPUTATION
!                            (Re(Z) too large with KODE=1)
!                    IERR=3  Precision warning - COMPUTATION COMPLETED
!                            (Result has less than half precision)
!                    IERR=4  Precision error   - NO COMPUTATION
!                            (Result has no precision)
!                    IERR=5  Algorithmic error - NO COMPUTATION
!                            (Termination condition not met)
!
! *Long Description:
!
!         Bi(z) and dBi/dz are computed from I Bessel functions by
!
!                Bi(z) =  c*sqrt(z)*( I(-1/3,zeta) + I(1/3,zeta) )
!               dBi/dz =  c*   z   *( I(-2/3,zeta) + I(2/3,zeta) )
!                    c =  1/sqrt(3)
!                 zeta =  (2/3)*z**(3/2)
!
!         when abs(z)>1 and from power series when abs(z)<=1.
!
!         In most complex variable computation, one must evaluate ele-
!         mentary functions.  When the magnitude of Z is large, losses
!         of significance by argument reduction occur.  Consequently, if
!         the magnitude of ZETA=(2/3)*Z**(3/2) exceeds U1=SQRT(0.5/UR),
!         then losses exceeding half precision are likely and an error
!         flag IERR=3 is triggered where UR=MAX(D1MACH(4),1.0D-18) is
!         double precision unit roundoff limited to 18 digits precision.
!         Also, if the magnitude of ZETA is larger than U2=0.5/UR, then
!         all significance is lost and IERR=4.  In order to use the INT
!         function, ZETA must be further restricted not to exceed
!         U3=I1MACH(9)=LARGEST INTEGER.  Thus, the magnitude of ZETA
!         must be restricted by MIN(U2,U3).  In IEEE arithmetic, U1,U2,
!         and U3 are approximately 2.0E+3, 4.2E+6, 2.1E+9 in single
!         precision and 4.7E+7, 2.3E+15, 2.1E+9 in double precision.
!         This makes U2 limiting is single precision and U3 limiting
!         in double precision.  This means that the magnitude of Z
!         cannot exceed approximately 3.4E+4 in single precision and
!         2.1E+6 in double precision.  This also means that one can
!         expect to retain, in the worst cases on 32-bit machines,
!         no digits in single precision and only 6 digits in double
!         precision.
!
!         The approximate relative error in the magnitude of a complex
!         Bessel function can be expressed as P*10**S where P=MAX(UNIT
!         ROUNDOFF,1.0E-18) is the nominal precision and 10**S repre-
!         sents the increase in error due to argument reduction in the
!         elementary functions.  Here, S=MAX(1,ABS(LOG10(ABS(Z))),
!         ABS(LOG10(FNU))) approximately (i.e., S=MAX(1,ABS(EXPONENT OF
!         ABS(Z),ABS(EXPONENT OF FNU)) ).  However, the phase angle may
!         have only absolute accuracy.  This is most likely to occur
!         when one component (in magnitude) is larger than the other by
!         several orders of magnitude.  If one component is 10**K larger
!         than the other, then one can expect only MAX(ABS(LOG10(P))-K,
!         0) significant digits; or, stated another way, when K exceeds
!         the exponent of P, no significant digits remain in the smaller
!         component.  However, the phase angle retains absolute accuracy
!         because, in complex arithmetic with precision P, the smaller
!         component will not (as a rule) decrease below P times the
!         magnitude of the larger component. In these extreme cases,
!         the principal phase angle is on the order of +P, -P, PI/2-P,
!         or -PI/2+P.
!
!***REFERENCES  1. M. Abramowitz and I. A. Stegun, Handbook of Mathe-
!                 matical Functions, National Bureau of Standards
!                 Applied Mathematics Series 55, U. S. Department
!                 of Commerce, Tenth Printing (1972) or later.
!               2. D. E. Amos, Computation of Bessel Functions of
!                 Complex Argument and Large Order, Report SAND83-0643,
!                 Sandia National Laboratories, Albuquerque, NM, May
!                 1983.
!               3. D. E. Amos, A Subroutine Package for Bessel Functions
!                 of a Complex Argument and Nonnegative Order, Report
!                 SAND85-1018, Sandia National Laboratory, Albuquerque,
!                 NM, May 1985.
!               4. D. E. Amos, A portable package for Bessel functions
!                 of a complex argument and nonnegative order, ACM
!                 Transactions on Mathematical Software, 12 (September
!                 1986), pp. 265-273.
!
!***ROUTINES CALLED  D1MACH, I1MACH, ZABS, ZBINU, ZDIV, ZSQRT
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   890801  REVISION DATE from Version 3.2
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!   920128  Category corrected.  (WRB)
!   920811  Prologue revised.  (DWL)
!   930122  Added ZSQRT to EXTERNAL statement.  (RWC)
!***END PROLOGUE  ZBIRY
!     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)
  EXTERNAL ZABS, ZSQRT
  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/
!***FIRST EXECUTABLE STATEMENT  ZBIRY
  IERR = 0
  NZ=0
  if (ID < 0 .OR. ID > 1) IERR=1
  if (KODE < 1 .OR. KODE > 2) IERR=1
  if (IERR /= 0) RETURN
  AZ = ZABS(ZR,ZI)
  TOL = MAX(D1MACH(4),1.0D-18)
  FID = ID
  if (AZ > 1.0E0) go to 70
!-----------------------------------------------------------------------
!     POWER SERIES FOR ABS(Z) <= 1.
!-----------------------------------------------------------------------
  S1R = CONER
  S1I = CONEI
  S2R = CONER
  S2I = CONEI
  if (AZ < TOL) go to 130
  AA = AZ*AZ
  if (AA < 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 = MIN(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 = MIN(D1,D2)
    if (ATRM < TOL*AD) go to 40
    AK = AK + 18.0D0
    BK = BK + 18.0D0
   30 CONTINUE
   40 CONTINUE
  if (ID == 1) go to 50
  BIR = C1*S1R + C2*(ZR*S2R-ZI*S2I)
  BII = C1*S1I + C2*(ZR*S2I+ZI*S2R)
  if (KODE == 1) RETURN
  call ZSQRT(ZR, ZI, STR, STI)
  ZTAR = TTH*(ZR*STR-ZI*STI)
  ZTAI = TTH*(ZR*STI+ZI*STR)
  AA = ZTAR
  AA = -ABS(AA)
  EAA = EXP(AA)
  BIR = BIR*EAA
  BII = BII*EAA
  return
   50 CONTINUE
  BIR = S2R*C2
  BII = S2I*C2
  if (AZ <= 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 == 1) RETURN
  call ZSQRT(ZR, ZI, STR, STI)
  ZTAR = TTH*(ZR*STR-ZI*STI)
  ZTAI = TTH*(ZR*STI+ZI*STR)
  AA = ZTAR
  AA = -ABS(AA)
  EAA = EXP(AA)
  BIR = BIR*EAA
  BII = BII*EAA
  return
!-----------------------------------------------------------------------
!     CASE FOR ABS(Z) > 1.0
!-----------------------------------------------------------------------
   70 CONTINUE
  FNU = (1.0D0+FID)/3.0D0
!-----------------------------------------------------------------------
!     SET PARAMETERS RELATED TO MACHINE CONSTANTS.
!     TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
!     ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
!     EXP(-ELIM) < EXP(-ALIM)=EXP(-ELIM)/TOL    AND
!     EXP(ELIM) > EXP(ALIM)=EXP(ELIM)*TOL       ARE INTERVALS NEAR
!     UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
!     RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
!     DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
!     FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU.
!-----------------------------------------------------------------------
  K1 = I1MACH(15)
  K2 = I1MACH(16)
  R1M5 = D1MACH(5)
  K = MIN(ABS(K1),ABS(K2))
  ELIM = 2.303D0*(K*R1M5-3.0D0)
  K1 = I1MACH(14) - 1
  AA = R1M5*K1
  DIG = MIN(AA,18.0D0)
  AA = AA*2.303D0
  ALIM = ELIM + MAX(-AA,-41.45D0)
  RL = 1.2D0*DIG + 3.0D0
  FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
!-----------------------------------------------------------------------
!     TEST FOR RANGE
!-----------------------------------------------------------------------
  AA=0.5D0/TOL
  BB=I1MACH(9)*0.5D0
  AA=MIN(AA,BB)
  AA=AA**TTH
  if (AZ > AA) go to 260
  AA=SQRT(AA)
  if (AZ > AA) IERR=3
  call ZSQRT(ZR, ZI, CSQR, CSQI)
  ZTAR = TTH*(ZR*CSQR-ZI*CSQI)
  ZTAI = TTH*(ZR*CSQI+ZI*CSQR)
!-----------------------------------------------------------------------
!     RE(ZTA) <= 0 WHEN RE(Z) < 0, ESPECIALLY WHEN IM(Z) IS SMALL
!-----------------------------------------------------------------------
  SFAC = 1.0D0
  AK = ZTAI
  if (ZR >= 0.0D0) go to 80
  BK = ZTAR
  CK = -ABS(BK)
  ZTAR = CK
  ZTAI = AK
   80 CONTINUE
  if (ZI /= 0.0D0 .OR. ZR > 0.0D0) go to 90
  ZTAR = 0.0D0
  ZTAI = AK
   90 CONTINUE
  AA = ZTAR
  if (KODE == 2) go to 100
!-----------------------------------------------------------------------
!     OVERFLOW TEST
!-----------------------------------------------------------------------
  BB = ABS(AA)
  if (BB < ALIM) go to 100
  BB = BB + 0.25D0*LOG(AZ)
  SFAC = TOL
  if (BB > ELIM) go to 190
  100 CONTINUE
  FMR = 0.0D0
  if (AA >= 0.0D0 .AND. ZR > 0.0D0) go to 110
  FMR = PI
  if (ZI < 0.0D0) FMR = -PI
  ZTAR = -ZTAR
  ZTAI = -ZTAI
  110 CONTINUE
!-----------------------------------------------------------------------
!     AA=FACTOR FOR ANALYTIC CONTINUATION OF I(FNU,ZTA)
!     KODE=2 RETURNS EXP(-ABS(XZTA))*I(FNU,ZTA) FROM CBESI
!-----------------------------------------------------------------------
  call ZBINU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, RL, FNUL, TOL, &
   ELIM, ALIM)
  if (NZ < 0) go to 200
  AA = FMR*FNU
  Z3R = SFAC
  STR = COS(AA)
  STI = SIN(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
!-----------------------------------------------------------------------
!     BACKWARD RECUR ONE STEP FOR ORDERS -1/3 OR -2/3
!-----------------------------------------------------------------------
  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 = COS(AA)
  STI = SIN(AA)
  S1R = COEF*(S1R+S2R*STR-S2I*STI)
  S1I = COEF*(S1I+S2R*STI+S2I*STR)
  if (ID == 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 == (-1)) go to 190
  NZ=0
  IERR=5
  return
  260 CONTINUE
  IERR=4
  NZ=0
  return
end



subroutine ZBKNU (ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, ALIM)
!
!! ZBKNU is subsidiary to ZAIRY, ZBESH, ZBESI and ZBESK.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CBKNU-A, ZBKNU-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     ZBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE.
!
!***SEE ALSO  ZAIRY, ZBESH, ZBESI, ZBESK
!***ROUTINES CALLED  D1MACH, DGAMLN, I1MACH, ZABS, ZDIV, ZEXP, ZKSCL,
!                    ZLOG, ZMLT, ZSHCH, ZSQRT, ZUCHK
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!   930122  Added ZEXP, ZLOG and ZSQRT to EXTERNAL statement.  (RWC)
!***END PROLOGUE  ZBKNU
!
  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)
  EXTERNAL ZABS, ZEXP, ZLOG, ZSQRT
!     COMPLEX Z,Y,A,B,RZ,SMU,FU,FMU,F,FLRZ,CZ,S1,S2,CSH,CCH
!     COMPLEX CK,P,Q,COEF,P1,P2,CBK,PT,CZERO,CONE,CTWO,ST,EZ,CS,DK
!
  DATA KMAX / 30 /
  DATA CZEROR,CZEROI,CONER,CONEI,CTWOR,R1/ &
    0.0D0 , 0.0D0 , 1.0D0 , 0.0D0 , 2.0D0 , 2.0D0 /
  DATA DPI, RTHPI, SPI ,HPI, FPI, TTH / &
       3.14159265358979324D0,       1.25331413731550025D0, &
       1.90985931710274403D0,       1.57079632679489662D0, &
       1.89769999331517738D0,       6.66666666666666666D-01/
  DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)/ &
       5.77215664901532861D-01,    -4.20026350340952355D-02, &
      -4.21977345555443367D-02,     7.21894324666309954D-03, &
      -2.15241674114950973D-04,    -2.01348547807882387D-05, &
       1.13302723198169588D-06,     6.11609510448141582D-09/
!***FIRST EXECUTABLE STATEMENT  ZBKNU
  CAZ = ZABS(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 = FNU+0.5D0
  DNU = FNU - INU
  if (ABS(DNU) == 0.5D0) go to 110
  DNU2 = 0.0D0
  if (ABS(DNU) > TOL) DNU2 = DNU*DNU
  if (CAZ > R1) go to 110
!-----------------------------------------------------------------------
!     SERIES FOR ABS(Z) <= R1
!-----------------------------------------------------------------------
  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 == 0.0D0) go to 10
  FC = DNU*DPI
  FC = FC/SIN(FC)
  SMUR = CSHR/DNU
  SMUI = CSHI/DNU
   10 CONTINUE
  A2 = 1.0D0 + DNU
!-----------------------------------------------------------------------
!     GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU), T2=1/GAM(1+DNU)
!-----------------------------------------------------------------------
  T2 = EXP(-DGAMLN(A2,IDUM))
  T1 = 1.0D0/(T2*FC)
  if (ABS(DNU) > 0.1D0) go to 40
!-----------------------------------------------------------------------
!     SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU)
!-----------------------------------------------------------------------
  AK = 1.0D0
  S = CC(1)
  DO 20 K=2,8
    AK = AK*DNU2
    TM = CC(K)*AK
    S = S + TM
    if (ABS(TM) < 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 > 0 .OR. N > 1) go to 80
!-----------------------------------------------------------------------
!     GENERATE K(FNU,Z), 0.0D0  <=  FNU  <  0.5D0 AND N=1
!-----------------------------------------------------------------------
  if (CAZ < 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 > TOL) go to 60
   70 CONTINUE
  YR(1) = S1R
  YI(1) = S1I
  if (KODED == 1) RETURN
  call ZEXP(ZR, ZI, STR, STI)
  call ZMLT(S1R, S1I, STR, STI, YR(1), YI(1))
  return
!-----------------------------------------------------------------------
!     GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE
!-----------------------------------------------------------------------
   80 CONTINUE
  if (CAZ < 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 > TOL) go to 90
  100 CONTINUE
  KFLAG = 2
  A1 = FNU + 1.0D0
  AK = A1*ABS(SMUR)
  if (AK > 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 == 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
!-----------------------------------------------------------------------
!     IFLAG=0 MEANS NO UNDERFLOW OCCURRED
!     IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH
!     KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD
!     RECURSION
!-----------------------------------------------------------------------
  110 CONTINUE
  call ZSQRT(ZR, ZI, STR, STI)
  call ZDIV(RTHPI, CZEROI, STR, STI, COEFR, COEFI)
  KFLAG = 2
  if (KODED == 2) go to 120
  if (ZR > ALIM) go to 290
!     BLANK LINE
  STR = EXP(-ZR)*CSSR(KFLAG)
  STI = -STR*SIN(ZI)
  STR = STR*COS(ZI)
  call ZMLT(COEFR, COEFI, STR, STI, COEFR, COEFI)
  120 CONTINUE
  if (ABS(DNU) == 0.5D0) go to 300
!-----------------------------------------------------------------------
!     MILLER ALGORITHM FOR ABS(Z) > R1
!-----------------------------------------------------------------------
  AK = COS(DPI*DNU)
  AK = ABS(AK)
  if (AK == CZEROR) go to 300
  FHS = ABS(0.25D0-DNU2)
  if (FHS == CZEROR) go to 300
!-----------------------------------------------------------------------
!     COMPUTE R2=F(E). if ABS(Z) >= R2, USE FORWARD RECURRENCE TO
!     DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT LINE ON
!     12 <= E <= 60. E IS COMPUTED FROM 2**(-E)=B**(1-I1MACH(14))=
!     TOL WHERE B IS THE BASE OF THE ARITHMETIC.
!-----------------------------------------------------------------------
  T1 = I1MACH(14)-1
  T1 = T1*D1MACH(5)*3.321928094D0
  T1 = MAX(T1,12.0D0)
  T1 = MIN(T1,60.0D0)
  T2 = TTH*T1 - 6.0D0
  if (ZR /= 0.0D0) go to 130
  T1 = HPI
  go to 140
  130 CONTINUE
  T1 = DATAN(ZI/ZR)
  T1 = ABS(T1)
  140 CONTINUE
  if (T2 > CAZ) go to 170
!-----------------------------------------------------------------------
!     FORWARD RECURRENCE LOOP WHEN ABS(Z) >= R2
!-----------------------------------------------------------------------
  ETEST = AK/(DPI*CAZ*TOL)
  FK = CONER
  if (ETEST < 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 = ABS(P2R)*FK
    if (ETEST < STR) go to 160
  150 CONTINUE
  go to 310
  160 CONTINUE
  FK = FK + SPI*T1*SQRT(T2/CAZ)
  FHS = ABS(0.25D0-DNU2)
  go to 180
  170 CONTINUE
!-----------------------------------------------------------------------
!     COMPUTE BACKWARD INDEX K FOR ABS(Z) < R2
!-----------------------------------------------------------------------
  A2 = SQRT(CAZ)
  AK = FPI*AK/(TOL*SQRT(A2))
  AA = 3.0D0*T1/(1.0D0+CAZ)
  BB = 14.7D0*T1/(28.0D0+CAZ)
  AK = (LOG(AK)+CAZ*COS(AA)/(1.0D0+0.008D0*CAZ))/COS(BB)
  FK = 0.12125D0*AK*AK/CAZ + 1.5D0
  180 CONTINUE
!-----------------------------------------------------------------------
!     BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM
!-----------------------------------------------------------------------
  K = FK
  FK = 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
!-----------------------------------------------------------------------
!     COMPUTE (P2/CS)=(P2/ABS(CS))*(CONJG(CS)/ABS(CS)) FOR BETTER
!     SCALING
!-----------------------------------------------------------------------
  TM = ZABS(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 > 0 .OR. N > 1) go to 200
  ZDR = ZR
  ZDI = ZI
  if ( IFLAG == 1) go to 270
  go to 240
  200 CONTINUE
!-----------------------------------------------------------------------
!     COMPUTE P1/P2=(P1/ABS(P2)*CONJG(P2)/ABS(P2) FOR SCALING
!-----------------------------------------------------------------------
  TM = ZABS(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)
!-----------------------------------------------------------------------
!     FORWARD RECURSION ON THE THREE TERM RECURSION WITH RELATION WITH
!     SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3
!-----------------------------------------------------------------------
  210 CONTINUE
  STR = DNU + 1.0D0
  CKR = STR*RZR
  CKI = STR*RZI
  if (N == 1) INU = INU - 1
  if (INU > 0) go to 220
  if (N > 1) go to 215
  S1R = S2R
  S1I = S2I
  215 CONTINUE
  ZDR = ZR
  ZDI = ZI
  if ( IFLAG == 1) go to 270
  go to 240
  220 CONTINUE
  INUB = 1
  if ( IFLAG == 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 >= 3) go to 230
    P2R = S2R*P1R
    P2I = S2I*P1R
    STR = ABS(P2R)
    STI = ABS(P2I)
    P2M = MAX(STR,STI)
    if (P2M <= 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 /= 1) go to 240
  S1R = S2R
  S1I = S2I
  240 CONTINUE
  STR = CSRR(KFLAG)
  YR(1) = S1R*STR
  YI(1) = S1I*STR
  if (N == 1) RETURN
  YR(2) = S2R*STR
  YI(2) = S2I*STR
  if (N == 2) RETURN
  KK = 2
  250 CONTINUE
  KK = KK + 1
  if (KK > 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 >= 3) go to 260
    STR = ABS(P2R)
    STI = ABS(P2I)
    P2M = MAX(STR,STI)
    if (P2M <= 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
!-----------------------------------------------------------------------
!     IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW
!-----------------------------------------------------------------------
  261 CONTINUE
  HELIM = 0.5D0*ELIM
  ELM = EXP(-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(S2R,S2I)
    ALAS = LOG(AS)
    P2R = -ZDR+ALAS
    if ( P2R < (-ELIM)) go to 263
    call ZLOG(S2R,S2I,STR,STI,IDUM)
    P2R = -ZDR+STR
    P2I = -ZDI+STI
    P2M = EXP(P2R)/TOL
    P1R = P2M*COS(P2I)
    P1I = P2M*SIN(P2I)
    call ZUCHK(P1R,P1I,NW,ASCLE,TOL)
    if ( NW /= 0) go to 263
    J = 3 - J
    CYR(J) = P1R
    CYI(J) = P1I
    if ( IC == (I-1)) go to 264
    IC = I
    go to 262
  263   CONTINUE
    if ( ALAS < HELIM) go to 262
    ZDR = ZDR-ELIM
    S1R = S1R*CELMR
    S1I = S1I*CELMR
    S2R = S2R*CELMR
    S2I = S2I*CELMR
  262 CONTINUE
  if ( N /= 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 <= INU) go to 225
  if ( N /= 1) go to 240
  S1R = S2R
  S1I = S2I
  go to 240
  270 CONTINUE
  YR(1) = S1R
  YI(1) = S1I
  if ( N == 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 <= 0) RETURN
  KK = NZ + 1
  S1R = YR(KK)
  S1I = YI(KK)
  YR(KK) = S1R*CSRR(1)
  YI(KK) = S1I*CSRR(1)
  if (INU == 1) RETURN
  KK = NZ + 2
  S2R = YR(KK)
  S2I = YI(KK)
  YR(KK) = S2R*CSRR(1)
  YI(KK) = S2I*CSRR(1)
  if (INU == 2) RETURN
  T2 = FNU + (KK-1)
  CKR = T2*RZR
  CKI = T2*RZI
  KFLAG = 1
  go to 250
  290 CONTINUE
!-----------------------------------------------------------------------
!     SCALE BY EXP(Z), IFLAG = 1 CASES
!-----------------------------------------------------------------------
  KODED = 2
  IFLAG = 1
  KFLAG = 2
  go to 120
!-----------------------------------------------------------------------
!     FNU=HALF ODD INTEGER CASE, DNU=-0.5
!-----------------------------------------------------------------------
  300 CONTINUE
  S1R = COEFR
  S1I = COEFI
  S2R = COEFR
  S2I = COEFI
  go to 210
!
!
  310 CONTINUE
  NZ=-2
  return
end



subroutine ZBUNI (ZR, ZI, FNU, KODE, N, YR, YI, NZ, NUI, NLAST, &
     FNUL, TOL, ELIM, ALIM)
!
!! ZBUNI is subsidiary to ZBESI and ZBESK.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CBUNI-A, ZBUNI-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     ZBUNI COMPUTES THE I BESSEL FUNCTION FOR LARGE ABS(Z) >
!     FNUL AND FNU+N-1 < FNUL. THE ORDER IS INCREASED FROM
!     FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING
!     ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z)
!     ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2
!
!***SEE ALSO  ZBESI, ZBESK
!***ROUTINES CALLED  D1MACH, ZABS, ZUNI1, ZUNI2
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!***END PROLOGUE  ZBUNI
!     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)
  EXTERNAL ZABS
!***FIRST EXECUTABLE STATEMENT  ZBUNI
  NZ = 0
  AX = ABS(ZR)*1.7321D0
  AY = ABS(ZI)
  IFORM = 1
  if (AY > AX) IFORM = 2
  if (NUI == 0) go to 60
  FNUI = NUI
  DFNU = FNU + (N-1)
  GNU = DFNU + FNUI
  if (IFORM == 2) go to 10
!-----------------------------------------------------------------------
!     ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN
!     -PI/3 <= ARG(Z) <= PI/3
!-----------------------------------------------------------------------
  call ZUNI1(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, &
   ELIM, ALIM)
  go to 20
   10 CONTINUE
!-----------------------------------------------------------------------
!     ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU
!     APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I
!     AND HPI=PI/2
!-----------------------------------------------------------------------
  call ZUNI2(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, &
   ELIM, ALIM)
   20 CONTINUE
  if (NW < 0) go to 50
  if (NW /= 0) go to 90
  STR = ZABS(CYR(1),CYI(1))
!----------------------------------------------------------------------
!     SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER USED
!----------------------------------------------------------------------
  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 > BRY(1)) go to 21
  IFLAG = 1
  ASCLE = BRY(1)
  CSCLR = 1.0D0/TOL
  go to 25
   21 CONTINUE
  if (STR < 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(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 >= 3) go to 30
    STR = S2R*CSCRR
    STI = S2I*CSCRR
    C1R = ABS(STR)
    C1I = ABS(STI)
    C1M = MAX(C1R,C1I)
    if (C1M <= 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 == 1) RETURN
  NL = N - 1
  FNUI = 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 >= 3) go to 40
    C1R = ABS(STR)
    C1I = ABS(STI)
    C1M = MAX(C1R,C1I)
    if (C1M <= 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 == (-2)) NZ=-2
  return
   60 CONTINUE
  if (IFORM == 2) go to 70
!-----------------------------------------------------------------------
!     ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN
!     -PI/3 <= ARG(Z) <= PI/3
!-----------------------------------------------------------------------
  call ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL, &
   ELIM, ALIM)
  go to 80
   70 CONTINUE
!-----------------------------------------------------------------------
!     ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU
!     APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I
!     AND HPI=PI/2
!-----------------------------------------------------------------------
  call ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL, &
   ELIM, ALIM)
   80 CONTINUE
  if (NW < 0) go to 50
  NZ = NW
  return
   90 CONTINUE
  NLAST = N
  return
end



subroutine ZBUNK (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, &
     ALIM)
!
!! ZBUNK is subsidiary to ZBESH and ZBESK.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CBUNI-A, ZBUNI-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     ZBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU > FNUL.
!     ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z)
!     IN ZUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN ZUNK2
!
!***SEE ALSO  ZBESH, ZBESK
!***ROUTINES CALLED  ZUNK1, ZUNK2
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!***END PROLOGUE  ZBUNK
!     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)
!***FIRST EXECUTABLE STATEMENT  ZBUNK
  NZ = 0
  AX = ABS(ZR)*1.7321D0
  AY = ABS(ZI)
  if (AY > AX) go to 10
!-----------------------------------------------------------------------
!     ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN
!     -PI/3 <= ARG(Z) <= PI/3
!-----------------------------------------------------------------------
  call ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM)
  go to 20
   10 CONTINUE
!-----------------------------------------------------------------------
!     ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU
!     APPLIED IN PI/3 < ABS(ARG(Z)) <= PI/2 WHERE M=+I OR -I
!     AND HPI=PI/2
!-----------------------------------------------------------------------
  call ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM)
   20 CONTINUE
  return
end



subroutine ZDIV (AR, AI, BR, BI, CR, CI)
!
!! ZDIV is subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and ZBIRY.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (ZDIV-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     DOUBLE PRECISION COMPLEX DIVIDE C=A/B.
!
!***SEE ALSO  ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY
!***ROUTINES CALLED  ZABS
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!***END PROLOGUE  ZDIV
  DOUBLE PRECISION AR, AI, BR, BI, CR, CI, BM, CA, CB, CC, CD
  DOUBLE PRECISION ZABS
  EXTERNAL ZABS
!***FIRST EXECUTABLE STATEMENT  ZDIV
  BM = 1.0D0/ZABS(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



subroutine ZEXP (AR, AI, BR, BI)
!
!! ZEXP is subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and ZBIRY.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (ZEXP-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     DOUBLE PRECISION COMPLEX EXPONENTIAL FUNCTION B=EXP(A)
!
!***SEE ALSO  ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY
!***ROUTINES CALLED  (NONE)
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!***END PROLOGUE  ZEXP
  DOUBLE PRECISION AR, AI, BR, BI, ZM, CA, CB
!***FIRST EXECUTABLE STATEMENT  ZEXP
  ZM = EXP(AR)
  CA = ZM*COS(AI)
  CB = ZM*SIN(AI)
  BR = CA
  BI = CB
  return
end



subroutine ZKSCL (ZRR, ZRI, FNU, N, YR, YI, NZ, RZR, RZI, ASCLE, &
     TOL, ELIM)
!
!! ZKSCL is subsidiary to ZBESK.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CKSCL-A, ZKSCL-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     SET K FUNCTIONS TO ZERO ON UNDERFLOW, CONTINUE RECURRENCE
!     ON SCALED FUNCTIONS UNTIL TWO MEMBERS COME ON SCALE, THEN
!     return WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL.
!
!***SEE ALSO  ZBESK
!***ROUTINES CALLED  ZABS, ZLOG, ZUCHK
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!   930122  Added ZLOG to EXTERNAL statement.  (RWC)
!***END PROLOGUE  ZKSCL
!     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)
  EXTERNAL ZABS, ZLOG
  DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 /
!***FIRST EXECUTABLE STATEMENT  ZKSCL
  NZ = 0
  IC = 0
  NN = MIN(2,N)
  DO 10 I=1,NN
    S1R = YR(I)
    S1I = YI(I)
    CYR(I) = S1R
    CYI(I) = S1I
    AS = ZABS(S1R,S1I)
    ACS = -ZRR + LOG(AS)
    NZ = NZ + 1
    YR(I) = ZEROR
    YI(I) = ZEROI
    if (ACS < (-ELIM)) go to 10
    call ZLOG(S1R, S1I, CSR, CSI, IDUM)
    CSR = CSR - ZRR
    CSI = CSI - ZRI
    STR = EXP(CSR)/TOL
    CSR = STR*COS(CSI)
    CSI = STR*SIN(CSI)
    call ZUCHK(CSR, CSI, NW, ASCLE, TOL)
    if (NW /= 0) go to 10
    YR(I) = CSR
    YI(I) = CSI
    IC = I
    NZ = NZ - 1
   10 CONTINUE
  if (N == 1) RETURN
  if (IC > 1) go to 20
  YR(1) = ZEROR
  YI(1) = ZEROI
  NZ = 2
   20 CONTINUE
  if (N == 2) RETURN
  if (NZ == 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 = EXP(-ELIM)
  CELMR = ELM
  ZDR = ZRR
  ZDI = ZRI
!
!     FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE RECURRENCE IF
!     S2 GETS LARGER THAN EXP(ELIM/2)
!
  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(S2R,S2I)
    ALAS = LOG(AS)
    ACS = -ZDR + ALAS
    NZ = NZ + 1
    YR(I) = ZEROR
    YI(I) = ZEROI
    if (ACS < (-ELIM)) go to 25
    call ZLOG(S2R, S2I, CSR, CSI, IDUM)
    CSR = CSR - ZDR
    CSI = CSI - ZDI
    STR = EXP(CSR)/TOL
    CSR = STR*COS(CSI)
    CSI = STR*SIN(CSI)
    call ZUCHK(CSR, CSI, NW, ASCLE, TOL)
    if (NW /= 0) go to 25
    YR(I) = CSR
    YI(I) = CSI
    NZ = NZ - 1
    if (IC == KK-1) go to 40
    IC = KK
    go to 30
   25   CONTINUE
    if ( ALAS < 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 == 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



subroutine ZLOG (AR, AI, BR, BI, IERR)
!
!! ZLOG is subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and ZBIRY.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (ZLOG-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     DOUBLE PRECISION COMPLEX LOGARITHM B=CLOG(A)
!     IERR=0,NORMAL RETURN      IERR=1, Z=CMPLX(0.0,0.0)
!***SEE ALSO  ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY
!***ROUTINES CALLED  ZABS
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!***END PROLOGUE  ZLOG
  DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DHPI
  DOUBLE PRECISION ZABS
  INTEGER IERR
  EXTERNAL ZABS
  DATA DPI , DHPI  / 3.141592653589793238462643383D+0, &
                     1.570796326794896619231321696D+0/
!***FIRST EXECUTABLE STATEMENT  ZLOG
  IERR=0
  if (AR == 0.0D+0) go to 10
  if (AI == 0.0D+0) go to 20
  DTHETA = DATAN(AI/AR)
  if (DTHETA <= 0.0D+0) go to 40
  if (AR < 0.0D+0) DTHETA = DTHETA - DPI
  go to 50
   10 if (AI == 0.0D+0) go to 60
  BI = DHPI
  BR = LOG(ABS(AI))
  if (AI < 0.0D+0) BI = -BI
  return
   20 if (AR > 0.0D+0) go to 30
  BR = LOG(ABS(AR))
  BI = DPI
  return
   30 BR = LOG(AR)
  BI = 0.0D+0
  return
   40 if (AR < 0.0D+0) DTHETA = DTHETA + DPI
   50 ZM = ZABS(AR,AI)
  BR = LOG(ZM)
  BI = DTHETA
  return
   60 CONTINUE
  IERR=1
  return
end



subroutine ZMLRI (ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL)
!
!! ZMLRI is subsidiary to ZBESI and ZBESK.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CMLRI-A, ZMLRI-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     ZMLRI COMPUTES THE I BESSEL FUNCTION FOR RE(Z) >= 0.0 BY THE
!     MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES.
!
!***SEE ALSO  ZBESI, ZBESK
!***ROUTINES CALLED  D1MACH, DGAMLN, ZABS, ZEXP, ZLOG, ZMLT
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!   930122  Added ZEXP and ZLOG to EXTERNAL statement.  (RWC)
!***END PROLOGUE  ZMLRI
!     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)
  EXTERNAL ZABS, ZEXP, ZLOG
  DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
!***FIRST EXECUTABLE STATEMENT  ZMLRI
  SCLE = D1MACH(1)/TOL
  NZ=0
  AZ = ZABS(ZR,ZI)
  IAZ = AZ
  IFNU = FNU
  INU = IFNU + N - 1
  AT = 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 + SQRT(ACK*ACK-1.0D0)
  RHO2 = RHO*RHO
  TST = (RHO2+RHO2)/((RHO2-1.0D0)*(RHO-1.0D0))
  TST = TST/TOL
!-----------------------------------------------------------------------
!     COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES
!-----------------------------------------------------------------------
  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(P2R,P2I)
    if (AP > TST*AK*AK) go to 20
    AK = AK + 1.0D0
   10 CONTINUE
  go to 110
   20 CONTINUE
  I = I + 1
  K = 0
  if (INU < IAZ) go to 40
!-----------------------------------------------------------------------
!     COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS
!-----------------------------------------------------------------------
  P1R = ZEROR
  P1I = ZEROI
  P2R = CONER
  P2I = CONEI
  AT = INU + 1.0D0
  STR = ZR*RAZ
  STI = -ZI*RAZ
  CKR = STR*AT*RAZ
  CKI = STI*AT*RAZ
  ACK = AT*RAZ
  TST = SQRT(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(P2R,P2I)
    if (AP < TST) go to 30
    if (ITIME == 2) go to 40
    ACK = ZABS(CKR,CKI)
    FLAM = ACK + SQRT(ACK*ACK-1.0D0)
    FKAP = AP/ZABS(P1R,P1I)
    RHO = MIN(FLAM,FKAP)
    TST = TST*SQRT(RHO/(RHO*RHO-1.0D0))
    ITIME = 2
   30 CONTINUE
  go to 110
   40 CONTINUE
!-----------------------------------------------------------------------
!     BACKWARD RECURRENCE AND SUM NORMALIZING RELATION
!-----------------------------------------------------------------------
  K = K + 1
  KK = MAX(I+IAZ,K+INU)
  FKK = KK
  P1R = ZEROR
  P1I = ZEROI
!-----------------------------------------------------------------------
!     SCALE P2 AND SUM BY SCLE
!-----------------------------------------------------------------------
  P2R = SCLE
  P2I = ZEROI
  FNF = FNU - IFNU
  TFNF = FNF + FNF
  BK = DGAMLN(FKK+TFNF+1.0D0,IDUM) - DGAMLN(FKK+1.0D0,IDUM) - &
   DGAMLN(TFNF+1.0D0,IDUM)
  BK = EXP(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 == 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 <= 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 == 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
!-----------------------------------------------------------------------
!     THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW
!     IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES
!-----------------------------------------------------------------------
  P2R = P2R + SUMR
  P2I = P2I + SUMI
  AP = ZABS(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



subroutine ZMLT (AR, AI, BR, BI, CR, CI)
!
!! ZMLT is subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and ZBIRY.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (ZMLT-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     DOUBLE PRECISION COMPLEX MULTIPLY, C=A*B.
!
!***SEE ALSO  ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY
!***ROUTINES CALLED  (NONE)
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!***END PROLOGUE  ZMLT
  DOUBLE PRECISION AR, AI, BR, BI, CR, CI, CA, CB
!***FIRST EXECUTABLE STATEMENT  ZMLT
  CA = AR*BR - AI*BI
  CB = AR*BI + AI*BR
  CR = CA
  CI = CB
  return
end



subroutine ZRATI (ZR, ZI, FNU, N, CYR, CYI, TOL)
!
!! ZRATI is subsidiary to ZBESH, ZBESI and ZBESK.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CRATI-A, ZRATI-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     ZRATI COMPUTES RATIOS OF I BESSEL FUNCTIONS BY BACKWARD
!     RECURRENCE.  THE STARTING INDEX IS DETERMINED BY FORWARD
!     RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B,
!     MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973,
!     BESSEL FUNCTIONS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER,
!     BY D. J. SOOKNE.
!
!***SEE ALSO  ZBESH, ZBESI, ZBESK
!***ROUTINES CALLED  ZABS, ZDIV
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!***END PROLOGUE  ZRATI
  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)
  EXTERNAL ZABS
  DATA CZEROR,CZEROI,CONER,CONEI,RT2/ &
   0.0D0, 0.0D0, 1.0D0, 0.0D0, 1.41421356237309505D0 /
!***FIRST EXECUTABLE STATEMENT  ZRATI
  AZ = ZABS(ZR,ZI)
  INU = FNU
  IDNU = INU + N - 1
  MAGZ = AZ
  AMAGZ = MAGZ+1
  FDNU = IDNU
  FNUP = MAX(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 > 0) ID = 0
  AP2 = ZABS(P2R,P2I)
  AP1 = ZABS(P1R,P1I)
!-----------------------------------------------------------------------
!     THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE call TO CBKNU
!     GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT
!     P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR
!     PREMATURELY.
!-----------------------------------------------------------------------
  ARG = (AP2+AP2)/(AP1*TOL)
  TEST1 = SQRT(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(P2R,P2I)
  if (AP1 <= TEST) go to 10
  if (ITIME == 2) go to 20
  AK = ZABS(T1R,T1I)*0.5D0
  FLAM = AK + SQRT(AK*AK-1.0D0)
  RHO = MIN(AP2/AP1,FLAM)
  TEST = TEST1*SQRT(RHO/(RHO*RHO-1.0D0))
  ITIME = 2
  go to 10
   20 CONTINUE
  KK = K + 1 - ID
  AK = KK
  T1R = AK
  T1I = CZEROI
  DFNU = FNU + (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 /= CZEROR .OR. P1I /= CZEROI) go to 40
  P1R = TOL
  P1I = TOL
   40 CONTINUE
  call ZDIV(P2R, P2I, P1R, P1I, CYR(N), CYI(N))
  if (N == 1) RETURN
  K = N - 1
  AK = 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(PTR,PTI)
    if (AK /= 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



subroutine ZS1S2 (ZRR, ZRI, S1R, S1I, S2R, S2I, NZ, ASCLE, ALIM, IUF)
!
!! ZS1S2 is subsidiary to ZAIRY and ZBESK.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CS1S2-A, ZS1S2-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     ZS1S2 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE
!     ADDITION OF THE I AND K FUNCTIONS IN THE ANALYTIC CON-
!     TINUATION FORMULA WHERE S1=K FUNCTION AND S2=I FUNCTION.
!     ON KODE=1 THE I AND K FUNCTIONS ARE DIFFERENT ORDERS OF
!     MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER
!     OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE
!     PRECISION ABOVE THE UNDERFLOW LIMIT.
!
!***SEE ALSO  ZAIRY, ZBESK
!***ROUTINES CALLED  ZABS, ZEXP, ZLOG
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!   930122  Added ZEXP and ZLOG to EXTERNAL statement.  (RWC)
!***END PROLOGUE  ZS1S2
!     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
  EXTERNAL ZABS, ZEXP, ZLOG
  DATA ZEROR,ZEROI  / 0.0D0 , 0.0D0 /
!***FIRST EXECUTABLE STATEMENT  ZS1S2
  NZ = 0
  AS1 = ZABS(S1R,S1I)
  AS2 = ZABS(S2R,S2I)
  if (S1R == 0.0D0 .AND. S1I == 0.0D0) go to 10
  if (AS1 == 0.0D0) go to 10
  ALN = -ZRR - ZRR + LOG(AS1)
  S1DR = S1R
  S1DI = S1I
  S1R = ZEROR
  S1I = ZEROI
  AS1 = ZEROR
  if (ALN < (-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(S1R,S1I)
  IUF = IUF + 1
   10 CONTINUE
  AA = MAX(AS1,AS2)
  if (AA > ASCLE) RETURN
  S1R = ZEROR
  S1I = ZEROI
  S2R = ZEROR
  S2I = ZEROI
  NZ = 1
  IUF = 0
  return
end



subroutine ZSERI (ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, ALIM)
!
!! ZSERI is subsidiary to ZBESI and ZBESK.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CSERI-A, ZSERI-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     ZSERI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z) >= 0.0 BY
!     MEANS OF THE POWER SERIES FOR LARGE ABS(Z) IN THE
!     REGION ABS(Z) <= 2*SQRT(FNU+1). NZ=0 IS A NORMAL RETURN.
!     NZ > 0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO
!     DUE TO UNDERFLOW. NZ < 0 MEANS UNDERFLOW OCCURRED, BUT THE
!     CONDITION ABS(Z) <= 2*SQRT(FNU+1) WAS VIOLATED AND THE
!     COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ).
!
!***SEE ALSO  ZBESI, ZBESK
!***ROUTINES CALLED  D1MACH, DGAMLN, ZABS, ZDIV, ZLOG, ZMLT, ZUCHK
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!   930122  Added ZLOG to EXTERNAL statement.  (RWC)
!***END PROLOGUE  ZSERI
!     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)
  EXTERNAL ZABS, ZLOG
  DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
!***FIRST EXECUTABLE STATEMENT  ZSERI
  NZ = 0
  AZ = ZABS(ZR,ZI)
  if (AZ == 0.0D0) go to 160
  ARM = 1.0D+3*D1MACH(1)
  RTR1 = SQRT(ARM)
  CRSCR = 1.0D0
  IFLAG = 0
  if (AZ < ARM) go to 150
  HZR = 0.5D0*ZR
  HZI = 0.5D0*ZI
  CZR = ZEROR
  CZI = ZEROI
  if (AZ <= RTR1) go to 10
  call ZMLT(HZR, HZI, HZR, HZI, CZR, CZI)
   10 CONTINUE
  ACZ = ZABS(CZR,CZI)
  NN = N
  call ZLOG(HZR, HZI, CKR, CKI, IDUM)
   20 CONTINUE
  DFNU = FNU + (NN-1)
  FNUP = DFNU + 1.0D0
!-----------------------------------------------------------------------
!     UNDERFLOW TEST
!-----------------------------------------------------------------------
  AK1R = CKR*DFNU
  AK1I = CKI*DFNU
  AK = DGAMLN(FNUP,IDUM)
  AK1R = AK1R - AK
  if (KODE == 2) AK1R = AK1R - ZR
  if (AK1R > (-ELIM)) go to 40
   30 CONTINUE
  NZ = NZ + 1
  YR(NN) = ZEROR
  YI(NN) = ZEROI
  if (ACZ > DFNU) go to 190
  NN = NN - 1
  if (NN == 0) RETURN
  go to 20
   40 CONTINUE
  if (AK1R > (-ALIM)) go to 50
  IFLAG = 1
  SS = 1.0D0/TOL
  CRSCR = TOL
  ASCLE = ARM*SS
   50 CONTINUE
  AA = EXP(AK1R)
  if (IFLAG == 1) AA = AA*SS
  COEFR = AA*COS(AK1I)
  COEFI = AA*SIN(AK1I)
  ATOL = TOL*ACZ/FNUP
  IL = MIN(2,NN)
  DO 90 I=1,IL
    DFNU = FNU + (NN-I)
    FNUP = DFNU + 1.0D0
    S1R = CONER
    S1I = CONEI
    if (ACZ < 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 > ATOL) go to 60
   70   CONTINUE
    S2R = S1R*COEFR - S1I*COEFI
    S2I = S1R*COEFI + S1I*COEFR
    WR(I) = S2R
    WI(I) = S2I
    if (IFLAG == 0) go to 80
    call ZUCHK(S2R, S2I, NW, ASCLE, TOL)
    if (NW /= 0) go to 30
   80   CONTINUE
    M = NN - I + 1
    YR(M) = S2R*CRSCR
    YI(M) = S2I*CRSCR
    if (I == IL) go to 90
    call ZDIV(COEFR, COEFI, HZR, HZI, STR, STI)
    COEFR = STR*DFNU
    COEFI = STI*DFNU
   90 CONTINUE
  if (NN <= 2) RETURN
  K = NN - 2
  AK = K
  RAZ = 1.0D0/AZ
  STR = ZR*RAZ
  STI = -ZI*RAZ
  RZR = (STR+STR)*RAZ
  RZI = (STI+STI)*RAZ
  if (IFLAG == 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
!-----------------------------------------------------------------------
!     RECUR BACKWARD WITH SCALED VALUES
!-----------------------------------------------------------------------
  120 CONTINUE
!-----------------------------------------------------------------------
!     EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE
!     UNDERFLOW LIMIT = ASCLE = D1MACH(1)*SS*1.0D+3
!-----------------------------------------------------------------------
  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(CKR,CKI) > ASCLE) go to 140
  130 CONTINUE
  return
  140 CONTINUE
  IB = L + 1
  if (IB > NN) RETURN
  go to 100
  150 CONTINUE
  NZ = N
  if (FNU == 0.0D0) NZ = NZ - 1
  160 CONTINUE
  YR(1) = ZEROR
  YI(1) = ZEROI
  if (FNU /= 0.0D0) go to 170
  YR(1) = CONER
  YI(1) = CONEI
  170 CONTINUE
  if (N == 1) RETURN
  DO 180 I=2,N
    YR(I) = ZEROR
    YI(I) = ZEROI
  180 CONTINUE
  return
!-----------------------------------------------------------------------
!     return WITH NZ < 0 if ABS(Z*Z/4) > FNU+N-NZ-1 COMPLETE
!     THE CALCULATION IN CBINU WITH N=N-ABS(NZ)
!-----------------------------------------------------------------------
  190 CONTINUE
  NZ = -NZ
  return
end



subroutine ZSHCH (ZR, ZI, CSHR, CSHI, CCHR, CCHI)
!
!! ZSHCH is subsidiary to ZBESH and ZBESK.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CSHCH-A, ZSHCH-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     ZSHCH COMPUTES THE COMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y)
!     AND CCH=COSH(X+I*Y), WHERE I**2=-1.
!
!***SEE ALSO  ZBESH, ZBESK
!***ROUTINES CALLED  (NONE)
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!***END PROLOGUE  ZSHCH
!
  DOUBLE PRECISION CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, ZI, ZR
!***FIRST EXECUTABLE STATEMENT  ZSHCH
  SH = SINH(ZR)
  CH = COSH(ZR)
  SN = SIN(ZI)
  CN = COS(ZI)
  CSHR = SH*CN
  CSHI = CH*SN
  CCHR = CH*CN
  CCHI = SH*SN
  return
end



subroutine ZSQRT (AR, AI, BR, BI)
!
!! ZSQRT is subsidiary to ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZAIRY and ZBIRY.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (ZSQRT-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     DOUBLE PRECISION COMPLEX SQUARE ROOT, B=CSQRT(A)
!
!***SEE ALSO  ZAIRY, ZBESH, ZBESI, ZBESJ, ZBESK, ZBESY, ZBIRY
!***ROUTINES CALLED  ZABS
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!***END PROLOGUE  ZSQRT
  DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DRT
  DOUBLE PRECISION ZABS
  EXTERNAL ZABS
  DATA DRT , DPI / 7.071067811865475244008443621D-1, &
                   3.141592653589793238462643383D+0/
!***FIRST EXECUTABLE STATEMENT  ZSQRT
  ZM = ZABS(AR,AI)
  ZM = SQRT(ZM)
  if (AR == 0.0D+0) go to 10
  if (AI == 0.0D+0) go to 20
  DTHETA = DATAN(AI/AR)
  if (DTHETA <= 0.0D+0) go to 40
  if (AR < 0.0D+0) DTHETA = DTHETA - DPI
  go to 50
   10 if (AI > 0.0D+0) go to 60
  if (AI < 0.0D+0) go to 70
  BR = 0.0D+0
  BI = 0.0D+0
  return
   20 if (AR > 0.0D+0) go to 30
  BR = 0.0D+0
  BI = SQRT(ABS(AR))
  return
   30 BR = SQRT(AR)
  BI = 0.0D+0
  return
   40 if (AR < 0.0D+0) DTHETA = DTHETA + DPI
   50 DTHETA = DTHETA*0.5D+0
  BR = ZM*COS(DTHETA)
  BI = ZM*SIN(DTHETA)
  return
   60 BR = ZM*DRT
  BI = ZM*DRT
  return
   70 BR = ZM*DRT
  BI = -ZM*DRT
  return
end



subroutine ZUCHK (YR, YI, NZ, ASCLE, TOL)
!
!! ZUCHK is subsidiary to SERI, ZUOIK, ZUNK1, ZUNK2, ZUNI1, ZUNI2 and ZKSCL.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CUCHK-A, ZUCHK-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!      Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN
!      EXP(-ALIM)=ASCLE=1.0E+3*D1MACH(1)/TOL. THE TEST IS MADE TO SEE
!      if THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDERFLOW
!      WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED
!      if THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE
!      OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE
!      ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED.
!
!***SEE ALSO  SERI, ZKSCL, ZUNI1, ZUNI2, ZUNK1, ZUNK2, ZUOIK
!***ROUTINES CALLED  (NONE)
!***REVISION HISTORY  (YYMMDD)
!   ??????  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!***END PROLOGUE  ZUCHK
!
!     COMPLEX Y
  DOUBLE PRECISION ASCLE, SS, ST, TOL, WR, WI, YR, YI
  INTEGER NZ
!***FIRST EXECUTABLE STATEMENT  ZUCHK
  NZ = 0
  WR = ABS(YR)
  WI = ABS(YI)
  ST = MIN(WR,WI)
  if (ST > ASCLE) RETURN
  SS = MAX(WR,WI)
  ST = ST/TOL
  if (SS < ST) NZ = 1
  return
end



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



subroutine ZUNI1 (ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, &
     TOL, ELIM, ALIM)
!
!! ZUNI1 is subsidiary to ZBESI and ZBESK.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CUNI1-A, ZUNI1-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     ZUNI1 COMPUTES I(FNU,Z)  BY MEANS OF THE UNIFORM ASYMPTOTIC
!     EXPANSION FOR I(FNU,Z) IN -PI/3 <= ARG Z <= PI/3.
!
!     FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC
!     EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET.
!     NLAST /= 0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER
!     FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1 < FNUL.
!     Y(I)=CZERO FOR I=NLAST+1,N
!
!***SEE ALSO  ZBESI, ZBESK
!***ROUTINES CALLED  D1MACH, ZABS, ZUCHK, ZUNIK, ZUOIK
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!***END PROLOGUE  ZUNI1
!     COMPLEX CFN,CONE,CRSC,CSCL,CSR,CSS,CWRK,CZERO,C1,C2,PHI,RZ,SUM,S1,
!    *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)
  EXTERNAL ZABS
  DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 /
!***FIRST EXECUTABLE STATEMENT  ZUNI1
  NZ = 0
  ND = N
  NLAST = 0
!-----------------------------------------------------------------------
!     COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG-
!     NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE,
!     EXP(ALIM)=EXP(ELIM)*TOL
!-----------------------------------------------------------------------
  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
!-----------------------------------------------------------------------
!     CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER
!-----------------------------------------------------------------------
  FN = MAX(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 == 1) go to 10
  STR = ZR + ZETA2R
  STI = ZI + ZETA2I
  RAST = FN/ZABS(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 (ABS(RS1) > ELIM) go to 130
   30 CONTINUE
  NN = MIN(2,ND)
  DO 80 I=1,NN
    FN = FNU + (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 == 1) go to 40
    STR = ZR + ZETA2R
    STI = ZI + ZETA2I
    RAST = FN/ZABS(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
!-----------------------------------------------------------------------
!     TEST FOR UNDERFLOW AND OVERFLOW
!-----------------------------------------------------------------------
    RS1 = S1R
    if (ABS(RS1) > ELIM) go to 110
    if (I == 1) IFLAG = 2
    if (ABS(RS1) < ALIM) go to 60
!-----------------------------------------------------------------------
!     REFINE  TEST AND SCALE
!-----------------------------------------------------------------------
    APHI = ZABS(PHIR,PHII)
    RS1 = RS1 + LOG(APHI)
    if (ABS(RS1) > ELIM) go to 110
    if (I == 1) IFLAG = 1
    if (RS1 < 0.0D0) go to 60
    if (I == 1) IFLAG = 3
   60   CONTINUE
!-----------------------------------------------------------------------
!     SCALE S1 if ABS(S1) < ASCLE
!-----------------------------------------------------------------------
    S2R = PHIR*SUMR - PHII*SUMI
    S2I = PHIR*SUMI + PHII*SUMR
    STR = EXP(S1R)*CSSR(IFLAG)
    S1R = STR*COS(S1I)
    S1I = STR*SIN(S1I)
    STR = S2R*S1R - S2I*S1I
    S2I = S2R*S1I + S2I*S1R
    S2R = STR
    if (IFLAG /= 1) go to 70
    call ZUCHK(S2R, S2I, NW, BRY(1), TOL)
    if (NW /= 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 <= 2) go to 100
  RAST = 1.0D0/ZABS(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 = 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 >= 3) go to 90
    STR = ABS(C2R)
    STI = ABS(C2I)
    C2M = MAX(STR,STI)
    if (C2M <= 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
!-----------------------------------------------------------------------
!     SET UNDERFLOW AND UPDATE PARAMETERS
!-----------------------------------------------------------------------
  110 CONTINUE
  if (RS1 > 0.0D0) go to 120
  YR(ND) = ZEROR
  YI(ND) = ZEROI
  NZ = NZ + 1
  ND = ND - 1
  if (ND == 0) go to 100
  call ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM)
  if (NUF < 0) go to 120
  ND = ND - NUF
  NZ = NZ + NUF
  if (ND == 0) go to 100
  FN = FNU + (ND-1)
  if (FN >= FNUL) go to 30
  NLAST = ND
  return
  120 CONTINUE
  NZ = -1
  return
  130 CONTINUE
  if (RS1 > 0.0D0) go to 120
  NZ = N
  DO 140 I=1,N
    YR(I) = ZEROR
    YI(I) = ZEROI
  140 CONTINUE
  return
end



subroutine ZUNI2 (ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, &
     TOL, ELIM, ALIM)
!
!! ZUNI2 is subsidiary to ZBESI and ZBESK.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CUNI2-A, ZUNI2-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     ZUNI2 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF
!     UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I
!     OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO.
!
!     FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC
!     EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET.
!     NLAST /= 0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER
!     FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1 < FNUL.
!     Y(I)=CZERO FOR I=NLAST+1,N
!
!***SEE ALSO  ZBESI, ZBESK
!***ROUTINES CALLED  D1MACH, ZABS, ZAIRY, ZUCHK, ZUNHJ, ZUOIK
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!***END PROLOGUE  ZUNI2
!     COMPLEX AI,ARG,ASUM,BSUM,CFN,CI,CID,CIP,CONE,CRSC,CSCL,CSR,CSS,
!    *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)
  EXTERNAL ZABS
  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.57079632679489662D+00,     1.265512123484645396D+00/
!***FIRST EXECUTABLE STATEMENT  ZUNI2
  NZ = 0
  ND = N
  NLAST = 0
!-----------------------------------------------------------------------
!     COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG-
!     NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE,
!     EXP(ALIM)=EXP(ELIM)*TOL
!-----------------------------------------------------------------------
  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
!-----------------------------------------------------------------------
!     ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI
!-----------------------------------------------------------------------
  ZNR = ZI
  ZNI = -ZR
  ZBR = ZR
  ZBI = ZI
  CIDI = -CONER
  INU = FNU
  ANG = HPI*(FNU-INU)
  C2R = COS(ANG)
  C2I = SIN(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 > 0.0D0) go to 10
  ZNR = -ZNR
  ZBI = -ZBI
  CIDI = -CIDI
  C2I = -C2I
   10 CONTINUE
!-----------------------------------------------------------------------
!     CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER
!-----------------------------------------------------------------------
  FN = MAX(FNU,1.0D0)
  call ZUNHJ(ZNR, ZNI, FN, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, &
   ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI)
  if (KODE == 1) go to 20
  STR = ZBR + ZETA2R
  STI = ZBI + ZETA2I
  RAST = FN/ZABS(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 (ABS(RS1) > ELIM) go to 150
   40 CONTINUE
  NN = MIN(2,ND)
  DO 90 I=1,NN
    FN = FNU + (ND-I)
    call ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR, PHII, ARGR, ARGI, &
     ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI)
    if (KODE == 1) go to 50
    STR = ZBR + ZETA2R
    STI = ZBI + ZETA2I
    RAST = FN/ZABS(STR,STI)
    STR = STR*RAST*RAST
    STI = -STI*RAST*RAST
    S1R = -ZETA1R + STR
    S1I = -ZETA1I + STI + ABS(ZI)
    go to 60
   50   CONTINUE
    S1R = -ZETA1R + ZETA2R
    S1I = -ZETA1I + ZETA2I
   60   CONTINUE
!-----------------------------------------------------------------------
!     TEST FOR UNDERFLOW AND OVERFLOW
!-----------------------------------------------------------------------
    RS1 = S1R
    if (ABS(RS1) > ELIM) go to 120
    if (I == 1) IFLAG = 2
    if (ABS(RS1) < ALIM) go to 70
!-----------------------------------------------------------------------
!     REFINE  TEST AND SCALE
!-----------------------------------------------------------------------
!-----------------------------------------------------------------------
    APHI = ZABS(PHIR,PHII)
    AARG = ZABS(ARGR,ARGI)
    RS1 = RS1 + LOG(APHI) - 0.25D0*LOG(AARG) - AIC
    if (ABS(RS1) > ELIM) go to 120
    if (I == 1) IFLAG = 1
    if (RS1 < 0.0D0) go to 70
    if (I == 1) IFLAG = 3
   70   CONTINUE
!-----------------------------------------------------------------------
!     SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR
!     EXPONENT EXTREMES
!-----------------------------------------------------------------------
    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 = EXP(S1R)*CSSR(IFLAG)
    S1R = STR*COS(S1I)
    S1I = STR*SIN(S1I)
    STR = S2R*S1R - S2I*S1I
    S2I = S2R*S1I + S2I*S1R
    S2R = STR
    if (IFLAG /= 1) go to 80
    call ZUCHK(S2R, S2I, NW, BRY(1), TOL)
    if (NW /= 0) go to 120
   80   CONTINUE
    if (ZI <= 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 <= 2) go to 110
  RAZ = 1.0D0/ZABS(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 = 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 >= 3) go to 100
    STR = ABS(C2R)
    STI = ABS(C2I)
    C2M = MAX(STR,STI)
    if (C2M <= 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 > 0.0D0) go to 140
!-----------------------------------------------------------------------
!     SET UNDERFLOW AND UPDATE PARAMETERS
!-----------------------------------------------------------------------
  YR(ND) = ZEROR
  YI(ND) = ZEROI
  NZ = NZ + 1
  ND = ND - 1
  if (ND == 0) go to 110
  call ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM)
  if (NUF < 0) go to 140
  ND = ND - NUF
  NZ = NZ + NUF
  if (ND == 0) go to 110
  FN = FNU + (ND-1)
  if (FN < FNUL) go to 130
!      FN = CIDI
!      J = NUF + 1
!      K = MOD(J,4) + 1
!      S1R = CIPR(K)
!      S1I = CIPI(K)
!      if (FN < 0.0D0) S1I = -S1I
!      STR = C2R*S1R - C2I*S1I
!      C2I = C2R*S1I + C2I*S1R
!      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 <= 0.0D0) C2I = -C2I
  go to 40
  130 CONTINUE
  NLAST = ND
  return
  140 CONTINUE
  NZ = -1
  return
  150 CONTINUE
  if (RS1 > 0.0D0) go to 140
  NZ = N
  DO 160 I=1,N
    YR(I) = ZEROR
    YI(I) = ZEROI
  160 CONTINUE
  return
end



subroutine ZUNIK (ZRR, ZRI, FNU, IKFLG, IPMTR, TOL, INIT, PHIR, &
     PHII, ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI)
!
!! ZUNIK is subsidiary to ZBESI and ZBESK.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CUNIK-A, ZUNIK-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!        ZUNIK COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC
!        EXPANSIONS OF THE I AND K FUNCTIONS ON IKFLG= 1 OR 2
!        RESPECTIVELY BY
!
!        W(FNU,ZR) = PHI*EXP(ZETA)*SUM
!
!        WHERE       ZETA=-ZETA1 + ZETA2       OR
!                          ZETA1 - ZETA2
!
!        THE FIRST call MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE
!        SAME ZR AND FNU WILL RETURN THE I OR K FUNCTION ON IKFLG=
!        1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK
!        ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI,
!        ZETA1,ZETA2.
!
!***SEE ALSO  ZBESI, ZBESK
!***ROUTINES CALLED  D1MACH, ZDIV, ZLOG, ZSQRT
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!   930122  Added EXTERNAL statement with ZLOG and ZSQRT.  (RWC)
!***END PROLOGUE  ZUNIK
!     COMPLEX CFN,CON,CONE,CRFN,CWRK,CZERO,PHI,S,SR,SUM,T,T2,ZETA1,
!    *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)
  EXTERNAL ZLOG, ZSQRT
  DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
  DATA CON(1), CON(2)  / &
   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), &
       C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), &
       C(19), C(20), C(21), C(22), C(23), C(24)/ &
       1.00000000000000000D+00,    -2.08333333333333333D-01, &
       1.25000000000000000D-01,     3.34201388888888889D-01, &
      -4.01041666666666667D-01,     7.03125000000000000D-02, &
      -1.02581259645061728D+00,     1.84646267361111111D+00, &
      -8.91210937500000000D-01,     7.32421875000000000D-02, &
       4.66958442342624743D+00,    -1.12070026162229938D+01, &
       8.78912353515625000D+00,    -2.36408691406250000D+00, &
       1.12152099609375000D-01,    -2.82120725582002449D+01, &
       8.46362176746007346D+01,    -9.18182415432400174D+01, &
       4.25349987453884549D+01,    -7.36879435947963170D+00, &
       2.27108001708984375D-01,     2.12570130039217123D+02, &
      -7.65252468141181642D+02,     1.05999045252799988D+03/
  DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), &
       C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), &
       C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ &
      -6.99579627376132541D+02,     2.18190511744211590D+02, &
      -2.64914304869515555D+01,     5.72501420974731445D-01, &
      -1.91945766231840700D+03,     8.06172218173730938D+03, &
      -1.35865500064341374D+04,     1.16553933368645332D+04, &
      -5.30564697861340311D+03,     1.20090291321635246D+03, &
      -1.08090919788394656D+02,     1.72772750258445740D+00, &
       2.02042913309661486D+04,    -9.69805983886375135D+04, &
       1.92547001232531532D+05,    -2.03400177280415534D+05, &
       1.22200464983017460D+05,    -4.11926549688975513D+04, &
       7.10951430248936372D+03,    -4.93915304773088012D+02, &
       6.07404200127348304D+00,    -2.42919187900551333D+05, &
       1.31176361466297720D+06,    -2.99801591853810675D+06/
  DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), &
       C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), &
       C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ &
       3.76327129765640400D+06,    -2.81356322658653411D+06, &
       1.26836527332162478D+06,    -3.31645172484563578D+05, &
       4.52187689813627263D+04,    -2.49983048181120962D+03, &
       2.43805296995560639D+01,     3.28446985307203782D+06, &
      -1.97068191184322269D+07,     5.09526024926646422D+07, &
      -7.41051482115326577D+07,     6.63445122747290267D+07, &
      -3.75671766607633513D+07,     1.32887671664218183D+07, &
      -2.78561812808645469D+06,     3.08186404612662398D+05, &
      -1.38860897537170405D+04,     1.10017140269246738D+02, &
      -4.93292536645099620D+07,     3.25573074185765749D+08, &
      -9.39462359681578403D+08,     1.55359689957058006D+09, &
      -1.62108055210833708D+09,     1.10684281682301447D+09/
  DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), &
       C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), &
       C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ &
      -4.95889784275030309D+08,     1.42062907797533095D+08, &
      -2.44740627257387285D+07,     2.24376817792244943D+06, &
      -8.40054336030240853D+04,     5.51335896122020586D+02, &
       8.14789096118312115D+08,    -5.86648149205184723D+09, &
       1.86882075092958249D+10,    -3.46320433881587779D+10, &
       4.12801855797539740D+10,    -3.30265997498007231D+10, &
       1.79542137311556001D+10,    -6.56329379261928433D+09, &
       1.55927986487925751D+09,    -2.25105661889415278D+08, &
       1.73951075539781645D+07,    -5.49842327572288687D+05, &
       3.03809051092238427D+03,    -1.46792612476956167D+10, &
       1.14498237732025810D+11,    -3.99096175224466498D+11, &
       8.19218669548577329D+11,    -1.09837515608122331D+12/
  DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), &
       C(105), C(106), C(107), C(108), C(109), C(110), C(111), &
       C(112), C(113), C(114), C(115), C(116), C(117), C(118)/ &
       1.00815810686538209D+12,    -6.45364869245376503D+11, &
       2.87900649906150589D+11,    -8.78670721780232657D+10, &
       1.76347306068349694D+10,    -2.16716498322379509D+09, &
       1.43157876718888981D+08,    -3.87183344257261262D+06, &
       1.82577554742931747D+04,     2.86464035717679043D+11, &
      -2.40629790002850396D+12,     9.10934118523989896D+12, &
      -2.05168994109344374D+13,     3.05651255199353206D+13, &
      -3.16670885847851584D+13,     2.33483640445818409D+13, &
      -1.23204913055982872D+13,     4.61272578084913197D+12, &
      -1.19655288019618160D+12,     2.05914503232410016D+11, &
      -2.18229277575292237D+10,     1.24700929351271032D+09/
  DATA C(119), C(120)/ &
      -2.91883881222208134D+07,     1.18838426256783253D+05/
!***FIRST EXECUTABLE STATEMENT  ZUNIK
  if (INIT /= 0) go to 40
!-----------------------------------------------------------------------
!     INITIALIZE ALL VARIABLES
!-----------------------------------------------------------------------
  RFN = 1.0D0/FNU
!-----------------------------------------------------------------------
!     OVERFLOW TEST (ZR/FNU TOO SMALL)
!-----------------------------------------------------------------------
  TEST = D1MACH(1)*1.0D+3
  AC = FNU*TEST
  if (ABS(ZRR) > AC .OR. ABS(ZRI) > AC) go to 15
  ZETA1R = 2.0D0*ABS(LOG(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 /= 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 = ABS(CWRKR(K)) + ABS(CWRKI(K))
    if (AC < TOL .AND. TEST < TOL) go to 30
   20 CONTINUE
  K = 15
   30 CONTINUE
  INIT = K
   40 CONTINUE
  if (IKFLG == 2) go to 60
!-----------------------------------------------------------------------
!     COMPUTE SUM FOR THE I FUNCTION
!-----------------------------------------------------------------------
  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
!-----------------------------------------------------------------------
!     COMPUTE SUM FOR THE K FUNCTION
!-----------------------------------------------------------------------
  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



subroutine ZUNK1 (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, &
     ALIM)
!
!! ZUNK1 is subsidiary to ZBESK.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CUNK1-A, ZUNK1-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     ZUNK1 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE
!     RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE
!     UNIFORM ASYMPTOTIC EXPANSION.
!     MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION.
!     NZ=-1 MEANS AN OVERFLOW WILL OCCUR
!
!***SEE ALSO  ZBESK
!***ROUTINES CALLED  D1MACH, ZABS, ZS1S2, ZUCHK, ZUNIK
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!***END PROLOGUE  ZUNK1
!     COMPLEX CFN,CK,CONE,CRSC,CS,CSCL,CSGN,CSPN,CSR,CSS,CWRK,CY,CZERO,
!    *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, M
  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)
  EXTERNAL ZABS
  DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 /
  DATA PI / 3.14159265358979324D0 /
!***FIRST EXECUTABLE STATEMENT  ZUNK1
  KDFLG = 1
  NZ = 0
!-----------------------------------------------------------------------
!     EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN
!     THE UNDERFLOW LIMIT
!-----------------------------------------------------------------------
  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 >= 0.0D0) go to 10
  ZRR = -ZR
  ZRI = -ZI
   10 CONTINUE
  J = 2
  DO 70 I=1,N
!-----------------------------------------------------------------------
!     J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J
!-----------------------------------------------------------------------
    J = 3 - J
    FN = FNU + (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 == 1) go to 20
    STR = ZRR + ZETA2R(J)
    STI = ZRI + ZETA2I(J)
    RAST = FN/ZABS(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
!-----------------------------------------------------------------------
!     TEST FOR UNDERFLOW AND OVERFLOW
!-----------------------------------------------------------------------
    if (ABS(RS1) > ELIM) go to 60
    if (KDFLG == 1) KFLAG = 2
    if (ABS(RS1) < ALIM) go to 40
!-----------------------------------------------------------------------
!     REFINE  TEST AND SCALE
!-----------------------------------------------------------------------
    APHI = ZABS(PHIR(J),PHII(J))
    RS1 = RS1 + LOG(APHI)
    if (ABS(RS1) > ELIM) go to 60
    if (KDFLG == 1) KFLAG = 1
    if (RS1 < 0.0D0) go to 40
    if (KDFLG == 1) KFLAG = 3
   40   CONTINUE
!-----------------------------------------------------------------------
!     SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR
!     EXPONENT EXTREMES
!-----------------------------------------------------------------------
    S2R = PHIR(J)*SUMR(J) - PHII(J)*SUMI(J)
    S2I = PHIR(J)*SUMI(J) + PHII(J)*SUMR(J)
    STR = EXP(S1R)*CSSR(KFLAG)
    S1R = STR*COS(S1I)
    S1I = STR*SIN(S1I)
    STR = S2R*S1R - S2I*S1I
    S2I = S1R*S2I + S2R*S1I
    S2R = STR
    if (KFLAG /= 1) go to 50
    call ZUCHK(S2R, S2I, NW, BRY(1), TOL)
    if (NW /= 0) go to 60
   50   CONTINUE
    CYR(KDFLG) = S2R
    CYI(KDFLG) = S2I
    YR(I) = S2R*CSRR(KFLAG)
    YI(I) = S2I*CSRR(KFLAG)
    if (KDFLG == 2) go to 75
    KDFLG = 2
    go to 70
   60   CONTINUE
    if (RS1 > 0.0D0) go to 300
!-----------------------------------------------------------------------
!     FOR ZR < 0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW
!-----------------------------------------------------------------------
    if (ZR < 0.0D0) go to 300
    KDFLG = 1
    YR(I)=ZEROR
    YI(I)=ZEROI
    NZ=NZ+1
    if (I == 1) go to 70
    if ((YR(I-1) == ZEROR).AND.(YI(I-1) == 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(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 < IB) go to 160
!-----------------------------------------------------------------------
!     TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO
!     ON UNDERFLOW.
!-----------------------------------------------------------------------
  FN = FNU + (N-1)
  IPARD = 1
  if (MR /= 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 == 1) go to 80
  STR = ZRR + ZET2DR
  STI = ZRI + ZET2DI
  RAST = FN/ZABS(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 (ABS(RS1) > ELIM) go to 95
  if (ABS(RS1) < ALIM) go to 100
!-----------------------------------------------------------------------
!     REFINE ESTIMATE AND TEST
!-----------------------------------------------------------------------
  APHI = ZABS(PHIDR,PHIDI)
  RS1 = RS1+LOG(APHI)
  if (ABS(RS1) < ELIM) go to 100
   95 CONTINUE
  if (ABS(RS1) > 0.0D0) go to 300
!-----------------------------------------------------------------------
!     FOR ZR < 0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW
!-----------------------------------------------------------------------
  if (ZR < 0.0D0) go to 300
  NZ = N
  DO 96 I=1,N
    YR(I) = ZEROR
    YI(I) = ZEROI
   96 CONTINUE
  return
!-----------------------------------------------------------------------
!     FORWARD RECUR FOR REMAINDER OF THE SEQUENCE
!-----------------------------------------------------------------------
  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 >= 3) go to 120
    STR = ABS(C2R)
    STI = ABS(C2I)
    C2M = MAX(STR,STI)
    if (C2M <= 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 == 0) RETURN
!-----------------------------------------------------------------------
!     ANALYTIC CONTINUATION FOR RE(Z) < 0.0D0
!-----------------------------------------------------------------------
  NZ = 0
  FMR = MR
  SGN = -DSIGN(PI,FMR)
!-----------------------------------------------------------------------
!     CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP.
!-----------------------------------------------------------------------
  CSGNI = SGN
  INU = FNU
  FNF = FNU - INU
  IFN = INU + N - 1
  ANG = FNF*SGN
  CSPNR = COS(ANG)
  CSPNI = SIN(ANG)
  if (MOD(IFN,2) == 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 + (KK-1)
!-----------------------------------------------------------------------
!     LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K
!     FUNCTION ABOVE
!-----------------------------------------------------------------------
    M=3
    if (N > 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 == N).AND.(IB < N)) go to 180
    if ((KK == IB).OR.(KK == 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 == 1) go to 200
    STR = ZRR + ZET2DR
    STI = ZRI + ZET2DI
    RAST = FN/ZABS(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
!-----------------------------------------------------------------------
!     TEST FOR UNDERFLOW AND OVERFLOW
!-----------------------------------------------------------------------
    RS1 = S1R
    if (ABS(RS1) > ELIM) go to 260
    if (KDFLG == 1) IFLAG = 2
    if (ABS(RS1) < ALIM) go to 220
!-----------------------------------------------------------------------
!     REFINE  TEST AND SCALE
!-----------------------------------------------------------------------
    APHI = ZABS(PHIDR,PHIDI)
    RS1 = RS1 + LOG(APHI)
    if (ABS(RS1) > ELIM) go to 260
    if (KDFLG == 1) IFLAG = 1
    if (RS1 < 0.0D0) go to 220
    if (KDFLG == 1) IFLAG = 3
  220   CONTINUE
    STR = PHIDR*SUMDR - PHIDI*SUMDI
    STI = PHIDR*SUMDI + PHIDI*SUMDR
    S2R = -CSGNI*STI
    S2I = CSGNI*STR
    STR = EXP(S1R)*CSSR(IFLAG)
    S1R = STR*COS(S1I)
    S1I = STR*SIN(S1I)
    STR = S2R*S1R - S2I*S1I
    S2I = S2R*S1I + S2I*S1R
    S2R = STR
    if (IFLAG /= 1) go to 230
    call ZUCHK(S2R, S2I, NW, BRY(1), TOL)
    if (NW == 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)
!-----------------------------------------------------------------------
!     ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N
!-----------------------------------------------------------------------
    S1R = YR(KK)
    S1I = YI(KK)
    if (KODE == 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 /= 0.0D0 .OR. C2I /= 0.0D0) go to 255
    KDFLG = 1
    go to 270
  255   CONTINUE
    if (KDFLG == 2) go to 275
    KDFLG = 2
    go to 270
  260   CONTINUE
    if (RS1 > 0.0D0) go to 300
    S2R = ZEROR
    S2I = ZEROI
    go to 230
  270 CONTINUE
  K = N
  275 CONTINUE
  IL = N - K
  if (IL == 0) RETURN
!-----------------------------------------------------------------------
!     RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE
!     K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP
!     INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES.
!-----------------------------------------------------------------------
  S1R = CYR(1)
  S1I = CYI(1)
  S2R = CYR(2)
  S2I = CYI(2)
  CSR = CSRR(IFLAG)
  ASCLE = BRY(IFLAG)
  FN = 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 == 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 >= 3) go to 290
    C2R = ABS(CKR)
    C2I = ABS(CKI)
    C2M = MAX(C2R,C2I)
    if (C2M <= 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



subroutine ZUNK2 (ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, &
     ALIM)
!
!! ZUNK2 is subsidiary to ZBESK.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CUNK2-A, ZUNK2-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     ZUNK2 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE
!     RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE
!     UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN)
!     WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR
!     -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z if Z IS IN THE RIGHT
!     HALF PLANE OR ZR=-Z if Z IS IN THE LEFT HALF PLANE. MR INDIC-
!     ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION.
!     NZ=-1 MEANS AN OVERFLOW WILL OCCUR
!
!***SEE ALSO  ZBESK
!***ROUTINES CALLED  D1MACH, ZABS, ZAIRY, ZS1S2, ZUCHK, ZUNHJ
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!***END PROLOGUE  ZUNK2
!     COMPLEX AI,ARG,ARGD,ASUM,ASUMD,BSUM,BSUMD,CFN,CI,CIP,CK,CONE,CRSC,
!    *CR1,CR2,CS,CSCL,CSGN,CSPN,CSR,CSS,CY,CZERO,C1,C2,DAI,PHI,PHID,RZ,
!    *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)
  EXTERNAL ZABS
  DATA ZEROR,ZEROI,CONER,CR1R,CR1I,CR2R,CR2I / &
           0.0D0, 0.0D0, 1.0D0, &
   1.0D0,1.73205080756887729D0 , -0.5D0,-8.66025403784438647D-01 /
  DATA HPI, PI, AIC / &
       1.57079632679489662D+00,     3.14159265358979324D+00, &
       1.26551212348464539D+00/
  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 /
!***FIRST EXECUTABLE STATEMENT  ZUNK2
  KDFLG = 1
  NZ = 0
!-----------------------------------------------------------------------
!     EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN
!     THE UNDERFLOW LIMIT
!-----------------------------------------------------------------------
  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 >= 0.0D0) go to 10
  ZRR = -ZR
  ZRI = -ZI
   10 CONTINUE
  YY = ZRI
  ZNR = ZRI
  ZNI = -ZRR
  ZBR = ZRR
  ZBI = ZRI
  INU = FNU
  FNF = FNU - INU
  ANG = -HPI*FNF
  CAR = COS(ANG)
  SAR = SIN(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 > 0.0D0) go to 20
  ZNR = -ZNR
  ZBI = -ZBI
   20 CONTINUE
!-----------------------------------------------------------------------
!     K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST
!     QUADRANT. FOURTH QUADRANT VALUES (YY <= 0.0E0) ARE COMPUTED BY
!     CONJUGATION SINCE THE K FUNCTION IS REAL ON THE POSITIVE REAL AXIS
!-----------------------------------------------------------------------
  J = 2
  DO 80 I=1,N
!-----------------------------------------------------------------------
!     J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J
!-----------------------------------------------------------------------
    J = 3 - J
    FN = FNU + (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 == 1) go to 30
    STR = ZBR + ZETA2R(J)
    STI = ZBI + ZETA2I(J)
    RAST = FN/ZABS(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
!-----------------------------------------------------------------------
!     TEST FOR UNDERFLOW AND OVERFLOW
!-----------------------------------------------------------------------
    RS1 = S1R
    if (ABS(RS1) > ELIM) go to 70
    if (KDFLG == 1) KFLAG = 2
    if (ABS(RS1) < ALIM) go to 50
!-----------------------------------------------------------------------
!     REFINE  TEST AND SCALE
!-----------------------------------------------------------------------
    APHI = ZABS(PHIR(J),PHII(J))
    AARG = ZABS(ARGR(J),ARGI(J))
    RS1 = RS1 + LOG(APHI) - 0.25D0*LOG(AARG) - AIC
    if (ABS(RS1) > ELIM) go to 70
    if (KDFLG == 1) KFLAG = 1
    if (RS1 < 0.0D0) go to 50
    if (KDFLG == 1) KFLAG = 3
   50   CONTINUE
!-----------------------------------------------------------------------
!     SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR
!     EXPONENT EXTREMES
!-----------------------------------------------------------------------
    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 = EXP(S1R)*CSSR(KFLAG)
    S1R = STR*COS(S1I)
    S1I = STR*SIN(S1I)
    STR = S2R*S1R - S2I*S1I
    S2I = S1R*S2I + S2R*S1I
    S2R = STR
    if (KFLAG /= 1) go to 60
    call ZUCHK(S2R, S2I, NW, BRY(1), TOL)
    if (NW /= 0) go to 70
   60   CONTINUE
    if (YY <= 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 == 2) go to 85
    KDFLG = 2
    go to 80
   70   CONTINUE
    if (RS1 > 0.0D0) go to 320
!-----------------------------------------------------------------------
!     FOR ZR < 0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW
!-----------------------------------------------------------------------
    if (ZR < 0.0D0) go to 320
    KDFLG = 1
    YR(I)=ZEROR
    YI(I)=ZEROI
    NZ=NZ+1
    STR = CSI
    CSI =-CSR
    CSR = STR
    if (I == 1) go to 80
    if ((YR(I-1) == ZEROR).AND.(YI(I-1) == 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(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 < IB) go to 180
!-----------------------------------------------------------------------
!     TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO
!     ON UNDERFLOW.
!-----------------------------------------------------------------------
  FN = FNU + (N-1)
  IPARD = 1
  if (MR /= 0) IPARD = 0
  call ZUNHJ(ZNR, ZNI, FN, IPARD, TOL, PHIDR, PHIDI, ARGDR, ARGDI, &
   ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR, ASUMDI, BSUMDR, BSUMDI)
  if (KODE == 1) go to 90
  STR = ZBR + ZET2DR
  STI = ZBI + ZET2DI
  RAST = FN/ZABS(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 (ABS(RS1) > ELIM) go to 105
  if (ABS(RS1) < ALIM) go to 120
!-----------------------------------------------------------------------
!     REFINE ESTIMATE AND TEST
!-----------------------------------------------------------------------
  APHI = ZABS(PHIDR,PHIDI)
  RS1 = RS1+LOG(APHI)
  if (ABS(RS1) < ELIM) go to 120
  105 CONTINUE
  if (RS1 > 0.0D0) go to 320
!-----------------------------------------------------------------------
!     FOR ZR < 0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW
!-----------------------------------------------------------------------
  if (ZR < 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 >= 3) go to 130
    STR = ABS(C2R)
    STI = ABS(C2I)
    C2M = MAX(STR,STI)
    if (C2M <= 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 == 0) RETURN
!-----------------------------------------------------------------------
!     ANALYTIC CONTINUATION FOR RE(Z) < 0.0D0
!-----------------------------------------------------------------------
  NZ = 0
  FMR = MR
  SGN = -DSIGN(PI,FMR)
!-----------------------------------------------------------------------
!     CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP.
!-----------------------------------------------------------------------
  CSGNI = SGN
  if (YY <= 0.0D0) CSGNI = -CSGNI
  IFN = INU + N - 1
  ANG = FNF*SGN
  CSPNR = COS(ANG)
  CSPNI = SIN(ANG)
  if (MOD(IFN,2) == 0) go to 190
  CSPNR = -CSPNR
  CSPNI = -CSPNI
  190 CONTINUE
!-----------------------------------------------------------------------
!     CS=COEFF OF THE J FUNCTION TO GET THE I FUNCTION. I(FNU,Z) IS
!     COMPUTED FROM EXP(I*FNU*HPI)*J(FNU,-I*Z) WHERE Z IS IN THE FIRST
!     QUADRANT. FOURTH QUADRANT VALUES (YY <= 0.0E0) ARE COMPUTED BY
!     CONJUGATION SINCE THE I FUNCTION IS REAL ON THE POSITIVE REAL AXIS
!-----------------------------------------------------------------------
  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 + (KK-1)
!-----------------------------------------------------------------------
!     LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K
!     FUNCTION ABOVE
!-----------------------------------------------------------------------
    if (N > 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 == N).AND.(IB < N)) go to 210
    if ((KK == IB).OR.(KK == 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 == 1) go to 220
    STR = ZBR + ZET2DR
    STI = ZBI + ZET2DI
    RAST = FN/ZABS(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
!-----------------------------------------------------------------------
!     TEST FOR UNDERFLOW AND OVERFLOW
!-----------------------------------------------------------------------
    RS1 = S1R
    if (ABS(RS1) > ELIM) go to 280
    if (KDFLG == 1) IFLAG = 2
    if (ABS(RS1) < ALIM) go to 240
!-----------------------------------------------------------------------
!     REFINE  TEST AND SCALE
!-----------------------------------------------------------------------
    APHI = ZABS(PHIDR,PHIDI)
    AARG = ZABS(ARGDR,ARGDI)
    RS1 = RS1 + LOG(APHI) - 0.25D0*LOG(AARG) - AIC
    if (ABS(RS1) > ELIM) go to 280
    if (KDFLG == 1) IFLAG = 1
    if (RS1 < 0.0D0) go to 240
    if (KDFLG == 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 = EXP(S1R)*CSSR(IFLAG)
    S1R = STR*COS(S1I)
    S1I = STR*SIN(S1I)
    STR = S2R*S1R - S2I*S1I
    S2I = S2R*S1I + S2I*S1R
    S2R = STR
    if (IFLAG /= 1) go to 250
    call ZUCHK(S2R, S2I, NW, BRY(1), TOL)
    if (NW == 0) go to 250
    S2R = ZEROR
    S2I = ZEROI
  250   CONTINUE
    if (YY <= 0.0D0) S2I = -S2I
    CYR(KDFLG) = S2R
    CYI(KDFLG) = S2I
    C2R = S2R
    C2I = S2I
    S2R = S2R*CSRR(IFLAG)
    S2I = S2I*CSRR(IFLAG)
!-----------------------------------------------------------------------
!     ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N
!-----------------------------------------------------------------------
    S1R = YR(KK)
    S1I = YI(KK)
    if (KODE == 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 /= 0.0D0 .OR. C2I /= 0.0D0) go to 255
    KDFLG = 1
    go to 290
  255   CONTINUE
    if (KDFLG == 2) go to 295
    KDFLG = 2
    go to 290
  280   CONTINUE
    if (RS1 > 0.0D0) go to 320
    S2R = ZEROR
    S2I = ZEROI
    go to 250
  290 CONTINUE
  K = N
  295 CONTINUE
  IL = N - K
  if (IL == 0) RETURN
!-----------------------------------------------------------------------
!     RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE
!     K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP
!     INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES.
!-----------------------------------------------------------------------
  S1R = CYR(1)
  S1I = CYI(1)
  S2R = CYR(2)
  S2I = CYI(2)
  CSR = CSRR(IFLAG)
  ASCLE = BRY(IFLAG)
  FN = 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 == 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 >= 3) go to 310
    C2R = ABS(CKR)
    C2I = ABS(CKI)
    C2M = MAX(C2R,C2I)
    if (C2M <= 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



subroutine ZUOIK (ZR, ZI, FNU, KODE, IKFLG, N, YR, YI, NUF, TOL, &
     ELIM, ALIM)
!
!! ZUOIK is subsidiary to ZBESH, ZBESI and ZBESK.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CUOIK-A, ZUOIK-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     ZUOIK COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC
!     EXPANSIONS FOR THE I AND K FUNCTIONS AND COMPARES THEM
!     (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW
!     WHERE ALIM < ELIM. if THE MAGNITUDE, BASED ON THE LEADING
!     EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN
!     THE RESULT IS ON SCALE. if NOT, THEN A REFINED TEST USING OTHER
!     MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE
!     EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)=
!     EXP(-ELIM)/TOL
!
!     IKFLG=1 MEANS THE I SEQUENCE IS TESTED
!          =2 MEANS THE K SEQUENCE IS TESTED
!     NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE
!         =-1 MEANS AN OVERFLOW WOULD OCCUR
!     IKFLG=1 AND NUF > 0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO
!             THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE
!     IKFLG=2 AND NUF == N MEANS ALL Y VALUES WERE SET TO ZERO
!     IKFLG=2 AND 0 < NUF < N NOT CONSIDERED. Y MUST BE SET BY
!             ANOTHER ROUTINE
!
!***SEE ALSO  ZBESH, ZBESI, ZBESK
!***ROUTINES CALLED  D1MACH, ZABS, ZLOG, ZUCHK, ZUNHJ, ZUNIK
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!   930122  Added ZLOG to EXTERNAL statement.  (RWC)
!***END PROLOGUE  ZUOIK
!     COMPLEX ARG,ASUM,BSUM,CWRK,CZ,CZERO,PHI,SUM,Y,Z,ZB,ZETA1,ZETA2,ZN,
!    *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)
  EXTERNAL ZABS, ZLOG
  DATA ZEROR,ZEROI / 0.0D0, 0.0D0 /
  DATA AIC / 1.265512123484645396D+00 /
!***FIRST EXECUTABLE STATEMENT  ZUOIK
  NUF = 0
  NN = N
  ZRR = ZR
  ZRI = ZI
  if (ZR >= 0.0D0) go to 10
  ZRR = -ZR
  ZRI = -ZI
   10 CONTINUE
  ZBR = ZRR
  ZBI = ZRI
  AX = ABS(ZR)*1.7321D0
  AY = ABS(ZI)
  IFORM = 1
  if (AY > AX) IFORM = 2
  GNU = MAX(FNU,1.0D0)
  if (IKFLG == 1) go to 20
  FNN = NN
  GNN = FNU + FNN - 1.0D0
  GNU = MAX(GNN,FNN)
   20 CONTINUE
!-----------------------------------------------------------------------
!     ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE
!     REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET
!     THE SIGN OF THE IMAGINARY PART CORRECT.
!-----------------------------------------------------------------------
  if (IFORM == 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 > 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(ARGR,ARGI)
   50 CONTINUE
  if (KODE == 1) go to 60
  CZR = CZR - ZBR
  CZI = CZI - ZBI
   60 CONTINUE
  if (IKFLG == 1) go to 70
  CZR = -CZR
  CZI = -CZI
   70 CONTINUE
  APHI = ZABS(PHIR,PHII)
  RCZ = CZR
!-----------------------------------------------------------------------
!     OVERFLOW TEST
!-----------------------------------------------------------------------
  if (RCZ > ELIM) go to 210
  if (RCZ < ALIM) go to 80
  RCZ = RCZ + LOG(APHI)
  if (IFORM == 2) RCZ = RCZ - 0.25D0*LOG(AARG) - AIC
  if (RCZ > ELIM) go to 210
  go to 130
   80 CONTINUE
!-----------------------------------------------------------------------
!     UNDERFLOW TEST
!-----------------------------------------------------------------------
  if (RCZ < (-ELIM)) go to 90
  if (RCZ > (-ALIM)) go to 130
  RCZ = RCZ + LOG(APHI)
  if (IFORM == 2) RCZ = RCZ - 0.25D0*LOG(AARG) - AIC
  if (RCZ > (-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 == 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 = EXP(RCZ)/TOL
  AY = CZI
  CZR = AX*COS(AY)
  CZI = AX*SIN(AY)
  call ZUCHK(CZR, CZI, NW, ASCLE, TOL)
  if (NW /= 0) go to 90
  130 CONTINUE
  if (IKFLG == 2) RETURN
  if (N == 1) RETURN
!-----------------------------------------------------------------------
!     SET UNDERFLOWS ON I SEQUENCE
!-----------------------------------------------------------------------
  140 CONTINUE
  GNU = FNU + (NN-1)
  if (IFORM == 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(ARGR,ARGI)
  160 CONTINUE
  if (KODE == 1) go to 170
  CZR = CZR - ZBR
  CZI = CZI - ZBI
  170 CONTINUE
  APHI = ZABS(PHIR,PHII)
  RCZ = CZR
  if (RCZ < (-ELIM)) go to 180
  if (RCZ > (-ALIM)) RETURN
  RCZ = RCZ + LOG(APHI)
  if (IFORM == 2) RCZ = RCZ - 0.25D0*LOG(AARG) - AIC
  if (RCZ > (-ELIM)) go to 190
  180 CONTINUE
  YR(NN) = ZEROR
  YI(NN) = ZEROI
  NN = NN - 1
  NUF = NUF + 1
  if (NN == 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 == 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 = EXP(RCZ)/TOL
  AY = CZI
  CZR = AX*COS(AY)
  CZI = AX*SIN(AY)
  call ZUCHK(CZR, CZI, NW, ASCLE, TOL)
  if (NW /= 0) go to 180
  return
  210 CONTINUE
  NUF = -1
  return
end



subroutine ZWRSK (ZRR, ZRI, FNU, KODE, N, YR, YI, NZ, CWR, CWI, &
     TOL, ELIM, ALIM)
!
!! ZWRSK is subsidiary to ZBESI and ZBESK.
!
!***LIBRARY   SLATEC
!***TYPE      ALL (CWRSK-A, ZWRSK-A)
!***AUTHOR  Amos, D. E., (SNL)
!***DESCRIPTION
!
!     ZWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z) >= 0.0 BY
!     NORMALIZING THE I FUNCTION RATIOS FROM ZRATI BY THE WRONSKIAN
!
!***SEE ALSO  ZBESI, ZBESK
!***ROUTINES CALLED  D1MACH, ZABS, ZBKNU, ZRATI
!***REVISION HISTORY  (YYMMDD)
!   830501  DATE WRITTEN
!   910415  Prologue converted to Version 4.0 format.  (BAB)
!***END PROLOGUE  ZWRSK
!     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)
  EXTERNAL ZABS
!***FIRST EXECUTABLE STATEMENT  ZWRSK
!-----------------------------------------------------------------------
!     I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS
!     Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM CRATI NORMALIZED BY THE
!     WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM CBKNU.
!-----------------------------------------------------------------------
!
  NZ = 0
  call ZBKNU(ZRR, ZRI, FNU, KODE, 2, CWR, CWI, NW, TOL, ELIM, ALIM)
  if (NW /= 0) go to 50
  call ZRATI(ZRR, ZRI, FNU, N, YR, YI, TOL)
!-----------------------------------------------------------------------
!     RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z),
!     R(FNU+J-1,Z)=Y(J),  J=1,...,N
!-----------------------------------------------------------------------
  CINUR = 1.0D0
  CINUI = 0.0D0
  if (KODE == 1) go to 10
  CINUR = COS(ZRI)
  CINUI = SIN(ZRI)
   10 CONTINUE
!-----------------------------------------------------------------------
!     ON LOW EXPONENT MACHINES THE K FUNCTIONS CAN BE CLOSE TO BOTH
!     THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE
!     SCALED TO PREVENT OVER OR UNDERFLOW. CUOIK HAS DETERMINED THAT
!     THE RESULT IS ON SCALE.
!-----------------------------------------------------------------------
  ACW = ZABS(CWR(2),CWI(2))
  ASCLE = 1.0D+3*D1MACH(1)/TOL
  CSCLR = 1.0D0
  if (ACW > ASCLE) go to 20
  CSCLR = 1.0D0/TOL
  go to 30
   20 CONTINUE
  ASCLE = 1.0D0/ASCLE
  if (ACW < 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)
!-----------------------------------------------------------------------
!     CINU=CINU*(CONJG(CT)/ABS(CT))*(1.0D0/ABS(CT) PREVENTS
!     UNDER- OR OVERFLOW PREMATURELY BY SQUARING ABS(CT)
!-----------------------------------------------------------------------
  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(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 == 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 == (-2)) NZ=-2
  return
end
