Add AMOS routines from netlib
Former-commit-id: c6fe0e468937daa36fe5f6692af5d24d4df3f851
This commit is contained in:
Marek Nečada
parent
31bab5225f
commit
94259e766b
|
|
@ -0,0 +1,427 @@
|
|||
*DECK D1MACH
|
||||
DOUBLE PRECISION FUNCTION D1MACH(I)
|
||||
C***BEGIN PROLOGUE D1MACH
|
||||
C***DATE WRITTEN 750101 (YYMMDD)
|
||||
C***REVISION DATE 890213 (YYMMDD)
|
||||
C***CATEGORY NO. R1
|
||||
C***KEYWORDS LIBRARY=SLATEC,TYPE=DOUBLE PRECISION(R1MACH-S D1MACH-D),
|
||||
C MACHINE CONSTANTS
|
||||
C***AUTHOR FOX, P. A., (BELL LABS)
|
||||
C HALL, A. D., (BELL LABS)
|
||||
C SCHRYER, N. L., (BELL LABS)
|
||||
C***PURPOSE Returns double precision machine dependent constants
|
||||
C***DESCRIPTION
|
||||
C
|
||||
C D1MACH can be used to obtain machine-dependent parameters
|
||||
C for the local machine environment. It is a function
|
||||
C subprogram with one (input) argument, and can be called
|
||||
C as follows, for example
|
||||
C
|
||||
C D = D1MACH(I)
|
||||
C
|
||||
C where I=1,...,5. The (output) value of D above is
|
||||
C determined by the (input) value of I. The results for
|
||||
C various values of I are discussed below.
|
||||
C
|
||||
C D1MACH( 1) = B**(EMIN-1), the smallest positive magnitude.
|
||||
C D1MACH( 2) = B**EMAX*(1 - B**(-T)), the largest magnitude.
|
||||
C D1MACH( 3) = B**(-T), the smallest relative spacing.
|
||||
C D1MACH( 4) = B**(1-T), the largest relative spacing.
|
||||
C D1MACH( 5) = LOG10(B)
|
||||
C
|
||||
C Assume double precision numbers are represented in the T-digit,
|
||||
C base-B form
|
||||
C
|
||||
C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
|
||||
C
|
||||
C where 0 .LE. X(I) .LT. B for I=1,...,T, 0 .LT. X(1), and
|
||||
C EMIN .LE. E .LE. EMAX.
|
||||
C
|
||||
C The values of B, T, EMIN and EMAX are provided in I1MACH as
|
||||
C follows:
|
||||
C I1MACH(10) = B, the base.
|
||||
C I1MACH(14) = T, the number of base-B digits.
|
||||
C I1MACH(15) = EMIN, the smallest exponent E.
|
||||
C I1MACH(16) = EMAX, the largest exponent E.
|
||||
C
|
||||
C To alter this function for a particular environment,
|
||||
C the desired set of DATA statements should be activated by
|
||||
C removing the C from column 1. Also, the values of
|
||||
C D1MACH(1) - D1MACH(4) should be checked for consistency
|
||||
C with the local operating system.
|
||||
C
|
||||
C***REFERENCES FOX P.A., HALL A.D., SCHRYER N.L.,*FRAMEWORK FOR A
|
||||
C PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHEMATICAL
|
||||
C SOFTWARE, VOL. 4, NO. 2, JUNE 1978, PP. 177-188.
|
||||
C***ROUTINES CALLED XERROR
|
||||
C***END PROLOGUE D1MACH
|
||||
C
|
||||
INTEGER SMALL(4)
|
||||
INTEGER LARGE(4)
|
||||
INTEGER RIGHT(4)
|
||||
INTEGER DIVER(4)
|
||||
INTEGER LOG10(4)
|
||||
C
|
||||
DOUBLE PRECISION DMACH(5)
|
||||
SAVE DMACH
|
||||
C
|
||||
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))
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE AMIGA
|
||||
C ABSOFT FORTRAN COMPILER USING THE 68020/68881 COMPILER OPTION
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' /
|
||||
C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' /
|
||||
C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' /
|
||||
C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' /
|
||||
C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE AMIGA
|
||||
C ABSOFT FORTRAN COMPILER USING SOFTWARE FLOATING POINT
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' /
|
||||
C DATA LARGE(1), LARGE(2) / Z'7FDFFFFF', Z'FFFFFFFF' /
|
||||
C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' /
|
||||
C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' /
|
||||
C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE APOLLO
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / 16#00100000, 16#00000000 /
|
||||
C DATA LARGE(1), LARGE(2) / 16#7FFFFFFF, 16#FFFFFFFF /
|
||||
C DATA RIGHT(1), RIGHT(2) / 16#3CA00000, 16#00000000 /
|
||||
C DATA DIVER(1), DIVER(2) / 16#3CB00000, 16#00000000 /
|
||||
C DATA LOG10(1), LOG10(2) / 16#3FD34413, 16#509F79FF /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM
|
||||
C
|
||||
C DATA SMALL(1) / ZC00800000 /
|
||||
C DATA SMALL(2) / Z000000000 /
|
||||
C DATA LARGE(1) / ZDFFFFFFFF /
|
||||
C DATA LARGE(2) / ZFFFFFFFFF /
|
||||
C DATA RIGHT(1) / ZCC5800000 /
|
||||
C DATA RIGHT(2) / Z000000000 /
|
||||
C DATA DIVER(1) / ZCC6800000 /
|
||||
C DATA DIVER(2) / Z000000000 /
|
||||
C DATA LOG10(1) / ZD00E730E7 /
|
||||
C DATA LOG10(2) / ZC77800DC0 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM
|
||||
C
|
||||
C DATA SMALL(1) / O1771000000000000 /
|
||||
C DATA SMALL(2) / O0000000000000000 /
|
||||
C DATA LARGE(1) / O0777777777777777 /
|
||||
C DATA LARGE(2) / O0007777777777777 /
|
||||
C DATA RIGHT(1) / O1461000000000000 /
|
||||
C DATA RIGHT(2) / O0000000000000000 /
|
||||
C DATA DIVER(1) / O1451000000000000 /
|
||||
C DATA DIVER(2) / O0000000000000000 /
|
||||
C DATA LOG10(1) / O1157163034761674 /
|
||||
C DATA LOG10(2) / O0006677466732724 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS
|
||||
C
|
||||
C DATA SMALL(1) / O1771000000000000 /
|
||||
C DATA SMALL(2) / O7770000000000000 /
|
||||
C DATA LARGE(1) / O0777777777777777 /
|
||||
C DATA LARGE(2) / O7777777777777777 /
|
||||
C DATA RIGHT(1) / O1461000000000000 /
|
||||
C DATA RIGHT(2) / O0000000000000000 /
|
||||
C DATA DIVER(1) / O1451000000000000 /
|
||||
C DATA DIVER(2) / O0000000000000000 /
|
||||
C DATA LOG10(1) / O1157163034761674 /
|
||||
C DATA LOG10(2) / O0006677466732724 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE
|
||||
C
|
||||
C DATA SMALL(1) / Z"3001800000000000" /
|
||||
C DATA SMALL(2) / Z"3001000000000000" /
|
||||
C DATA LARGE(1) / Z"4FFEFFFFFFFFFFFE" /
|
||||
C DATA LARGE(2) / Z"4FFE000000000000" /
|
||||
C DATA RIGHT(1) / Z"3FD2800000000000" /
|
||||
C DATA RIGHT(2) / Z"3FD2000000000000" /
|
||||
C DATA DIVER(1) / Z"3FD3800000000000" /
|
||||
C DATA DIVER(2) / Z"3FD3000000000000" /
|
||||
C DATA LOG10(1) / Z"3FFF9A209A84FBCF" /
|
||||
C DATA LOG10(2) / Z"3FFFF7988F8959AC" /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES
|
||||
C
|
||||
C DATA SMALL(1) / 00564000000000000000B /
|
||||
C DATA SMALL(2) / 00000000000000000000B /
|
||||
C DATA LARGE(1) / 37757777777777777777B /
|
||||
C DATA LARGE(2) / 37157777777777777777B /
|
||||
C DATA RIGHT(1) / 15624000000000000000B /
|
||||
C DATA RIGHT(2) / 00000000000000000000B /
|
||||
C DATA DIVER(1) / 15634000000000000000B /
|
||||
C DATA DIVER(2) / 00000000000000000000B /
|
||||
C DATA LOG10(1) / 17164642023241175717B /
|
||||
C DATA LOG10(2) / 16367571421742254654B /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE CELERITY C1260
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' /
|
||||
C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' /
|
||||
C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' /
|
||||
C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' /
|
||||
C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE CONVEX C-1
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X /
|
||||
C DATA LARGE(1), LARGE(2) / '7FFFFFFF'X,'FFFFFFFF'X /
|
||||
C DATA RIGHT(1), RIGHT(2) / '3CC00000'X,'00000000'X /
|
||||
C DATA DIVER(1), DIVER(2) / '3CD00000'X,'00000000'X /
|
||||
C DATA LOG10(1), LOG10(2) / '3FF34413'X,'509F79FF'X /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE CRAY-1
|
||||
C
|
||||
C DATA SMALL(1) / 201354000000000000000B /
|
||||
C DATA SMALL(2) / 000000000000000000000B /
|
||||
C DATA LARGE(1) / 577767777777777777777B /
|
||||
C DATA LARGE(2) / 000007777777777777774B /
|
||||
C DATA RIGHT(1) / 376434000000000000000B /
|
||||
C DATA RIGHT(2) / 000000000000000000000B /
|
||||
C DATA DIVER(1) / 376444000000000000000B /
|
||||
C DATA DIVER(2) / 000000000000000000000B /
|
||||
C DATA LOG10(1) / 377774642023241175717B /
|
||||
C DATA LOG10(2) / 000007571421742254654B /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
|
||||
C
|
||||
C NOTE - IT MAY BE APPROPRIATE TO INCLUDE THE FOLLOWING CARD -
|
||||
C STATIC DMACH(5)
|
||||
C
|
||||
C DATA SMALL / 20K, 3*0 /
|
||||
C DATA LARGE / 77777K, 3*177777K /
|
||||
C DATA RIGHT / 31420K, 3*0 /
|
||||
C DATA DIVER / 32020K, 3*0 /
|
||||
C DATA LOG10 / 40423K, 42023K, 50237K, 74776K /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE ELXSI 6400
|
||||
C (ASSUMING REAL*8 IS THE DEFAULT DOUBLE PRECISION)
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / '00100000'X,'00000000'X /
|
||||
C DATA LARGE(1), LARGE(2) / '7FEFFFFF'X,'FFFFFFFF'X /
|
||||
C DATA RIGHT(1), RIGHT(2) / '3CB00000'X,'00000000'X /
|
||||
C DATA DIVER(1), DIVER(2) / '3CC00000'X,'00000000'X /
|
||||
C DATA LOG10(1), LOG10(2) / '3FD34413'X,'509F79FF'X /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE HARRIS 220
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / '20000000, '00000201 /
|
||||
C DATA LARGE(1), LARGE(2) / '37777777, '37777577 /
|
||||
C DATA RIGHT(1), RIGHT(2) / '20000000, '00000333 /
|
||||
C DATA DIVER(1), DIVER(2) / '20000000, '00000334 /
|
||||
C DATA LOG10(1), LOG10(2) / '23210115, '10237777 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / O402400000000, O000000000000 /
|
||||
C DATA LARGE(1), LARGE(2) / O376777777777, O777777777777 /
|
||||
C DATA RIGHT(1), RIGHT(2) / O604400000000, O000000000000 /
|
||||
C DATA DIVER(1), DIVER(2) / O606400000000, O000000000000 /
|
||||
C DATA LOG10(1), LOG10(2) / O776464202324, O117571775714 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE HP 2100
|
||||
C THREE WORD DOUBLE PRECISION OPTION WITH FTN4
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2), SMALL(3) / 40000B, 0, 1 /
|
||||
C DATA LARGE(1), LARGE(2), LARGE(3) / 77777B, 177777B, 177776B /
|
||||
C DATA RIGHT(1), RIGHT(2), RIGHT(3) / 40000B, 0, 265B /
|
||||
C DATA DIVER(1), DIVER(2), DIVER(3) / 40000B, 0, 276B /
|
||||
C DATA LOG10(1), LOG10(2), LOG10(3) / 46420B, 46502B, 77777B /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE HP 2100
|
||||
C FOUR WORD DOUBLE PRECISION OPTION WITH FTN4
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / 40000B, 0 /
|
||||
C DATA SMALL(3), SMALL(4) / 0, 1 /
|
||||
C DATA LARGE(1), LARGE(2) / 77777B, 177777B /
|
||||
C DATA LARGE(3), LARGE(4) / 177777B, 177776B /
|
||||
C DATA RIGHT(1), RIGHT(2) / 40000B, 0 /
|
||||
C DATA RIGHT(3), RIGHT(4) / 0, 225B /
|
||||
C DATA DIVER(1), DIVER(2) / 40000B, 0 /
|
||||
C DATA DIVER(3), DIVER(4) / 0, 227B /
|
||||
C DATA LOG10(1), LOG10(2) / 46420B, 46502B /
|
||||
C DATA LOG10(3), LOG10(4) / 76747B, 176377B /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE HP 9000
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / 00040000000B, 00000000000B /
|
||||
C DATA LARGE(1), LARGE(2) / 17737777777B, 37777777777B /
|
||||
C DATA RIGHT(1), RIGHT(2) / 07454000000B, 00000000000B /
|
||||
C DATA DIVER(1), DIVER(2) / 07460000000B, 00000000000B /
|
||||
C DATA LOG10(1), LOG10(2) / 07764642023B, 12047674777B /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
|
||||
C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND
|
||||
C THE PERKIN ELMER (INTERDATA) 7/32.
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / Z00100000, Z00000000 /
|
||||
C DATA LARGE(1), LARGE(2) / Z7FFFFFFF, ZFFFFFFFF /
|
||||
C DATA RIGHT(1), RIGHT(2) / Z33100000, Z00000000 /
|
||||
C DATA DIVER(1), DIVER(2) / Z34100000, Z00000000 /
|
||||
C DATA LOG10(1), LOG10(2) / Z41134413, Z509F79FF /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE IBM PC
|
||||
C ASSUMES THAT ALL ARITHMETIC IS DONE IN DOUBLE PRECISION
|
||||
C ON 8088, I.E., NOT IN 80 BIT FORM FOR THE 8087.
|
||||
C
|
||||
C DATA SMALL(1),SMALL(2) / 2002288515, 1050897 /
|
||||
C DATA LARGE(1),LARGE(2) / 1487780761, 2146426097 /
|
||||
C DATA RIGHT(1),RIGHT(2) / -1209488034, 1017118298 /
|
||||
C DATA DIVER(1),DIVER(2) / -1209488034, 1018166874 /
|
||||
C DATA LOG10(1),LOG10(2) / 1352628735, 1070810131 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE IBM RS 6000
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' /
|
||||
C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' /
|
||||
C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' /
|
||||
C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' /
|
||||
C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR)
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / "033400000000, "000000000000 /
|
||||
C DATA LARGE(1), LARGE(2) / "377777777777, "344777777777 /
|
||||
C DATA RIGHT(1), RIGHT(2) / "113400000000, "000000000000 /
|
||||
C DATA DIVER(1), DIVER(2) / "114400000000, "000000000000 /
|
||||
C DATA LOG10(1), LOG10(2) / "177464202324, "144117571776 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR)
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / "000400000000, "000000000000 /
|
||||
C DATA LARGE(1), LARGE(2) / "377777777777, "377777777777 /
|
||||
C DATA RIGHT(1), RIGHT(2) / "103400000000, "000000000000 /
|
||||
C DATA DIVER(1), DIVER(2) / "104400000000, "000000000000 /
|
||||
C DATA LOG10(1), LOG10(2) / "177464202324, "476747767461 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING
|
||||
C 32-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL).
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / 8388608, 0 /
|
||||
C DATA LARGE(1), LARGE(2) / 2147483647, -1 /
|
||||
C DATA RIGHT(1), RIGHT(2) / 612368384, 0 /
|
||||
C DATA DIVER(1), DIVER(2) / 620756992, 0 /
|
||||
C DATA LOG10(1), LOG10(2) / 1067065498, -2063872008 /
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / O00040000000, O00000000000 /
|
||||
C DATA LARGE(1), LARGE(2) / O17777777777, O37777777777 /
|
||||
C DATA RIGHT(1), RIGHT(2) / O04440000000, O00000000000 /
|
||||
C DATA DIVER(1), DIVER(2) / O04500000000, O00000000000 /
|
||||
C DATA LOG10(1), LOG10(2) / O07746420232, O20476747770 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING
|
||||
C 16-BIT INTEGERS (EXPRESSED IN INTEGER AND OCTAL).
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / 128, 0 /
|
||||
C DATA SMALL(3), SMALL(4) / 0, 0 /
|
||||
C DATA LARGE(1), LARGE(2) / 32767, -1 /
|
||||
C DATA LARGE(3), LARGE(4) / -1, -1 /
|
||||
C DATA RIGHT(1), RIGHT(2) / 9344, 0 /
|
||||
C DATA RIGHT(3), RIGHT(4) / 0, 0 /
|
||||
C DATA DIVER(1), DIVER(2) / 9472, 0 /
|
||||
C DATA DIVER(3), DIVER(4) / 0, 0 /
|
||||
C DATA LOG10(1), LOG10(2) / 16282, 8346 /
|
||||
C DATA LOG10(3), LOG10(4) / -31493, -12296 /
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / O000200, O000000 /
|
||||
C DATA SMALL(3), SMALL(4) / O000000, O000000 /
|
||||
C DATA LARGE(1), LARGE(2) / O077777, O177777 /
|
||||
C DATA LARGE(3), LARGE(4) / O177777, O177777 /
|
||||
C DATA RIGHT(1), RIGHT(2) / O022200, O000000 /
|
||||
C DATA RIGHT(3), RIGHT(4) / O000000, O000000 /
|
||||
C DATA DIVER(1), DIVER(2) / O022400, O000000 /
|
||||
C DATA DIVER(3), DIVER(4) / O000000, O000000 /
|
||||
C DATA LOG10(1), LOG10(2) / O037632, O020232 /
|
||||
C DATA LOG10(3), LOG10(4) / O102373, O147770 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE SILICON GRAPHICS IRIS
|
||||
C
|
||||
c data dmach(1) / 2.22507 38585 072012 d-308 /
|
||||
c data dmach(2) / 1.79769 31348 623158 d+308 /
|
||||
c data dmach(3) / 2.22044 60492 503131 d-16 /
|
||||
c data dmach(4) / 4.44089 20985 006262 d-16 /
|
||||
c data dmach(5) / 0.30102 99956 639812 /
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / Z'00100000',Z'00000000' /
|
||||
C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF',Z'FFFFFFFF' /
|
||||
C DATA RIGHT(1), RIGHT(2) / Z'3CB00000',Z'00000000' /
|
||||
C DATA DIVER(1), DIVER(2) / Z'3CC00000',Z'00000000' /
|
||||
C DATA LOG10(1), LOG10(2) / Z'3FD34413',Z'509F79FF' /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE SUN
|
||||
C
|
||||
C from SLATEC CML committee - work for Sun3, Sun4, and Sparc
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / Z'00100000', Z'00000000' /
|
||||
C DATA LARGE(1), LARGE(2) / Z'7FEFFFFF', Z'FFFFFFFF' /
|
||||
C DATA RIGHT(1), RIGHT(2) / Z'3CA00000', Z'00000000' /
|
||||
C DATA DIVER(1), DIVER(2) / Z'3CB00000', Z'00000000' /
|
||||
C DATA LOG10(1), LOG10(2) / Z'3FD34413', Z'509F79FF' /
|
||||
C
|
||||
C from Sun Microsystems - work for Sun 386i
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / Z'00000000', Z'00100000' /
|
||||
C DATA LARGE(1), LARGE(2) / Z'FFFFFFFF', Z'7FEFFFFF' /
|
||||
C DATA RIGHT(1), RIGHT(2) / Z'00000000', Z'3CA00000' /
|
||||
C DATA DIVER(1), DIVER(2) / Z'00000000', Z'3CB00000' /
|
||||
C DATA LOG10(1), LOG10(2) / Z'509F79FF', Z'3FD34413' /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / O000040000000, O000000000000 /
|
||||
C DATA LARGE(1), LARGE(2) / O377777777777, O777777777777 /
|
||||
C DATA RIGHT(1), RIGHT(2) / O170540000000, O000000000000 /
|
||||
C DATA DIVER(1), DIVER(2) / O170640000000, O000000000000 /
|
||||
C DATA LOG10(1), LOG10(2) / O177746420232, O411757177572 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR VAX 11/780
|
||||
C (EXPRESSED IN INTEGER AND HEXADECIMAL)
|
||||
C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSYEMS
|
||||
C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / 128, 0 /
|
||||
C DATA LARGE(1), LARGE(2) / -32769, -1 /
|
||||
C DATA RIGHT(1), RIGHT(2) / 9344, 0 /
|
||||
C DATA DIVER(1), DIVER(2) / 9472, 0 /
|
||||
C DATA LOG10(1), LOG10(2) / 546979738, -805796613 /
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / Z00000080, Z00000000 /
|
||||
C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF /
|
||||
C DATA RIGHT(1), RIGHT(2) / Z00002480, Z00000000 /
|
||||
C DATA DIVER(1), DIVER(2) / Z00002500, Z00000000 /
|
||||
C DATA LOG10(1), LOG10(2) / Z209A3F9A, ZCFF884FB /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR VAX 11/780 (G-FLOATING)
|
||||
C (EXPRESSED IN INTEGER AND HEXADECIMAL)
|
||||
C THE HEX FORMAT BELOW MAY NOT BE SUITABLE FOR UNIX SYSYEMS
|
||||
C THE INTEGER FORMAT SHOULD BE OK FOR UNIX SYSTEMS
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / 16, 0 /
|
||||
C DATA LARGE(1), LARGE(2) / -32769, -1 /
|
||||
C DATA RIGHT(1), RIGHT(2) / 15552, 0 /
|
||||
C DATA DIVER(1), DIVER(2) / 15568, 0 /
|
||||
C DATA LOG10(1), LOG10(2) / 1142112243, 2046775455 /
|
||||
C
|
||||
C DATA SMALL(1), SMALL(2) / Z00000010, Z00000000 /
|
||||
C DATA LARGE(1), LARGE(2) / ZFFFF7FFF, ZFFFFFFFF /
|
||||
C DATA RIGHT(1), RIGHT(2) / Z00003CC0, Z00000000 /
|
||||
C DATA DIVER(1), DIVER(2) / Z00003CD0, Z00000000 /
|
||||
C DATA LOG10(1), LOG10(2) / Z44133FF3, Z79FF509F /
|
||||
C
|
||||
C
|
||||
C***FIRST EXECUTABLE STATEMENT D1MACH
|
||||
IF (I .LT. 1 .OR. I .GT. 5)
|
||||
1 CALL XERROR ('D1MACH -- I OUT OF BOUNDS', 25, 1, 2)
|
||||
C
|
||||
D1MACH = DMACH(I)
|
||||
RETURN
|
||||
C
|
||||
END
|
||||
|
|
@ -0,0 +1,189 @@
|
|||
DOUBLE PRECISION FUNCTION DGAMLN(Z,IERR)
|
||||
C***BEGIN PROLOGUE DGAMLN
|
||||
C***DATE WRITTEN 830501 (YYMMDD)
|
||||
C***REVISION DATE 830501 (YYMMDD)
|
||||
C***CATEGORY NO. B5F
|
||||
C***KEYWORDS GAMMA FUNCTION,LOGARITHM OF GAMMA FUNCTION
|
||||
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
|
||||
C***PURPOSE TO COMPUTE THE LOGARITHM OF THE GAMMA FUNCTION
|
||||
C***DESCRIPTION
|
||||
C
|
||||
C **** A DOUBLE PRECISION ROUTINE ****
|
||||
C DGAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR
|
||||
C Z.GT.0. THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES
|
||||
C GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION
|
||||
C G(Z+1)=Z*G(Z) FOR Z.LE.ZMIN. THE FUNCTION WAS MADE AS
|
||||
C PORTABLE AS POSSIBLE BY COMPUTIMG ZMIN FROM THE NUMBER OF BASE
|
||||
C 10 DIGITS IN A WORD, RLN=AMAX1(-ALOG10(R1MACH(4)),0.5E-18)
|
||||
C LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY.
|
||||
C
|
||||
C SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100
|
||||
C VALUES IS USED FOR SPEED OF EXECUTION.
|
||||
C
|
||||
C DESCRIPTION OF ARGUMENTS
|
||||
C
|
||||
C INPUT Z IS D0UBLE PRECISION
|
||||
C Z - ARGUMENT, Z.GT.0.0D0
|
||||
C
|
||||
C OUTPUT DGAMLN IS DOUBLE PRECISION
|
||||
C DGAMLN - NATURAL LOG OF THE GAMMA FUNCTION AT Z.NE.0.0D0
|
||||
C IERR - ERROR FLAG
|
||||
C IERR=0, NORMAL RETURN, COMPUTATION COMPLETED
|
||||
C IERR=1, Z.LE.0.0D0, NO COMPUTATION
|
||||
C
|
||||
C
|
||||
C***REFERENCES COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
|
||||
C BY D. E. AMOS, SAND83-0083, MAY, 1983.
|
||||
C***ROUTINES CALLED I1MACH,D1MACH
|
||||
C***END PROLOGUE DGAMLN
|
||||
DOUBLE PRECISION CF, CON, FLN, FZ, GLN, RLN, S, TLG, TRM, TST,
|
||||
* T1, WDTOL, Z, ZDMY, ZINC, ZM, ZMIN, ZP, ZSQ, D1MACH
|
||||
INTEGER I, IERR, I1M, K, MZ, NZ, I1MACH
|
||||
DIMENSION CF(22), GLN(100)
|
||||
C LNGAMMA(N), N=1,100
|
||||
DATA GLN(1), GLN(2), GLN(3), GLN(4), GLN(5), GLN(6), GLN(7),
|
||||
1 GLN(8), GLN(9), GLN(10), GLN(11), GLN(12), GLN(13), GLN(14),
|
||||
2 GLN(15), GLN(16), GLN(17), GLN(18), GLN(19), GLN(20),
|
||||
3 GLN(21), GLN(22)/
|
||||
4 0.00000000000000000D+00, 0.00000000000000000D+00,
|
||||
5 6.93147180559945309D-01, 1.79175946922805500D+00,
|
||||
6 3.17805383034794562D+00, 4.78749174278204599D+00,
|
||||
7 6.57925121201010100D+00, 8.52516136106541430D+00,
|
||||
8 1.06046029027452502D+01, 1.28018274800814696D+01,
|
||||
9 1.51044125730755153D+01, 1.75023078458738858D+01,
|
||||
A 1.99872144956618861D+01, 2.25521638531234229D+01,
|
||||
B 2.51912211827386815D+01, 2.78992713838408916D+01,
|
||||
C 3.06718601060806728D+01, 3.35050734501368889D+01,
|
||||
D 3.63954452080330536D+01, 3.93398841871994940D+01,
|
||||
E 4.23356164607534850D+01, 4.53801388984769080D+01/
|
||||
DATA GLN(23), GLN(24), GLN(25), GLN(26), GLN(27), GLN(28),
|
||||
1 GLN(29), GLN(30), GLN(31), GLN(32), GLN(33), GLN(34),
|
||||
2 GLN(35), GLN(36), GLN(37), GLN(38), GLN(39), GLN(40),
|
||||
3 GLN(41), GLN(42), GLN(43), GLN(44)/
|
||||
4 4.84711813518352239D+01, 5.16066755677643736D+01,
|
||||
5 5.47847293981123192D+01, 5.80036052229805199D+01,
|
||||
6 6.12617017610020020D+01, 6.45575386270063311D+01,
|
||||
7 6.78897431371815350D+01, 7.12570389671680090D+01,
|
||||
8 7.46582363488301644D+01, 7.80922235533153106D+01,
|
||||
9 8.15579594561150372D+01, 8.50544670175815174D+01,
|
||||
A 8.85808275421976788D+01, 9.21361756036870925D+01,
|
||||
B 9.57196945421432025D+01, 9.93306124547874269D+01,
|
||||
C 1.02968198614513813D+02, 1.06631760260643459D+02,
|
||||
D 1.10320639714757395D+02, 1.14034211781461703D+02,
|
||||
E 1.17771881399745072D+02, 1.21533081515438634D+02/
|
||||
DATA GLN(45), GLN(46), GLN(47), GLN(48), GLN(49), GLN(50),
|
||||
1 GLN(51), GLN(52), GLN(53), GLN(54), GLN(55), GLN(56),
|
||||
2 GLN(57), GLN(58), GLN(59), GLN(60), GLN(61), GLN(62),
|
||||
3 GLN(63), GLN(64), GLN(65), GLN(66)/
|
||||
4 1.25317271149356895D+02, 1.29123933639127215D+02,
|
||||
5 1.32952575035616310D+02, 1.36802722637326368D+02,
|
||||
6 1.40673923648234259D+02, 1.44565743946344886D+02,
|
||||
7 1.48477766951773032D+02, 1.52409592584497358D+02,
|
||||
8 1.56360836303078785D+02, 1.60331128216630907D+02,
|
||||
9 1.64320112263195181D+02, 1.68327445448427652D+02,
|
||||
A 1.72352797139162802D+02, 1.76395848406997352D+02,
|
||||
B 1.80456291417543771D+02, 1.84533828861449491D+02,
|
||||
C 1.88628173423671591D+02, 1.92739047287844902D+02,
|
||||
D 1.96866181672889994D+02, 2.01009316399281527D+02,
|
||||
E 2.05168199482641199D+02, 2.09342586752536836D+02/
|
||||
DATA GLN(67), GLN(68), GLN(69), GLN(70), GLN(71), GLN(72),
|
||||
1 GLN(73), GLN(74), GLN(75), GLN(76), GLN(77), GLN(78),
|
||||
2 GLN(79), GLN(80), GLN(81), GLN(82), GLN(83), GLN(84),
|
||||
3 GLN(85), GLN(86), GLN(87), GLN(88)/
|
||||
4 2.13532241494563261D+02, 2.17736934113954227D+02,
|
||||
5 2.21956441819130334D+02, 2.26190548323727593D+02,
|
||||
6 2.30439043565776952D+02, 2.34701723442818268D+02,
|
||||
7 2.38978389561834323D+02, 2.43268849002982714D+02,
|
||||
8 2.47572914096186884D+02, 2.51890402209723194D+02,
|
||||
9 2.56221135550009525D+02, 2.60564940971863209D+02,
|
||||
A 2.64921649798552801D+02, 2.69291097651019823D+02,
|
||||
B 2.73673124285693704D+02, 2.78067573440366143D+02,
|
||||
C 2.82474292687630396D+02, 2.86893133295426994D+02,
|
||||
D 2.91323950094270308D+02, 2.95766601350760624D+02,
|
||||
E 3.00220948647014132D+02, 3.04686856765668715D+02/
|
||||
DATA GLN(89), GLN(90), GLN(91), GLN(92), GLN(93), GLN(94),
|
||||
1 GLN(95), GLN(96), GLN(97), GLN(98), GLN(99), GLN(100)/
|
||||
2 3.09164193580146922D+02, 3.13652829949879062D+02,
|
||||
3 3.18152639620209327D+02, 3.22663499126726177D+02,
|
||||
4 3.27185287703775217D+02, 3.31717887196928473D+02,
|
||||
5 3.36261181979198477D+02, 3.40815058870799018D+02,
|
||||
6 3.45379407062266854D+02, 3.49954118040770237D+02,
|
||||
7 3.54539085519440809D+02, 3.59134205369575399D+02/
|
||||
C COEFFICIENTS OF ASYMPTOTIC EXPANSION
|
||||
DATA CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), CF(8),
|
||||
1 CF(9), CF(10), CF(11), CF(12), CF(13), CF(14), CF(15),
|
||||
2 CF(16), CF(17), CF(18), CF(19), CF(20), CF(21), CF(22)/
|
||||
3 8.33333333333333333D-02, -2.77777777777777778D-03,
|
||||
4 7.93650793650793651D-04, -5.95238095238095238D-04,
|
||||
5 8.41750841750841751D-04, -1.91752691752691753D-03,
|
||||
6 6.41025641025641026D-03, -2.95506535947712418D-02,
|
||||
7 1.79644372368830573D-01, -1.39243221690590112D+00,
|
||||
8 1.34028640441683920D+01, -1.56848284626002017D+02,
|
||||
9 2.19310333333333333D+03, -3.61087712537249894D+04,
|
||||
A 6.91472268851313067D+05, -1.52382215394074162D+07,
|
||||
B 3.82900751391414141D+08, -1.08822660357843911D+10,
|
||||
C 3.47320283765002252D+11, -1.23696021422692745D+13,
|
||||
D 4.88788064793079335D+14, -2.13203339609193739D+16/
|
||||
C
|
||||
C LN(2*PI)
|
||||
DATA CON / 1.83787706640934548D+00/
|
||||
C
|
||||
C***FIRST EXECUTABLE STATEMENT DGAMLN
|
||||
IERR=0
|
||||
IF (Z.LE.0.0D0) GO TO 70
|
||||
IF (Z.GT.101.0D0) GO TO 10
|
||||
NZ = INT(SNGL(Z))
|
||||
FZ = Z - FLOAT(NZ)
|
||||
IF (FZ.GT.0.0D0) GO TO 10
|
||||
IF (NZ.GT.100) GO TO 10
|
||||
DGAMLN = GLN(NZ)
|
||||
RETURN
|
||||
10 CONTINUE
|
||||
WDTOL = D1MACH(4)
|
||||
WDTOL = DMAX1(WDTOL,0.5D-18)
|
||||
I1M = I1MACH(14)
|
||||
RLN = D1MACH(5)*FLOAT(I1M)
|
||||
FLN = DMIN1(RLN,20.0D0)
|
||||
FLN = DMAX1(FLN,3.0D0)
|
||||
FLN = FLN - 3.0D0
|
||||
ZM = 1.8000D0 + 0.3875D0*FLN
|
||||
MZ = INT(SNGL(ZM)) + 1
|
||||
ZMIN = FLOAT(MZ)
|
||||
ZDMY = Z
|
||||
ZINC = 0.0D0
|
||||
IF (Z.GE.ZMIN) GO TO 20
|
||||
ZINC = ZMIN - FLOAT(NZ)
|
||||
ZDMY = Z + ZINC
|
||||
20 CONTINUE
|
||||
ZP = 1.0D0/ZDMY
|
||||
T1 = CF(1)*ZP
|
||||
S = T1
|
||||
IF (ZP.LT.WDTOL) GO TO 40
|
||||
ZSQ = ZP*ZP
|
||||
TST = T1*WDTOL
|
||||
DO 30 K=2,22
|
||||
ZP = ZP*ZSQ
|
||||
TRM = CF(K)*ZP
|
||||
IF (DABS(TRM).LT.TST) GO TO 40
|
||||
S = S + TRM
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
IF (ZINC.NE.0.0D0) GO TO 50
|
||||
TLG = DLOG(Z)
|
||||
DGAMLN = Z*(TLG-1.0D0) + 0.5D0*(CON-TLG) + S
|
||||
RETURN
|
||||
50 CONTINUE
|
||||
ZP = 1.0D0
|
||||
NZ = INT(SNGL(ZINC))
|
||||
DO 60 I=1,NZ
|
||||
ZP = ZP*(Z+FLOAT(I-1))
|
||||
60 CONTINUE
|
||||
TLG = DLOG(ZDMY)
|
||||
DGAMLN = ZDMY*(TLG-1.0D0) - DLOG(ZP) + 0.5D0*(CON-TLG) + S
|
||||
RETURN
|
||||
C
|
||||
C
|
||||
70 CONTINUE
|
||||
IERR=1
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,673 @@
|
|||
*DECK I1MACH
|
||||
INTEGER FUNCTION I1MACH(I)
|
||||
C***BEGIN PROLOGUE I1MACH
|
||||
C***DATE WRITTEN 750101 (YYMMDD)
|
||||
C***REVISION DATE 890213 (YYMMDD)
|
||||
C***CATEGORY NO. R1
|
||||
C***KEYWORDS LIBRARY=SLATEC,TYPE=INTEGER(I1MACH-I),MACHINE CONSTANTS
|
||||
C***AUTHOR FOX, P. A., (BELL LABS)
|
||||
C HALL, A. D., (BELL LABS)
|
||||
C SCHRYER, N. L., (BELL LABS)
|
||||
C***PURPOSE Returns integer machine dependent constants
|
||||
C***DESCRIPTION
|
||||
C
|
||||
C I1MACH can be used to obtain machine-dependent parameters
|
||||
C for the local machine environment. It is a function
|
||||
C subroutine with one (input) argument, and can be called
|
||||
C as follows, for example
|
||||
C
|
||||
C K = I1MACH(I)
|
||||
C
|
||||
C where I=1,...,16. The (output) value of K above is
|
||||
C determined by the (input) value of I. The results for
|
||||
C various values of I are discussed below.
|
||||
C
|
||||
C I/O unit numbers.
|
||||
C I1MACH( 1) = the standard input unit.
|
||||
C I1MACH( 2) = the standard output unit.
|
||||
C I1MACH( 3) = the standard punch unit.
|
||||
C I1MACH( 4) = the standard error message unit.
|
||||
C
|
||||
C Words.
|
||||
C I1MACH( 5) = the number of bits per integer storage unit.
|
||||
C I1MACH( 6) = the number of characters per integer storage unit.
|
||||
C
|
||||
C Integers.
|
||||
C assume integers are represented in the S-digit, base-A form
|
||||
C
|
||||
C sign ( X(S-1)*A**(S-1) + ... + X(1)*A + X(0) )
|
||||
C
|
||||
C where 0 .LE. X(I) .LT. A for I=0,...,S-1.
|
||||
C I1MACH( 7) = A, the base.
|
||||
C I1MACH( 8) = S, the number of base-A digits.
|
||||
C I1MACH( 9) = A**S - 1, the largest magnitude.
|
||||
C
|
||||
C Floating-Point Numbers.
|
||||
C Assume floating-point numbers are represented in the T-digit,
|
||||
C base-B form
|
||||
C sign (B**E)*( (X(1)/B) + ... + (X(T)/B**T) )
|
||||
C
|
||||
C where 0 .LE. X(I) .LT. B for I=1,...,T,
|
||||
C 0 .LT. X(1), and EMIN .LE. E .LE. EMAX.
|
||||
C I1MACH(10) = B, the base.
|
||||
C
|
||||
C Single-Precision
|
||||
C I1MACH(11) = T, the number of base-B digits.
|
||||
C I1MACH(12) = EMIN, the smallest exponent E.
|
||||
C I1MACH(13) = EMAX, the largest exponent E.
|
||||
C
|
||||
C Double-Precision
|
||||
C I1MACH(14) = T, the number of base-B digits.
|
||||
C I1MACH(15) = EMIN, the smallest exponent E.
|
||||
C I1MACH(16) = EMAX, the largest exponent E.
|
||||
C
|
||||
C To alter this function for a particular environment,
|
||||
C the desired set of DATA statements should be activated by
|
||||
C removing the C from column 1. Also, the values of
|
||||
C I1MACH(1) - I1MACH(4) should be checked for consistency
|
||||
C with the local operating system.
|
||||
C
|
||||
C***REFERENCES FOX P.A., HALL A.D., SCHRYER N.L.,*FRAMEWORK FOR A
|
||||
C PORTABLE LIBRARY*, ACM TRANSACTIONS ON MATHEMATICAL
|
||||
C SOFTWARE, VOL. 4, NO. 2, JUNE 1978, PP. 177-188.
|
||||
C***ROUTINES CALLED (NONE)
|
||||
C***END PROLOGUE I1MACH
|
||||
C
|
||||
INTEGER IMACH(16),OUTPUT
|
||||
SAVE IMACH
|
||||
EQUIVALENCE (IMACH(4),OUTPUT)
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE AMIGA
|
||||
C ABSOFT COMPILER
|
||||
C
|
||||
C DATA IMACH(1) / 5 /
|
||||
C DATA IMACH(2) / 6 /
|
||||
C DATA IMACH(3) / 5 /
|
||||
C DATA IMACH(4) / 6 /
|
||||
C DATA IMACH(5) / 32 /
|
||||
C DATA IMACH(6) / 4 /
|
||||
C DATA IMACH(7) / 2 /
|
||||
C DATA IMACH(8) / 31 /
|
||||
C DATA IMACH(9) / 2147483647 /
|
||||
C DATA IMACH(10)/ 2 /
|
||||
C DATA IMACH(11)/ 24 /
|
||||
C DATA IMACH(12)/ -126 /
|
||||
C DATA IMACH(13)/ 127 /
|
||||
C DATA IMACH(14)/ 53 /
|
||||
C DATA IMACH(15)/ -1022 /
|
||||
C DATA IMACH(16)/ 1023 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE APOLLO
|
||||
C
|
||||
C DATA IMACH(1) / 5 /
|
||||
C DATA IMACH(2) / 6 /
|
||||
C DATA IMACH(3) / 6 /
|
||||
C DATA IMACH(4) / 6 /
|
||||
C DATA IMACH(5) / 32 /
|
||||
C DATA IMACH(6) / 4 /
|
||||
C DATA IMACH(7) / 2 /
|
||||
C DATA IMACH(8) / 31 /
|
||||
C DATA IMACH(9) / 2147483647 /
|
||||
C DATA IMACH(10)/ 2 /
|
||||
C DATA IMACH(11)/ 24 /
|
||||
C DATA IMACH(12)/ -125 /
|
||||
C DATA IMACH(13)/ 129 /
|
||||
C DATA IMACH(14)/ 53 /
|
||||
C DATA IMACH(15)/ -1021 /
|
||||
C DATA IMACH(16)/ 1025 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE BURROUGHS 1700 SYSTEM
|
||||
C
|
||||
C DATA IMACH( 1) / 7 /
|
||||
C DATA IMACH( 2) / 2 /
|
||||
C DATA IMACH( 3) / 2 /
|
||||
C DATA IMACH( 4) / 2 /
|
||||
C DATA IMACH( 5) / 36 /
|
||||
C DATA IMACH( 6) / 4 /
|
||||
C DATA IMACH( 7) / 2 /
|
||||
C DATA IMACH( 8) / 33 /
|
||||
C DATA IMACH( 9) / Z1FFFFFFFF /
|
||||
C DATA IMACH(10) / 2 /
|
||||
C DATA IMACH(11) / 24 /
|
||||
C DATA IMACH(12) / -256 /
|
||||
C DATA IMACH(13) / 255 /
|
||||
C DATA IMACH(14) / 60 /
|
||||
C DATA IMACH(15) / -256 /
|
||||
C DATA IMACH(16) / 255 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE BURROUGHS 5700 SYSTEM
|
||||
C
|
||||
C DATA IMACH( 1) / 5 /
|
||||
C DATA IMACH( 2) / 6 /
|
||||
C DATA IMACH( 3) / 7 /
|
||||
C DATA IMACH( 4) / 6 /
|
||||
C DATA IMACH( 5) / 48 /
|
||||
C DATA IMACH( 6) / 6 /
|
||||
C DATA IMACH( 7) / 2 /
|
||||
C DATA IMACH( 8) / 39 /
|
||||
C DATA IMACH( 9) / O0007777777777777 /
|
||||
C DATA IMACH(10) / 8 /
|
||||
C DATA IMACH(11) / 13 /
|
||||
C DATA IMACH(12) / -50 /
|
||||
C DATA IMACH(13) / 76 /
|
||||
C DATA IMACH(14) / 26 /
|
||||
C DATA IMACH(15) / -50 /
|
||||
C DATA IMACH(16) / 76 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE BURROUGHS 6700/7700 SYSTEMS
|
||||
C
|
||||
C DATA IMACH( 1) / 5 /
|
||||
C DATA IMACH( 2) / 6 /
|
||||
C DATA IMACH( 3) / 7 /
|
||||
C DATA IMACH( 4) / 6 /
|
||||
C DATA IMACH( 5) / 48 /
|
||||
C DATA IMACH( 6) / 6 /
|
||||
C DATA IMACH( 7) / 2 /
|
||||
C DATA IMACH( 8) / 39 /
|
||||
C DATA IMACH( 9) / O0007777777777777 /
|
||||
C DATA IMACH(10) / 8 /
|
||||
C DATA IMACH(11) / 13 /
|
||||
C DATA IMACH(12) / -50 /
|
||||
C DATA IMACH(13) / 76 /
|
||||
C DATA IMACH(14) / 26 /
|
||||
C DATA IMACH(15) / -32754 /
|
||||
C DATA IMACH(16) / 32780 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE CDC 170/180 SERIES USING NOS/VE
|
||||
C
|
||||
C DATA IMACH( 1) / 5 /
|
||||
C DATA IMACH( 2) / 6 /
|
||||
C DATA IMACH( 3) / 7 /
|
||||
C DATA IMACH( 4) / 6 /
|
||||
C DATA IMACH( 5) / 64 /
|
||||
C DATA IMACH( 6) / 8 /
|
||||
C DATA IMACH( 7) / 2 /
|
||||
C DATA IMACH( 8) / 63 /
|
||||
C DATA IMACH( 9) / 9223372036854775807 /
|
||||
C DATA IMACH(10) / 2 /
|
||||
C DATA IMACH(11) / 47 /
|
||||
C DATA IMACH(12) / -4095 /
|
||||
C DATA IMACH(13) / 4094 /
|
||||
C DATA IMACH(14) / 94 /
|
||||
C DATA IMACH(15) / -4095 /
|
||||
C DATA IMACH(16) / 4094 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE CDC 6000/7000 SERIES
|
||||
C
|
||||
C DATA IMACH( 1) / 5 /
|
||||
C DATA IMACH( 2) / 6 /
|
||||
C DATA IMACH( 3) / 7 /
|
||||
C DATA IMACH( 4) /6LOUTPUT/
|
||||
C DATA IMACH( 5) / 60 /
|
||||
C DATA IMACH( 6) / 10 /
|
||||
C DATA IMACH( 7) / 2 /
|
||||
C DATA IMACH( 8) / 48 /
|
||||
C DATA IMACH( 9) / 00007777777777777777B /
|
||||
C DATA IMACH(10) / 2 /
|
||||
C DATA IMACH(11) / 47 /
|
||||
C DATA IMACH(12) / -929 /
|
||||
C DATA IMACH(13) / 1070 /
|
||||
C DATA IMACH(14) / 94 /
|
||||
C DATA IMACH(15) / -929 /
|
||||
C DATA IMACH(16) / 1069 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE CELERITY C1260
|
||||
C
|
||||
C DATA IMACH(1) / 5 /
|
||||
C DATA IMACH(2) / 6 /
|
||||
C DATA IMACH(3) / 6 /
|
||||
C DATA IMACH(4) / 0 /
|
||||
C DATA IMACH(5) / 32 /
|
||||
C DATA IMACH(6) / 4 /
|
||||
C DATA IMACH(7) / 2 /
|
||||
C DATA IMACH(8) / 31 /
|
||||
C DATA IMACH(9) / Z'7FFFFFFF' /
|
||||
C DATA IMACH(10)/ 2 /
|
||||
C DATA IMACH(11)/ 24 /
|
||||
C DATA IMACH(12)/ -126 /
|
||||
C DATA IMACH(13)/ 127 /
|
||||
C DATA IMACH(14)/ 53 /
|
||||
C DATA IMACH(15)/ -1022 /
|
||||
C DATA IMACH(16)/ 1023 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE CONVEX C-1
|
||||
C
|
||||
C DATA IMACH( 1) / 5/
|
||||
C DATA IMACH( 2) / 6/
|
||||
C DATA IMACH( 3) / 7/
|
||||
C DATA IMACH( 4) / 6/
|
||||
C DATA IMACH( 5) / 32/
|
||||
C DATA IMACH( 6) / 4/
|
||||
C DATA IMACH( 7) / 2/
|
||||
C DATA IMACH( 8) / 31/
|
||||
C DATA IMACH( 9) /2147483647/
|
||||
C DATA IMACH(10) / 2/
|
||||
C DATA IMACH(11) / 24/
|
||||
C DATA IMACH(12) / -128/
|
||||
C DATA IMACH(13) / 127/
|
||||
C DATA IMACH(14) / 53/
|
||||
C DATA IMACH(15) / -1024/
|
||||
C DATA IMACH(16) / 1023/
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE CRAY-1
|
||||
C
|
||||
C DATA IMACH( 1) / 100 /
|
||||
C DATA IMACH( 2) / 101 /
|
||||
C DATA IMACH( 3) / 102 /
|
||||
C DATA IMACH( 4) / 101 /
|
||||
C DATA IMACH( 5) / 64 /
|
||||
C DATA IMACH( 6) / 8 /
|
||||
C DATA IMACH( 7) / 2 /
|
||||
C DATA IMACH( 8) / 63 /
|
||||
C DATA IMACH( 9) / 777777777777777777777B /
|
||||
C DATA IMACH(10) / 2 /
|
||||
C DATA IMACH(11) / 47 /
|
||||
C DATA IMACH(12) / -8189 /
|
||||
C DATA IMACH(13) / 8190 /
|
||||
C DATA IMACH(14) / 94 /
|
||||
C DATA IMACH(15) / -8099 /
|
||||
C DATA IMACH(16) / 8190 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE DATA GENERAL ECLIPSE S/200
|
||||
C
|
||||
C DATA IMACH( 1) / 11 /
|
||||
C DATA IMACH( 2) / 12 /
|
||||
C DATA IMACH( 3) / 8 /
|
||||
C DATA IMACH( 4) / 10 /
|
||||
C DATA IMACH( 5) / 16 /
|
||||
C DATA IMACH( 6) / 2 /
|
||||
C DATA IMACH( 7) / 2 /
|
||||
C DATA IMACH( 8) / 15 /
|
||||
C DATA IMACH( 9) /32767 /
|
||||
C DATA IMACH(10) / 16 /
|
||||
C DATA IMACH(11) / 6 /
|
||||
C DATA IMACH(12) / -64 /
|
||||
C DATA IMACH(13) / 63 /
|
||||
C DATA IMACH(14) / 14 /
|
||||
C DATA IMACH(15) / -64 /
|
||||
C DATA IMACH(16) / 63 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE ELXSI 6400
|
||||
C
|
||||
C DATA IMACH( 1) / 5/
|
||||
C DATA IMACH( 2) / 6/
|
||||
C DATA IMACH( 3) / 6/
|
||||
C DATA IMACH( 4) / 6/
|
||||
C DATA IMACH( 5) / 32/
|
||||
C DATA IMACH( 6) / 4/
|
||||
C DATA IMACH( 7) / 2/
|
||||
C DATA IMACH( 8) / 32/
|
||||
C DATA IMACH( 9) /2147483647/
|
||||
C DATA IMACH(10) / 2/
|
||||
C DATA IMACH(11) / 24/
|
||||
C DATA IMACH(12) / -126/
|
||||
C DATA IMACH(13) / 127/
|
||||
C DATA IMACH(14) / 53/
|
||||
C DATA IMACH(15) / -1022/
|
||||
C DATA IMACH(16) / 1023/
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE HARRIS 220
|
||||
C
|
||||
C DATA IMACH( 1) / 5 /
|
||||
C DATA IMACH( 2) / 6 /
|
||||
C DATA IMACH( 3) / 0 /
|
||||
C DATA IMACH( 4) / 6 /
|
||||
C DATA IMACH( 5) / 24 /
|
||||
C DATA IMACH( 6) / 3 /
|
||||
C DATA IMACH( 7) / 2 /
|
||||
C DATA IMACH( 8) / 23 /
|
||||
C DATA IMACH( 9) / 8388607 /
|
||||
C DATA IMACH(10) / 2 /
|
||||
C DATA IMACH(11) / 23 /
|
||||
C DATA IMACH(12) / -127 /
|
||||
C DATA IMACH(13) / 127 /
|
||||
C DATA IMACH(14) / 38 /
|
||||
C DATA IMACH(15) / -127 /
|
||||
C DATA IMACH(16) / 127 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE HONEYWELL 600/6000 SERIES
|
||||
C
|
||||
C DATA IMACH( 1) / 5 /
|
||||
C DATA IMACH( 2) / 6 /
|
||||
C DATA IMACH( 3) / 43 /
|
||||
C DATA IMACH( 4) / 6 /
|
||||
C DATA IMACH( 5) / 36 /
|
||||
C DATA IMACH( 6) / 6 /
|
||||
C DATA IMACH( 7) / 2 /
|
||||
C DATA IMACH( 8) / 35 /
|
||||
C DATA IMACH( 9) / O377777777777 /
|
||||
C DATA IMACH(10) / 2 /
|
||||
C DATA IMACH(11) / 27 /
|
||||
C DATA IMACH(12) / -127 /
|
||||
C DATA IMACH(13) / 127 /
|
||||
C DATA IMACH(14) / 63 /
|
||||
C DATA IMACH(15) / -127 /
|
||||
C DATA IMACH(16) / 127 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE HP 2100
|
||||
C 3 WORD DOUBLE PRECISION OPTION WITH FTN4
|
||||
C
|
||||
C DATA IMACH(1) / 5/
|
||||
C DATA IMACH(2) / 6 /
|
||||
C DATA IMACH(3) / 4 /
|
||||
C DATA IMACH(4) / 1 /
|
||||
C DATA IMACH(5) / 16 /
|
||||
C DATA IMACH(6) / 2 /
|
||||
C DATA IMACH(7) / 2 /
|
||||
C DATA IMACH(8) / 15 /
|
||||
C DATA IMACH(9) / 32767 /
|
||||
C DATA IMACH(10)/ 2 /
|
||||
C DATA IMACH(11)/ 23 /
|
||||
C DATA IMACH(12)/ -128 /
|
||||
C DATA IMACH(13)/ 127 /
|
||||
C DATA IMACH(14)/ 39 /
|
||||
C DATA IMACH(15)/ -128 /
|
||||
C DATA IMACH(16)/ 127 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE HP 2100
|
||||
C 4 WORD DOUBLE PRECISION OPTION WITH FTN4
|
||||
C
|
||||
C DATA IMACH(1) / 5 /
|
||||
C DATA IMACH(2) / 6 /
|
||||
C DATA IMACH(3) / 4 /
|
||||
C DATA IMACH(4) / 1 /
|
||||
C DATA IMACH(5) / 16 /
|
||||
C DATA IMACH(6) / 2 /
|
||||
C DATA IMACH(7) / 2 /
|
||||
C DATA IMACH(8) / 15 /
|
||||
C DATA IMACH(9) / 32767 /
|
||||
C DATA IMACH(10)/ 2 /
|
||||
C DATA IMACH(11)/ 23 /
|
||||
C DATA IMACH(12)/ -128 /
|
||||
C DATA IMACH(13)/ 127 /
|
||||
C DATA IMACH(14)/ 55 /
|
||||
C DATA IMACH(15)/ -128 /
|
||||
C DATA IMACH(16)/ 127 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE HP 9000
|
||||
C
|
||||
C DATA IMACH(1) / 5 /
|
||||
C DATA IMACH(2) / 6 /
|
||||
C DATA IMACH(3) / 6 /
|
||||
C DATA IMACH(3) / 7 /
|
||||
C DATA IMACH(5) / 32 /
|
||||
C DATA IMACH(6) / 4 /
|
||||
C DATA IMACH(7) / 2 /
|
||||
C DATA IMACH(8) / 32 /
|
||||
C DATA IMACH(9) /2147483647 /
|
||||
C DATA IMACH(10) / 2 /
|
||||
C DATA IMACH(11) / 24 /
|
||||
C DATA IMACH(12) / -126 /
|
||||
C DATA IMACH(13) / 127 /
|
||||
C DATA IMACH(14) / 53 /
|
||||
C DATA IMACH(15) /-1015 /
|
||||
C DATA IMACH(16) / 1017 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE IBM 360/370 SERIES,
|
||||
C THE XEROX SIGMA 5/7/9, THE SEL SYSTEMS 85/86, AND
|
||||
C THE PERKIN ELMER (INTERDATA) 7/32.
|
||||
C
|
||||
C DATA IMACH( 1) / 5 /
|
||||
C DATA IMACH( 2) / 6 /
|
||||
C DATA IMACH( 3) / 7 /
|
||||
C DATA IMACH( 4) / 6 /
|
||||
C DATA IMACH( 5) / 32 /
|
||||
C DATA IMACH( 6) / 4 /
|
||||
C DATA IMACH( 7) / 16 /
|
||||
C DATA IMACH( 8) / 31 /
|
||||
C DATA IMACH( 9) / Z7FFFFFFF /
|
||||
C DATA IMACH(10) / 16 /
|
||||
C DATA IMACH(11) / 6 /
|
||||
C DATA IMACH(12) / -64 /
|
||||
C DATA IMACH(13) / 63 /
|
||||
C DATA IMACH(14) / 14 /
|
||||
C DATA IMACH(15) / -64 /
|
||||
C DATA IMACH(16) / 63 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE IBM PC
|
||||
C
|
||||
C DATA IMACH( 1) / 5 /
|
||||
C DATA IMACH( 2) / 6 /
|
||||
C DATA IMACH( 3) / 0 /
|
||||
C DATA IMACH( 4) / 0 /
|
||||
C DATA IMACH( 5) / 32 /
|
||||
C DATA IMACH( 6) / 4 /
|
||||
C DATA IMACH( 7) / 2 /
|
||||
C DATA IMACH( 8) / 31 /
|
||||
C DATA IMACH( 9) / 2147483647 /
|
||||
C DATA IMACH(10) / 2 /
|
||||
C DATA IMACH(11) / 24 /
|
||||
C DATA IMACH(12) / -125 /
|
||||
C DATA IMACH(13) / 127 /
|
||||
C DATA IMACH(14) / 53 /
|
||||
C DATA IMACH(15) / -1021 /
|
||||
C DATA IMACH(16) / 1023 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE IBM RS 6000
|
||||
C
|
||||
C DATA IMACH( 1) / 5 /
|
||||
C DATA IMACH( 2) / 6 /
|
||||
C DATA IMACH( 3) / 6 /
|
||||
C DATA IMACH( 4) / 0 /
|
||||
C DATA IMACH( 5) / 32 /
|
||||
C DATA IMACH( 6) / 4 /
|
||||
C DATA IMACH( 7) / 2 /
|
||||
C DATA IMACH( 8) / 31 /
|
||||
C DATA IMACH( 9) / 2147483647 /
|
||||
C DATA IMACH(10) / 2 /
|
||||
C DATA IMACH(11) / 24 /
|
||||
C DATA IMACH(12) / -125 /
|
||||
C DATA IMACH(13) / 128 /
|
||||
C DATA IMACH(14) / 53 /
|
||||
C DATA IMACH(15) / -1021 /
|
||||
C DATA IMACH(16) / 1024 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE PDP-10 (KA PROCESSOR)
|
||||
C
|
||||
C DATA IMACH( 1) / 5 /
|
||||
C DATA IMACH( 2) / 6 /
|
||||
C DATA IMACH( 3) / 5 /
|
||||
C DATA IMACH( 4) / 6 /
|
||||
C DATA IMACH( 5) / 36 /
|
||||
C DATA IMACH( 6) / 5 /
|
||||
C DATA IMACH( 7) / 2 /
|
||||
C DATA IMACH( 8) / 35 /
|
||||
C DATA IMACH( 9) / "377777777777 /
|
||||
C DATA IMACH(10) / 2 /
|
||||
C DATA IMACH(11) / 27 /
|
||||
C DATA IMACH(12) / -128 /
|
||||
C DATA IMACH(13) / 127 /
|
||||
C DATA IMACH(14) / 54 /
|
||||
C DATA IMACH(15) / -101 /
|
||||
C DATA IMACH(16) / 127 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE PDP-10 (KI PROCESSOR)
|
||||
C
|
||||
C DATA IMACH( 1) / 5 /
|
||||
C DATA IMACH( 2) / 6 /
|
||||
C DATA IMACH( 3) / 5 /
|
||||
C DATA IMACH( 4) / 6 /
|
||||
C DATA IMACH( 5) / 36 /
|
||||
C DATA IMACH( 6) / 5 /
|
||||
C DATA IMACH( 7) / 2 /
|
||||
C DATA IMACH( 8) / 35 /
|
||||
C DATA IMACH( 9) / "377777777777 /
|
||||
C DATA IMACH(10) / 2 /
|
||||
C DATA IMACH(11) / 27 /
|
||||
C DATA IMACH(12) / -128 /
|
||||
C DATA IMACH(13) / 127 /
|
||||
C DATA IMACH(14) / 62 /
|
||||
C DATA IMACH(15) / -128 /
|
||||
C DATA IMACH(16) / 127 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING
|
||||
C 32-BIT INTEGER ARITHMETIC.
|
||||
C
|
||||
C DATA IMACH( 1) / 5 /
|
||||
C DATA IMACH( 2) / 6 /
|
||||
C DATA IMACH( 3) / 5 /
|
||||
C DATA IMACH( 4) / 6 /
|
||||
C DATA IMACH( 5) / 32 /
|
||||
C DATA IMACH( 6) / 4 /
|
||||
C DATA IMACH( 7) / 2 /
|
||||
C DATA IMACH( 8) / 31 /
|
||||
C DATA IMACH( 9) / 2147483647 /
|
||||
C DATA IMACH(10) / 2 /
|
||||
C DATA IMACH(11) / 24 /
|
||||
C DATA IMACH(12) / -127 /
|
||||
C DATA IMACH(13) / 127 /
|
||||
C DATA IMACH(14) / 56 /
|
||||
C DATA IMACH(15) / -127 /
|
||||
C DATA IMACH(16) / 127 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR PDP-11 FORTRAN SUPPORTING
|
||||
C 16-BIT INTEGER ARITHMETIC.
|
||||
C
|
||||
C DATA IMACH( 1) / 5 /
|
||||
C DATA IMACH( 2) / 6 /
|
||||
C DATA IMACH( 3) / 5 /
|
||||
C DATA IMACH( 4) / 6 /
|
||||
C DATA IMACH( 5) / 16 /
|
||||
C DATA IMACH( 6) / 2 /
|
||||
C DATA IMACH( 7) / 2 /
|
||||
C DATA IMACH( 8) / 15 /
|
||||
C DATA IMACH( 9) / 32767 /
|
||||
C DATA IMACH(10) / 2 /
|
||||
C DATA IMACH(11) / 24 /
|
||||
C DATA IMACH(12) / -127 /
|
||||
C DATA IMACH(13) / 127 /
|
||||
C DATA IMACH(14) / 56 /
|
||||
C DATA IMACH(15) / -127 /
|
||||
C DATA IMACH(16) / 127 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE SILICON GRAPHICS IRIS
|
||||
C
|
||||
C DATA IMACH( 1) / 5 /
|
||||
C DATA IMACH( 2) / 6 /
|
||||
C DATA IMACH( 3) / 6 /
|
||||
C DATA IMACH( 4) / 0 /
|
||||
C DATA IMACH( 5) / 32 /
|
||||
C DATA IMACH( 6) / 4 /
|
||||
C DATA IMACH( 7) / 2 /
|
||||
C DATA IMACH( 8) / 31 /
|
||||
C DATA IMACH( 9) / 2147483647 /
|
||||
C DATA IMACH(10) / 2 /
|
||||
C DATA IMACH(11) / 23 /
|
||||
C DATA IMACH(12) / -126 /
|
||||
C DATA IMACH(13) / 127 /
|
||||
C DATA IMACH(14) / 52 /
|
||||
C DATA IMACH(15) / -1022 /
|
||||
C DATA IMACH(16) / 1023 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE SUN
|
||||
C
|
||||
C DATA IMACH(1) / 5 /
|
||||
C DATA IMACH(2) / 6 /
|
||||
C DATA IMACH(3) / 6 /
|
||||
C DATA IMACH(4) / 6 /
|
||||
C DATA IMACH(5) / 32 /
|
||||
C DATA IMACH(6) / 4 /
|
||||
C DATA IMACH(7) / 2 /
|
||||
C DATA IMACH(8) / 31 /
|
||||
C DATA IMACH(9) /2147483647 /
|
||||
C DATA IMACH(10)/ 2 /
|
||||
C DATA IMACH(11)/ 24 /
|
||||
C DATA IMACH(12)/ -125 /
|
||||
C DATA IMACH(13)/ 128 /
|
||||
C DATA IMACH(14)/ 53 /
|
||||
C DATA IMACH(15)/ -1021 /
|
||||
C DATA IMACH(16)/ 1024 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE UNIVAC 1100 SERIES FTN COMPILER
|
||||
C
|
||||
C
|
||||
C DATA IMACH( 1) / 5 /
|
||||
C DATA IMACH( 2) / 6 /
|
||||
C DATA IMACH( 3) / 1 /
|
||||
C DATA IMACH( 4) / 6 /
|
||||
C DATA IMACH( 5) / 36 /
|
||||
C DATA IMACH( 6) / 4 /
|
||||
C DATA IMACH( 7) / 2 /
|
||||
C DATA IMACH( 8) / 35 /
|
||||
C DATA IMACH( 9) / O377777777777 /
|
||||
C DATA IMACH(10) / 2 /
|
||||
C DATA IMACH(11) / 27 /
|
||||
C DATA IMACH(12) / -128 /
|
||||
C DATA IMACH(13) / 127 /
|
||||
C DATA IMACH(14) / 60 /
|
||||
C DATA IMACH(15) /-1024 /
|
||||
C DATA IMACH(16) / 1023 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE VAX 11/780
|
||||
C
|
||||
C DATA IMACH(1) / 5 /
|
||||
C DATA IMACH(2) / 6 /
|
||||
C DATA IMACH(3) / 5 /
|
||||
C DATA IMACH(4) / 6 /
|
||||
C DATA IMACH(5) / 32 /
|
||||
C DATA IMACH(6) / 4 /
|
||||
C DATA IMACH(7) / 2 /
|
||||
C DATA IMACH(8) / 31 /
|
||||
C DATA IMACH(9) /2147483647 /
|
||||
C DATA IMACH(10)/ 2 /
|
||||
C DATA IMACH(11)/ 24 /
|
||||
C DATA IMACH(12)/ -127 /
|
||||
C DATA IMACH(13)/ 127 /
|
||||
C DATA IMACH(14)/ 56 /
|
||||
C DATA IMACH(15)/ -127 /
|
||||
C DATA IMACH(16)/ 127 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE VAX 11/780, G-FLOAT OPTION
|
||||
C
|
||||
C DATA IMACH(1) / 5 /
|
||||
C DATA IMACH(2) / 6 /
|
||||
C DATA IMACH(3) / 5 /
|
||||
C DATA IMACH(4) / 6 /
|
||||
C DATA IMACH(5) / 32 /
|
||||
C DATA IMACH(6) / 4 /
|
||||
C DATA IMACH(7) / 2 /
|
||||
C DATA IMACH(8) / 31 /
|
||||
C DATA IMACH(9) /2147483647 /
|
||||
C DATA IMACH(10)/ 2 /
|
||||
C DATA IMACH(11)/ 24 /
|
||||
C DATA IMACH(12)/ -127 /
|
||||
C DATA IMACH(13)/ 127 /
|
||||
C DATA IMACH(14)/ 53 /
|
||||
C DATA IMACH(15)/ -1022 /
|
||||
C DATA IMACH(16)/ 1023 /
|
||||
C
|
||||
C MACHINE CONSTANTS FOR THE Z80 MICROPROCESSOR
|
||||
C
|
||||
C DATA IMACH( 1) / 1/
|
||||
C DATA IMACH( 2) / 1/
|
||||
C DATA IMACH( 3) / 0/
|
||||
C DATA IMACH( 4) / 1/
|
||||
C DATA IMACH( 5) / 16/
|
||||
C DATA IMACH( 6) / 2/
|
||||
C DATA IMACH( 7) / 2/
|
||||
C DATA IMACH( 8) / 15/
|
||||
C DATA IMACH( 9) / 32767/
|
||||
C DATA IMACH(10) / 2/
|
||||
C DATA IMACH(11) / 24/
|
||||
C DATA IMACH(12) / -127/
|
||||
C DATA IMACH(13) / 127/
|
||||
C DATA IMACH(14) / 56/
|
||||
C DATA IMACH(15) / -127/
|
||||
C DATA IMACH(16) / 127/
|
||||
C
|
||||
C
|
||||
C***FIRST EXECUTABLE STATEMENT I1MACH
|
||||
IF (I .LT. 1 .OR. I .GT. 16) GO TO 10
|
||||
C
|
||||
I1MACH = IMACH(I)
|
||||
RETURN
|
||||
C
|
||||
10 CONTINUE
|
||||
WRITE (UNIT = OUTPUT, FMT = 9000)
|
||||
9000 FORMAT ('1ERROR 1 IN I1MACH - I OUT OF BOUNDS')
|
||||
C
|
||||
C CALL FDUMP
|
||||
C
|
||||
C
|
||||
STOP
|
||||
END
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
SUBROUTINE XERROR(MESS,NMESS,L1,L2)
|
||||
C
|
||||
C THIS IS A DUMMY XERROR ROUTINE TO PRINT ERROR MESSAGES WITH NMESS
|
||||
C CHARACTERS. L1 AND L2 ARE DUMMY PARAMETERS TO MAKE THIS CALL
|
||||
C COMPATIBLE WITH THE SLATEC XERROR ROUTINE. THIS IS A FORTRAN 77
|
||||
C ROUTINE.
|
||||
C
|
||||
CHARACTER*(*) MESS
|
||||
NN=NMESS/70
|
||||
NR=NMESS-70*NN
|
||||
IF(NR.NE.0) NN=NN+1
|
||||
K=1
|
||||
PRINT 900
|
||||
900 FORMAT(/)
|
||||
DO 10 I=1,NN
|
||||
KMIN=MIN0(K+69,NMESS)
|
||||
PRINT *, MESS(K:KMIN)
|
||||
K=K+70
|
||||
10 CONTINUE
|
||||
PRINT 900
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,29 @@
|
|||
DOUBLE PRECISION FUNCTION ZABS(ZR, ZI)
|
||||
C***BEGIN PROLOGUE ZABS
|
||||
C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
|
||||
C
|
||||
C ZABS COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE
|
||||
C PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI)
|
||||
C
|
||||
C***ROUTINES CALLED (NONE)
|
||||
C***END PROLOGUE ZABS
|
||||
DOUBLE PRECISION ZR, ZI, U, V, Q, S
|
||||
U = DABS(ZR)
|
||||
V = DABS(ZI)
|
||||
S = U + V
|
||||
C-----------------------------------------------------------------------
|
||||
C S*1.0D0 MAKES AN UNNORMALIZED UNDERFLOW ON CDC MACHINES INTO A
|
||||
C TRUE FLOATING ZERO
|
||||
C-----------------------------------------------------------------------
|
||||
S = S*1.0D+0
|
||||
IF (S.EQ.0.0D+0) GO TO 20
|
||||
IF (U.GT.V) GO TO 10
|
||||
Q = U/V
|
||||
ZABS = V*DSQRT(1.D+0+Q*Q)
|
||||
RETURN
|
||||
10 Q = V/U
|
||||
ZABS = U*DSQRT(1.D+0+Q*Q)
|
||||
RETURN
|
||||
20 ZABS = 0.0D+0
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,99 @@
|
|||
SUBROUTINE ZACAI(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, TOL,
|
||||
* ELIM, ALIM)
|
||||
C***BEGIN PROLOGUE ZACAI
|
||||
C***REFER TO ZAIRY
|
||||
C
|
||||
C ZACAI APPLIES THE ANALYTIC CONTINUATION FORMULA
|
||||
C
|
||||
C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN)
|
||||
C MP=PI*MR*CMPLX(0.0,1.0)
|
||||
C
|
||||
C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT
|
||||
C HALF Z PLANE FOR USE WITH ZAIRY WHERE FNU=1/3 OR 2/3 AND N=1.
|
||||
C ZACAI IS THE SAME AS ZACON WITH THE PARTS FOR LARGER ORDERS AND
|
||||
C RECURRENCE REMOVED. A RECURSIVE CALL TO ZACON CAN RESULT IF ZACON
|
||||
C IS CALLED FROM ZAIRY.
|
||||
C
|
||||
C***ROUTINES CALLED ZASYI,ZBKNU,ZMLRI,ZSERI,ZS1S2,D1MACH,ZABS
|
||||
C***END PROLOGUE ZACAI
|
||||
C COMPLEX CSGN,CSPN,C1,C2,Y,Z,ZN,CY
|
||||
DOUBLE PRECISION ALIM, ARG, ASCLE, AZ, CSGNR, CSGNI, CSPNR,
|
||||
* CSPNI, C1R, C1I, C2R, C2I, CYR, CYI, DFNU, ELIM, FMR, FNU, PI,
|
||||
* RL, SGN, TOL, YY, YR, YI, ZR, ZI, ZNR, ZNI, D1MACH, ZABS
|
||||
INTEGER INU, IUF, KODE, MR, N, NN, NW, NZ
|
||||
DIMENSION YR(N), YI(N), CYR(2), CYI(2)
|
||||
DATA PI / 3.14159265358979324D0 /
|
||||
NZ = 0
|
||||
ZNR = -ZR
|
||||
ZNI = -ZI
|
||||
AZ = ZABS(ZR,ZI)
|
||||
NN = N
|
||||
DFNU = FNU + DBLE(FLOAT(N-1))
|
||||
IF (AZ.LE.2.0D0) GO TO 10
|
||||
IF (AZ*AZ*0.25D0.GT.DFNU+1.0D0) GO TO 20
|
||||
10 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C POWER SERIES FOR THE I FUNCTION
|
||||
C-----------------------------------------------------------------------
|
||||
CALL ZSERI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL, ELIM, ALIM)
|
||||
GO TO 40
|
||||
20 CONTINUE
|
||||
IF (AZ.LT.RL) GO TO 30
|
||||
C-----------------------------------------------------------------------
|
||||
C ASYMPTOTIC EXPANSION FOR LARGE Z FOR THE I FUNCTION
|
||||
C-----------------------------------------------------------------------
|
||||
CALL ZASYI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, TOL, ELIM,
|
||||
* ALIM)
|
||||
IF (NW.LT.0) GO TO 80
|
||||
GO TO 40
|
||||
30 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C MILLER ALGORITHM NORMALIZED BY THE SERIES FOR THE I FUNCTION
|
||||
C-----------------------------------------------------------------------
|
||||
CALL ZMLRI(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, TOL)
|
||||
IF(NW.LT.0) GO TO 80
|
||||
40 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION
|
||||
C-----------------------------------------------------------------------
|
||||
CALL ZBKNU(ZNR, ZNI, FNU, KODE, 1, CYR, CYI, NW, TOL, ELIM, ALIM)
|
||||
IF (NW.NE.0) GO TO 80
|
||||
FMR = DBLE(FLOAT(MR))
|
||||
SGN = -DSIGN(PI,FMR)
|
||||
CSGNR = 0.0D0
|
||||
CSGNI = SGN
|
||||
IF (KODE.EQ.1) GO TO 50
|
||||
YY = -ZNI
|
||||
CSGNR = -CSGNI*DSIN(YY)
|
||||
CSGNI = CSGNI*DCOS(YY)
|
||||
50 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
|
||||
C WHEN FNU IS LARGE
|
||||
C-----------------------------------------------------------------------
|
||||
INU = INT(SNGL(FNU))
|
||||
ARG = (FNU-DBLE(FLOAT(INU)))*SGN
|
||||
CSPNR = DCOS(ARG)
|
||||
CSPNI = DSIN(ARG)
|
||||
IF (MOD(INU,2).EQ.0) GO TO 60
|
||||
CSPNR = -CSPNR
|
||||
CSPNI = -CSPNI
|
||||
60 CONTINUE
|
||||
C1R = CYR(1)
|
||||
C1I = CYI(1)
|
||||
C2R = YR(1)
|
||||
C2I = YI(1)
|
||||
IF (KODE.EQ.1) GO TO 70
|
||||
IUF = 0
|
||||
ASCLE = 1.0D+3*D1MACH(1)/TOL
|
||||
CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF)
|
||||
NZ = NZ + NW
|
||||
70 CONTINUE
|
||||
YR(1) = CSPNR*C1R - CSPNI*C1I + CSGNR*C2R - CSGNI*C2I
|
||||
YI(1) = CSPNR*C1I + CSPNI*C1R + CSGNR*C2I + CSGNI*C2R
|
||||
RETURN
|
||||
80 CONTINUE
|
||||
NZ = -1
|
||||
IF(NW.EQ.(-2)) NZ=-2
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,203 @@
|
|||
SUBROUTINE ZACON(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, FNUL,
|
||||
* TOL, ELIM, ALIM)
|
||||
C***BEGIN PROLOGUE ZACON
|
||||
C***REFER TO ZBESK,ZBESH
|
||||
C
|
||||
C ZACON APPLIES THE ANALYTIC CONTINUATION FORMULA
|
||||
C
|
||||
C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN)
|
||||
C MP=PI*MR*CMPLX(0.0,1.0)
|
||||
C
|
||||
C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT
|
||||
C HALF Z PLANE
|
||||
C
|
||||
C***ROUTINES CALLED ZBINU,ZBKNU,ZS1S2,D1MACH,ZABS,ZMLT
|
||||
C***END PROLOGUE ZACON
|
||||
C COMPLEX CK,CONE,CSCL,CSCR,CSGN,CSPN,CY,CZERO,C1,C2,RZ,SC1,SC2,ST,
|
||||
C *S1,S2,Y,Z,ZN
|
||||
DOUBLE PRECISION ALIM, ARG, ASCLE, AS2, AZN, BRY, BSCLE, CKI,
|
||||
* CKR, CONER, CPN, CSCL, CSCR, CSGNI, CSGNR, CSPNI, CSPNR,
|
||||
* CSR, CSRR, CSSR, CYI, CYR, C1I, C1M, C1R, C2I, C2R, ELIM, FMR,
|
||||
* FN, FNU, FNUL, PI, PTI, PTR, RAZN, RL, RZI, RZR, SC1I, SC1R,
|
||||
* SC2I, SC2R, SGN, SPN, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR,
|
||||
* YY, ZEROR, ZI, ZNI, ZNR, ZR, D1MACH, ZABS
|
||||
INTEGER I, INU, IUF, KFLAG, KODE, MR, N, NN, NW, NZ
|
||||
DIMENSION YR(N), YI(N), CYR(2), CYI(2), CSSR(3), CSRR(3), BRY(3)
|
||||
DATA PI / 3.14159265358979324D0 /
|
||||
DATA ZEROR,CONER / 0.0D0,1.0D0 /
|
||||
NZ = 0
|
||||
ZNR = -ZR
|
||||
ZNI = -ZI
|
||||
NN = N
|
||||
CALL ZBINU(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, FNUL, TOL,
|
||||
* ELIM, ALIM)
|
||||
IF (NW.LT.0) GO TO 90
|
||||
C-----------------------------------------------------------------------
|
||||
C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION
|
||||
C-----------------------------------------------------------------------
|
||||
NN = MIN0(2,N)
|
||||
CALL ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM)
|
||||
IF (NW.NE.0) GO TO 90
|
||||
S1R = CYR(1)
|
||||
S1I = CYI(1)
|
||||
FMR = DBLE(FLOAT(MR))
|
||||
SGN = -DSIGN(PI,FMR)
|
||||
CSGNR = ZEROR
|
||||
CSGNI = SGN
|
||||
IF (KODE.EQ.1) GO TO 10
|
||||
YY = -ZNI
|
||||
CPN = DCOS(YY)
|
||||
SPN = DSIN(YY)
|
||||
CALL ZMLT(CSGNR, CSGNI, CPN, SPN, CSGNR, CSGNI)
|
||||
10 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
|
||||
C WHEN FNU IS LARGE
|
||||
C-----------------------------------------------------------------------
|
||||
INU = INT(SNGL(FNU))
|
||||
ARG = (FNU-DBLE(FLOAT(INU)))*SGN
|
||||
CPN = DCOS(ARG)
|
||||
SPN = DSIN(ARG)
|
||||
CSPNR = CPN
|
||||
CSPNI = SPN
|
||||
IF (MOD(INU,2).EQ.0) GO TO 20
|
||||
CSPNR = -CSPNR
|
||||
CSPNI = -CSPNI
|
||||
20 CONTINUE
|
||||
IUF = 0
|
||||
C1R = S1R
|
||||
C1I = S1I
|
||||
C2R = YR(1)
|
||||
C2I = YI(1)
|
||||
ASCLE = 1.0D+3*D1MACH(1)/TOL
|
||||
IF (KODE.EQ.1) GO TO 30
|
||||
CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF)
|
||||
NZ = NZ + NW
|
||||
SC1R = C1R
|
||||
SC1I = C1I
|
||||
30 CONTINUE
|
||||
CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI)
|
||||
CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI)
|
||||
YR(1) = STR + PTR
|
||||
YI(1) = STI + PTI
|
||||
IF (N.EQ.1) RETURN
|
||||
CSPNR = -CSPNR
|
||||
CSPNI = -CSPNI
|
||||
S2R = CYR(2)
|
||||
S2I = CYI(2)
|
||||
C1R = S2R
|
||||
C1I = S2I
|
||||
C2R = YR(2)
|
||||
C2I = YI(2)
|
||||
IF (KODE.EQ.1) GO TO 40
|
||||
CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF)
|
||||
NZ = NZ + NW
|
||||
SC2R = C1R
|
||||
SC2I = C1I
|
||||
40 CONTINUE
|
||||
CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI)
|
||||
CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI)
|
||||
YR(2) = STR + PTR
|
||||
YI(2) = STI + PTI
|
||||
IF (N.EQ.2) RETURN
|
||||
CSPNR = -CSPNR
|
||||
CSPNI = -CSPNI
|
||||
AZN = ZABS(ZNR,ZNI)
|
||||
RAZN = 1.0D0/AZN
|
||||
STR = ZNR*RAZN
|
||||
STI = -ZNI*RAZN
|
||||
RZR = (STR+STR)*RAZN
|
||||
RZI = (STI+STI)*RAZN
|
||||
FN = FNU + 1.0D0
|
||||
CKR = FN*RZR
|
||||
CKI = FN*RZI
|
||||
C-----------------------------------------------------------------------
|
||||
C SCALE NEAR EXPONENT EXTREMES DURING RECURRENCE ON K FUNCTIONS
|
||||
C-----------------------------------------------------------------------
|
||||
CSCL = 1.0D0/TOL
|
||||
CSCR = TOL
|
||||
CSSR(1) = CSCL
|
||||
CSSR(2) = CONER
|
||||
CSSR(3) = CSCR
|
||||
CSRR(1) = CSCR
|
||||
CSRR(2) = CONER
|
||||
CSRR(3) = CSCL
|
||||
BRY(1) = ASCLE
|
||||
BRY(2) = 1.0D0/ASCLE
|
||||
BRY(3) = D1MACH(2)
|
||||
AS2 = ZABS(S2R,S2I)
|
||||
KFLAG = 2
|
||||
IF (AS2.GT.BRY(1)) GO TO 50
|
||||
KFLAG = 1
|
||||
GO TO 60
|
||||
50 CONTINUE
|
||||
IF (AS2.LT.BRY(2)) GO TO 60
|
||||
KFLAG = 3
|
||||
60 CONTINUE
|
||||
BSCLE = BRY(KFLAG)
|
||||
S1R = S1R*CSSR(KFLAG)
|
||||
S1I = S1I*CSSR(KFLAG)
|
||||
S2R = S2R*CSSR(KFLAG)
|
||||
S2I = S2I*CSSR(KFLAG)
|
||||
CSR = CSRR(KFLAG)
|
||||
DO 80 I=3,N
|
||||
STR = S2R
|
||||
STI = S2I
|
||||
S2R = CKR*STR - CKI*STI + S1R
|
||||
S2I = CKR*STI + CKI*STR + S1I
|
||||
S1R = STR
|
||||
S1I = STI
|
||||
C1R = S2R*CSR
|
||||
C1I = S2I*CSR
|
||||
STR = C1R
|
||||
STI = C1I
|
||||
C2R = YR(I)
|
||||
C2I = YI(I)
|
||||
IF (KODE.EQ.1) GO TO 70
|
||||
IF (IUF.LT.0) GO TO 70
|
||||
CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF)
|
||||
NZ = NZ + NW
|
||||
SC1R = SC2R
|
||||
SC1I = SC2I
|
||||
SC2R = C1R
|
||||
SC2I = C1I
|
||||
IF (IUF.NE.3) GO TO 70
|
||||
IUF = -4
|
||||
S1R = SC1R*CSSR(KFLAG)
|
||||
S1I = SC1I*CSSR(KFLAG)
|
||||
S2R = SC2R*CSSR(KFLAG)
|
||||
S2I = SC2I*CSSR(KFLAG)
|
||||
STR = SC2R
|
||||
STI = SC2I
|
||||
70 CONTINUE
|
||||
PTR = CSPNR*C1R - CSPNI*C1I
|
||||
PTI = CSPNR*C1I + CSPNI*C1R
|
||||
YR(I) = PTR + CSGNR*C2R - CSGNI*C2I
|
||||
YI(I) = PTI + CSGNR*C2I + CSGNI*C2R
|
||||
CKR = CKR + RZR
|
||||
CKI = CKI + RZI
|
||||
CSPNR = -CSPNR
|
||||
CSPNI = -CSPNI
|
||||
IF (KFLAG.GE.3) GO TO 80
|
||||
PTR = DABS(C1R)
|
||||
PTI = DABS(C1I)
|
||||
C1M = DMAX1(PTR,PTI)
|
||||
IF (C1M.LE.BSCLE) GO TO 80
|
||||
KFLAG = KFLAG + 1
|
||||
BSCLE = BRY(KFLAG)
|
||||
S1R = S1R*CSR
|
||||
S1I = S1I*CSR
|
||||
S2R = STR
|
||||
S2I = STI
|
||||
S1R = S1R*CSSR(KFLAG)
|
||||
S1I = S1I*CSSR(KFLAG)
|
||||
S2R = S2R*CSSR(KFLAG)
|
||||
S2I = S2I*CSSR(KFLAG)
|
||||
CSR = CSRR(KFLAG)
|
||||
80 CONTINUE
|
||||
RETURN
|
||||
90 CONTINUE
|
||||
NZ = -1
|
||||
IF(NW.EQ.(-2)) NZ=-2
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,393 @@
|
|||
SUBROUTINE ZAIRY(ZR, ZI, ID, KODE, AIR, AII, NZ, IERR)
|
||||
C***BEGIN PROLOGUE ZAIRY
|
||||
C***DATE WRITTEN 830501 (YYMMDD)
|
||||
C***REVISION DATE 890801 (YYMMDD)
|
||||
C***CATEGORY NO. B5K
|
||||
C***KEYWORDS AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD
|
||||
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
|
||||
C***PURPOSE TO COMPUTE AIRY FUNCTIONS AI(Z) AND DAI(Z) FOR COMPLEX Z
|
||||
C***DESCRIPTION
|
||||
C
|
||||
C ***A DOUBLE PRECISION ROUTINE***
|
||||
C ON KODE=1, ZAIRY COMPUTES THE COMPLEX AIRY FUNCTION AI(Z) OR
|
||||
C ITS DERIVATIVE DAI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON
|
||||
C KODE=2, A SCALING OPTION CEXP(ZTA)*AI(Z) OR CEXP(ZTA)*
|
||||
C DAI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL DECAY IN
|
||||
C -PI/3.LT.ARG(Z).LT.PI/3 AND THE EXPONENTIAL GROWTH IN
|
||||
C PI/3.LT.ABS(ARG(Z)).LT.PI WHERE ZTA=(2/3)*Z*CSQRT(Z).
|
||||
C
|
||||
C WHILE THE AIRY FUNCTIONS AI(Z) AND DAI(Z)/DZ ARE ANALYTIC IN
|
||||
C THE WHOLE Z PLANE, THE CORRESPONDING SCALED FUNCTIONS DEFINED
|
||||
C FOR KODE=2 HAVE A CUT ALONG THE NEGATIVE REAL AXIS.
|
||||
C DEFINTIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF
|
||||
C MATHEMATICAL FUNCTIONS (REF. 1).
|
||||
C
|
||||
C INPUT ZR,ZI ARE DOUBLE PRECISION
|
||||
C ZR,ZI - Z=CMPLX(ZR,ZI)
|
||||
C ID - ORDER OF DERIVATIVE, ID=0 OR ID=1
|
||||
C KODE - A PARAMETER TO INDICATE THE SCALING OPTION
|
||||
C KODE= 1 RETURNS
|
||||
C AI=AI(Z) ON ID=0 OR
|
||||
C AI=DAI(Z)/DZ ON ID=1
|
||||
C = 2 RETURNS
|
||||
C AI=CEXP(ZTA)*AI(Z) ON ID=0 OR
|
||||
C AI=CEXP(ZTA)*DAI(Z)/DZ ON ID=1 WHERE
|
||||
C ZTA=(2/3)*Z*CSQRT(Z)
|
||||
C
|
||||
C OUTPUT AIR,AII ARE DOUBLE PRECISION
|
||||
C AIR,AII- COMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND
|
||||
C KODE
|
||||
C NZ - UNDERFLOW INDICATOR
|
||||
C NZ= 0 , NORMAL RETURN
|
||||
C NZ= 1 , AI=CMPLX(0.0D0,0.0D0) DUE TO UNDERFLOW IN
|
||||
C -PI/3.LT.ARG(Z).LT.PI/3 ON KODE=1
|
||||
C IERR - ERROR FLAG
|
||||
C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
|
||||
C IERR=1, INPUT ERROR - NO COMPUTATION
|
||||
C IERR=2, OVERFLOW - NO COMPUTATION, REAL(ZTA)
|
||||
C TOO LARGE ON KODE=1
|
||||
C IERR=3, CABS(Z) LARGE - COMPUTATION COMPLETED
|
||||
C LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION
|
||||
C PRODUCE LESS THAN HALF OF MACHINE ACCURACY
|
||||
C IERR=4, CABS(Z) TOO LARGE - NO COMPUTATION
|
||||
C COMPLETE LOSS OF ACCURACY BY ARGUMENT
|
||||
C REDUCTION
|
||||
C IERR=5, ERROR - NO COMPUTATION,
|
||||
C ALGORITHM TERMINATION CONDITION NOT MET
|
||||
C
|
||||
C***LONG DESCRIPTION
|
||||
C
|
||||
C AI AND DAI ARE COMPUTED FOR CABS(Z).GT.1.0 FROM THE K BESSEL
|
||||
C FUNCTIONS BY
|
||||
C
|
||||
C AI(Z)=C*SQRT(Z)*K(1/3,ZTA) , DAI(Z)=-C*Z*K(2/3,ZTA)
|
||||
C C=1.0/(PI*SQRT(3.0))
|
||||
C ZTA=(2/3)*Z**(3/2)
|
||||
C
|
||||
C WITH THE POWER SERIES FOR CABS(Z).LE.1.0.
|
||||
C
|
||||
C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
|
||||
C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES
|
||||
C OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF
|
||||
C THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR),
|
||||
C THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR
|
||||
C FLAG IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
|
||||
C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
|
||||
C ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN
|
||||
C ALL SIGNIFICANCE IS LOST AND IERR=4. IN ORDER TO USE THE INT
|
||||
C FUNCTION, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE
|
||||
C LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA
|
||||
C MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2,
|
||||
C AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE
|
||||
C PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE
|
||||
C PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT-
|
||||
C ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG-
|
||||
C NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN
|
||||
C DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN
|
||||
C EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES,
|
||||
C NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE
|
||||
C PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER
|
||||
C MACHINES.
|
||||
C
|
||||
C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
|
||||
C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
|
||||
C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
|
||||
C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
|
||||
C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
|
||||
C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
|
||||
C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
|
||||
C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
|
||||
C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
|
||||
C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
|
||||
C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
|
||||
C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
|
||||
C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
|
||||
C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
|
||||
C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
|
||||
C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
|
||||
C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
|
||||
C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
|
||||
C OR -PI/2+P.
|
||||
C
|
||||
C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
|
||||
C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
|
||||
C COMMERCE, 1955.
|
||||
C
|
||||
C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
|
||||
C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
|
||||
C
|
||||
C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
|
||||
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
|
||||
C 1018, MAY, 1985
|
||||
C
|
||||
C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
|
||||
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
|
||||
C MATH. SOFTWARE, 1986
|
||||
C
|
||||
C***ROUTINES CALLED ZACAI,ZBKNU,ZEXP,ZSQRT,I1MACH,D1MACH
|
||||
C***END PROLOGUE ZAIRY
|
||||
C COMPLEX AI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3
|
||||
DOUBLE PRECISION AA, AD, AII, AIR, AK, ALIM, ATRM, AZ, AZ3, BK,
|
||||
* CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2, DIG,
|
||||
* DK, D1, D2, ELIM, FID, FNU, PTR, RL, R1M5, SFAC, STI, STR,
|
||||
* S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I, TRM2R, TTH, ZEROI,
|
||||
* ZEROR, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS, ALAZ, BB
|
||||
INTEGER ID, IERR, IFLAG, K, KODE, K1, K2, MR, NN, NZ, I1MACH
|
||||
DIMENSION CYR(1), CYI(1)
|
||||
DATA TTH, C1, C2, COEF /6.66666666666666667D-01,
|
||||
* 3.55028053887817240D-01,2.58819403792806799D-01,
|
||||
* 1.83776298473930683D-01/
|
||||
DATA ZEROR, ZEROI, CONER, CONEI /0.0D0,0.0D0,1.0D0,0.0D0/
|
||||
C***FIRST EXECUTABLE STATEMENT ZAIRY
|
||||
IERR = 0
|
||||
NZ=0
|
||||
IF (ID.LT.0 .OR. ID.GT.1) IERR=1
|
||||
IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
|
||||
IF (IERR.NE.0) RETURN
|
||||
AZ = ZABS(ZR,ZI)
|
||||
TOL = DMAX1(D1MACH(4),1.0D-18)
|
||||
FID = DBLE(FLOAT(ID))
|
||||
IF (AZ.GT.1.0D0) GO TO 70
|
||||
C-----------------------------------------------------------------------
|
||||
C POWER SERIES FOR CABS(Z).LE.1.
|
||||
C-----------------------------------------------------------------------
|
||||
S1R = CONER
|
||||
S1I = CONEI
|
||||
S2R = CONER
|
||||
S2I = CONEI
|
||||
IF (AZ.LT.TOL) GO TO 170
|
||||
AA = AZ*AZ
|
||||
IF (AA.LT.TOL/AZ) GO TO 40
|
||||
TRM1R = CONER
|
||||
TRM1I = CONEI
|
||||
TRM2R = CONER
|
||||
TRM2I = CONEI
|
||||
ATRM = 1.0D0
|
||||
STR = ZR*ZR - ZI*ZI
|
||||
STI = ZR*ZI + ZI*ZR
|
||||
Z3R = STR*ZR - STI*ZI
|
||||
Z3I = STR*ZI + STI*ZR
|
||||
AZ3 = AZ*AA
|
||||
AK = 2.0D0 + FID
|
||||
BK = 3.0D0 - FID - FID
|
||||
CK = 4.0D0 - FID
|
||||
DK = 3.0D0 + FID + FID
|
||||
D1 = AK*DK
|
||||
D2 = BK*CK
|
||||
AD = DMIN1(D1,D2)
|
||||
AK = 24.0D0 + 9.0D0*FID
|
||||
BK = 30.0D0 - 9.0D0*FID
|
||||
DO 30 K=1,25
|
||||
STR = (TRM1R*Z3R-TRM1I*Z3I)/D1
|
||||
TRM1I = (TRM1R*Z3I+TRM1I*Z3R)/D1
|
||||
TRM1R = STR
|
||||
S1R = S1R + TRM1R
|
||||
S1I = S1I + TRM1I
|
||||
STR = (TRM2R*Z3R-TRM2I*Z3I)/D2
|
||||
TRM2I = (TRM2R*Z3I+TRM2I*Z3R)/D2
|
||||
TRM2R = STR
|
||||
S2R = S2R + TRM2R
|
||||
S2I = S2I + TRM2I
|
||||
ATRM = ATRM*AZ3/AD
|
||||
D1 = D1 + AK
|
||||
D2 = D2 + BK
|
||||
AD = DMIN1(D1,D2)
|
||||
IF (ATRM.LT.TOL*AD) GO TO 40
|
||||
AK = AK + 18.0D0
|
||||
BK = BK + 18.0D0
|
||||
30 CONTINUE
|
||||
40 CONTINUE
|
||||
IF (ID.EQ.1) GO TO 50
|
||||
AIR = S1R*C1 - C2*(ZR*S2R-ZI*S2I)
|
||||
AII = S1I*C1 - C2*(ZR*S2I+ZI*S2R)
|
||||
IF (KODE.EQ.1) RETURN
|
||||
CALL ZSQRT(ZR, ZI, STR, STI)
|
||||
ZTAR = TTH*(ZR*STR-ZI*STI)
|
||||
ZTAI = TTH*(ZR*STI+ZI*STR)
|
||||
CALL ZEXP(ZTAR, ZTAI, STR, STI)
|
||||
PTR = AIR*STR - AII*STI
|
||||
AII = AIR*STI + AII*STR
|
||||
AIR = PTR
|
||||
RETURN
|
||||
50 CONTINUE
|
||||
AIR = -S2R*C2
|
||||
AII = -S2I*C2
|
||||
IF (AZ.LE.TOL) GO TO 60
|
||||
STR = ZR*S1R - ZI*S1I
|
||||
STI = ZR*S1I + ZI*S1R
|
||||
CC = C1/(1.0D0+FID)
|
||||
AIR = AIR + CC*(STR*ZR-STI*ZI)
|
||||
AII = AII + CC*(STR*ZI+STI*ZR)
|
||||
60 CONTINUE
|
||||
IF (KODE.EQ.1) RETURN
|
||||
CALL ZSQRT(ZR, ZI, STR, STI)
|
||||
ZTAR = TTH*(ZR*STR-ZI*STI)
|
||||
ZTAI = TTH*(ZR*STI+ZI*STR)
|
||||
CALL ZEXP(ZTAR, ZTAI, STR, STI)
|
||||
PTR = STR*AIR - STI*AII
|
||||
AII = STR*AII + STI*AIR
|
||||
AIR = PTR
|
||||
RETURN
|
||||
C-----------------------------------------------------------------------
|
||||
C CASE FOR CABS(Z).GT.1.0
|
||||
C-----------------------------------------------------------------------
|
||||
70 CONTINUE
|
||||
FNU = (1.0D0+FID)/3.0D0
|
||||
C-----------------------------------------------------------------------
|
||||
C SET PARAMETERS RELATED TO MACHINE CONSTANTS.
|
||||
C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0D-18.
|
||||
C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
|
||||
C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND
|
||||
C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR
|
||||
C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
|
||||
C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
|
||||
C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
|
||||
C-----------------------------------------------------------------------
|
||||
K1 = I1MACH(15)
|
||||
K2 = I1MACH(16)
|
||||
R1M5 = D1MACH(5)
|
||||
K = MIN0(IABS(K1),IABS(K2))
|
||||
ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
|
||||
K1 = I1MACH(14) - 1
|
||||
AA = R1M5*DBLE(FLOAT(K1))
|
||||
DIG = DMIN1(AA,18.0D0)
|
||||
AA = AA*2.303D0
|
||||
ALIM = ELIM + DMAX1(-AA,-41.45D0)
|
||||
RL = 1.2D0*DIG + 3.0D0
|
||||
ALAZ = DLOG(AZ)
|
||||
C--------------------------------------------------------------------------
|
||||
C TEST FOR PROPER RANGE
|
||||
C-----------------------------------------------------------------------
|
||||
AA=0.5D0/TOL
|
||||
BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
|
||||
AA=DMIN1(AA,BB)
|
||||
AA=AA**TTH
|
||||
IF (AZ.GT.AA) GO TO 260
|
||||
AA=DSQRT(AA)
|
||||
IF (AZ.GT.AA) IERR=3
|
||||
CALL ZSQRT(ZR, ZI, CSQR, CSQI)
|
||||
ZTAR = TTH*(ZR*CSQR-ZI*CSQI)
|
||||
ZTAI = TTH*(ZR*CSQI+ZI*CSQR)
|
||||
C-----------------------------------------------------------------------
|
||||
C RE(ZTA).LE.0 WHEN RE(Z).LT.0, ESPECIALLY WHEN IM(Z) IS SMALL
|
||||
C-----------------------------------------------------------------------
|
||||
IFLAG = 0
|
||||
SFAC = 1.0D0
|
||||
AK = ZTAI
|
||||
IF (ZR.GE.0.0D0) GO TO 80
|
||||
BK = ZTAR
|
||||
CK = -DABS(BK)
|
||||
ZTAR = CK
|
||||
ZTAI = AK
|
||||
80 CONTINUE
|
||||
IF (ZI.NE.0.0D0) GO TO 90
|
||||
IF (ZR.GT.0.0D0) GO TO 90
|
||||
ZTAR = 0.0D0
|
||||
ZTAI = AK
|
||||
90 CONTINUE
|
||||
AA = ZTAR
|
||||
IF (AA.GE.0.0D0 .AND. ZR.GT.0.0D0) GO TO 110
|
||||
IF (KODE.EQ.2) GO TO 100
|
||||
C-----------------------------------------------------------------------
|
||||
C OVERFLOW TEST
|
||||
C-----------------------------------------------------------------------
|
||||
IF (AA.GT.(-ALIM)) GO TO 100
|
||||
AA = -AA + 0.25D0*ALAZ
|
||||
IFLAG = 1
|
||||
SFAC = TOL
|
||||
IF (AA.GT.ELIM) GO TO 270
|
||||
100 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C CBKNU AND CACON RETURN EXP(ZTA)*K(FNU,ZTA) ON KODE=2
|
||||
C-----------------------------------------------------------------------
|
||||
MR = 1
|
||||
IF (ZI.LT.0.0D0) MR = -1
|
||||
CALL ZACAI(ZTAR, ZTAI, FNU, KODE, MR, 1, CYR, CYI, NN, RL, TOL,
|
||||
* ELIM, ALIM)
|
||||
IF (NN.LT.0) GO TO 280
|
||||
NZ = NZ + NN
|
||||
GO TO 130
|
||||
110 CONTINUE
|
||||
IF (KODE.EQ.2) GO TO 120
|
||||
C-----------------------------------------------------------------------
|
||||
C UNDERFLOW TEST
|
||||
C-----------------------------------------------------------------------
|
||||
IF (AA.LT.ALIM) GO TO 120
|
||||
AA = -AA - 0.25D0*ALAZ
|
||||
IFLAG = 2
|
||||
SFAC = 1.0D0/TOL
|
||||
IF (AA.LT.(-ELIM)) GO TO 210
|
||||
120 CONTINUE
|
||||
CALL ZBKNU(ZTAR, ZTAI, FNU, KODE, 1, CYR, CYI, NZ, TOL, ELIM,
|
||||
* ALIM)
|
||||
130 CONTINUE
|
||||
S1R = CYR(1)*COEF
|
||||
S1I = CYI(1)*COEF
|
||||
IF (IFLAG.NE.0) GO TO 150
|
||||
IF (ID.EQ.1) GO TO 140
|
||||
AIR = CSQR*S1R - CSQI*S1I
|
||||
AII = CSQR*S1I + CSQI*S1R
|
||||
RETURN
|
||||
140 CONTINUE
|
||||
AIR = -(ZR*S1R-ZI*S1I)
|
||||
AII = -(ZR*S1I+ZI*S1R)
|
||||
RETURN
|
||||
150 CONTINUE
|
||||
S1R = S1R*SFAC
|
||||
S1I = S1I*SFAC
|
||||
IF (ID.EQ.1) GO TO 160
|
||||
STR = S1R*CSQR - S1I*CSQI
|
||||
S1I = S1R*CSQI + S1I*CSQR
|
||||
S1R = STR
|
||||
AIR = S1R/SFAC
|
||||
AII = S1I/SFAC
|
||||
RETURN
|
||||
160 CONTINUE
|
||||
STR = -(S1R*ZR-S1I*ZI)
|
||||
S1I = -(S1R*ZI+S1I*ZR)
|
||||
S1R = STR
|
||||
AIR = S1R/SFAC
|
||||
AII = S1I/SFAC
|
||||
RETURN
|
||||
170 CONTINUE
|
||||
AA = 1.0D+3*D1MACH(1)
|
||||
S1R = ZEROR
|
||||
S1I = ZEROI
|
||||
IF (ID.EQ.1) GO TO 190
|
||||
IF (AZ.LE.AA) GO TO 180
|
||||
S1R = C2*ZR
|
||||
S1I = C2*ZI
|
||||
180 CONTINUE
|
||||
AIR = C1 - S1R
|
||||
AII = -S1I
|
||||
RETURN
|
||||
190 CONTINUE
|
||||
AIR = -C2
|
||||
AII = 0.0D0
|
||||
AA = DSQRT(AA)
|
||||
IF (AZ.LE.AA) GO TO 200
|
||||
S1R = 0.5D0*(ZR*ZR-ZI*ZI)
|
||||
S1I = ZR*ZI
|
||||
200 CONTINUE
|
||||
AIR = AIR + C1*S1R
|
||||
AII = AII + C1*S1I
|
||||
RETURN
|
||||
210 CONTINUE
|
||||
NZ = 1
|
||||
AIR = ZEROR
|
||||
AII = ZEROI
|
||||
RETURN
|
||||
270 CONTINUE
|
||||
NZ = 0
|
||||
IERR=2
|
||||
RETURN
|
||||
280 CONTINUE
|
||||
IF(NN.EQ.(-1)) GO TO 270
|
||||
NZ=0
|
||||
IERR=5
|
||||
RETURN
|
||||
260 CONTINUE
|
||||
IERR=4
|
||||
NZ=0
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,165 @@
|
|||
SUBROUTINE ZASYI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, RL, TOL, ELIM,
|
||||
* ALIM)
|
||||
C***BEGIN PROLOGUE ZASYI
|
||||
C***REFER TO ZBESI,ZBESK
|
||||
C
|
||||
C ZASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY
|
||||
C MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z) IN THE
|
||||
C REGION CABS(Z).GT.MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL RETURN.
|
||||
C NZ.LT.0 INDICATES AN OVERFLOW ON KODE=1.
|
||||
C
|
||||
C***ROUTINES CALLED D1MACH,ZABS,ZDIV,ZEXP,ZMLT,ZSQRT
|
||||
C***END PROLOGUE ZASYI
|
||||
C COMPLEX AK1,CK,CONE,CS1,CS2,CZ,CZERO,DK,EZ,P1,RZ,S2,Y,Z
|
||||
DOUBLE PRECISION AA, AEZ, AK, AK1I, AK1R, ALIM, ARG, ARM, ATOL,
|
||||
* AZ, BB, BK, CKI, CKR, CONEI, CONER, CS1I, CS1R, CS2I, CS2R, CZI,
|
||||
* CZR, DFNU, DKI, DKR, DNU2, ELIM, EZI, EZR, FDN, FNU, PI, P1I,
|
||||
* P1R, RAZ, RL, RTPI, RTR1, RZI, RZR, S, SGN, SQK, STI, STR, S2I,
|
||||
* S2R, TOL, TZI, TZR, YI, YR, ZEROI, ZEROR, ZI, ZR, D1MACH, ZABS
|
||||
INTEGER I, IB, IL, INU, J, JL, K, KODE, KODED, M, N, NN, NZ
|
||||
DIMENSION YR(N), YI(N)
|
||||
DATA PI, RTPI /3.14159265358979324D0 , 0.159154943091895336D0 /
|
||||
DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
|
||||
C
|
||||
NZ = 0
|
||||
AZ = ZABS(ZR,ZI)
|
||||
ARM = 1.0D+3*D1MACH(1)
|
||||
RTR1 = DSQRT(ARM)
|
||||
IL = MIN0(2,N)
|
||||
DFNU = FNU + DBLE(FLOAT(N-IL))
|
||||
C-----------------------------------------------------------------------
|
||||
C OVERFLOW TEST
|
||||
C-----------------------------------------------------------------------
|
||||
RAZ = 1.0D0/AZ
|
||||
STR = ZR*RAZ
|
||||
STI = -ZI*RAZ
|
||||
AK1R = RTPI*STR*RAZ
|
||||
AK1I = RTPI*STI*RAZ
|
||||
CALL ZSQRT(AK1R, AK1I, AK1R, AK1I)
|
||||
CZR = ZR
|
||||
CZI = ZI
|
||||
IF (KODE.NE.2) GO TO 10
|
||||
CZR = ZEROR
|
||||
CZI = ZI
|
||||
10 CONTINUE
|
||||
IF (DABS(CZR).GT.ELIM) GO TO 100
|
||||
DNU2 = DFNU + DFNU
|
||||
KODED = 1
|
||||
IF ((DABS(CZR).GT.ALIM) .AND. (N.GT.2)) GO TO 20
|
||||
KODED = 0
|
||||
CALL ZEXP(CZR, CZI, STR, STI)
|
||||
CALL ZMLT(AK1R, AK1I, STR, STI, AK1R, AK1I)
|
||||
20 CONTINUE
|
||||
FDN = 0.0D0
|
||||
IF (DNU2.GT.RTR1) FDN = DNU2*DNU2
|
||||
EZR = ZR*8.0D0
|
||||
EZI = ZI*8.0D0
|
||||
C-----------------------------------------------------------------------
|
||||
C WHEN Z IS IMAGINARY, THE ERROR TEST MUST BE MADE RELATIVE TO THE
|
||||
C FIRST RECIPROCAL POWER SINCE THIS IS THE LEADING TERM OF THE
|
||||
C EXPANSION FOR THE IMAGINARY PART.
|
||||
C-----------------------------------------------------------------------
|
||||
AEZ = 8.0D0*AZ
|
||||
S = TOL/AEZ
|
||||
JL = INT(SNGL(RL+RL)) + 2
|
||||
P1R = ZEROR
|
||||
P1I = ZEROI
|
||||
IF (ZI.EQ.0.0D0) GO TO 30
|
||||
C-----------------------------------------------------------------------
|
||||
C CALCULATE EXP(PI*(0.5+FNU+N-IL)*I) TO MINIMIZE LOSSES OF
|
||||
C SIGNIFICANCE WHEN FNU OR N IS LARGE
|
||||
C-----------------------------------------------------------------------
|
||||
INU = INT(SNGL(FNU))
|
||||
ARG = (FNU-DBLE(FLOAT(INU)))*PI
|
||||
INU = INU + N - IL
|
||||
AK = -DSIN(ARG)
|
||||
BK = DCOS(ARG)
|
||||
IF (ZI.LT.0.0D0) BK = -BK
|
||||
P1R = AK
|
||||
P1I = BK
|
||||
IF (MOD(INU,2).EQ.0) GO TO 30
|
||||
P1R = -P1R
|
||||
P1I = -P1I
|
||||
30 CONTINUE
|
||||
DO 70 K=1,IL
|
||||
SQK = FDN - 1.0D0
|
||||
ATOL = S*DABS(SQK)
|
||||
SGN = 1.0D0
|
||||
CS1R = CONER
|
||||
CS1I = CONEI
|
||||
CS2R = CONER
|
||||
CS2I = CONEI
|
||||
CKR = CONER
|
||||
CKI = CONEI
|
||||
AK = 0.0D0
|
||||
AA = 1.0D0
|
||||
BB = AEZ
|
||||
DKR = EZR
|
||||
DKI = EZI
|
||||
DO 40 J=1,JL
|
||||
CALL ZDIV(CKR, CKI, DKR, DKI, STR, STI)
|
||||
CKR = STR*SQK
|
||||
CKI = STI*SQK
|
||||
CS2R = CS2R + CKR
|
||||
CS2I = CS2I + CKI
|
||||
SGN = -SGN
|
||||
CS1R = CS1R + CKR*SGN
|
||||
CS1I = CS1I + CKI*SGN
|
||||
DKR = DKR + EZR
|
||||
DKI = DKI + EZI
|
||||
AA = AA*DABS(SQK)/BB
|
||||
BB = BB + AEZ
|
||||
AK = AK + 8.0D0
|
||||
SQK = SQK - AK
|
||||
IF (AA.LE.ATOL) GO TO 50
|
||||
40 CONTINUE
|
||||
GO TO 110
|
||||
50 CONTINUE
|
||||
S2R = CS1R
|
||||
S2I = CS1I
|
||||
IF (ZR+ZR.GE.ELIM) GO TO 60
|
||||
TZR = ZR + ZR
|
||||
TZI = ZI + ZI
|
||||
CALL ZEXP(-TZR, -TZI, STR, STI)
|
||||
CALL ZMLT(STR, STI, P1R, P1I, STR, STI)
|
||||
CALL ZMLT(STR, STI, CS2R, CS2I, STR, STI)
|
||||
S2R = S2R + STR
|
||||
S2I = S2I + STI
|
||||
60 CONTINUE
|
||||
FDN = FDN + 8.0D0*DFNU + 4.0D0
|
||||
P1R = -P1R
|
||||
P1I = -P1I
|
||||
M = N - IL + K
|
||||
YR(M) = S2R*AK1R - S2I*AK1I
|
||||
YI(M) = S2R*AK1I + S2I*AK1R
|
||||
70 CONTINUE
|
||||
IF (N.LE.2) RETURN
|
||||
NN = N
|
||||
K = NN - 2
|
||||
AK = DBLE(FLOAT(K))
|
||||
STR = ZR*RAZ
|
||||
STI = -ZI*RAZ
|
||||
RZR = (STR+STR)*RAZ
|
||||
RZI = (STI+STI)*RAZ
|
||||
IB = 3
|
||||
DO 80 I=IB,NN
|
||||
YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2)
|
||||
YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2)
|
||||
AK = AK - 1.0D0
|
||||
K = K - 1
|
||||
80 CONTINUE
|
||||
IF (KODED.EQ.0) RETURN
|
||||
CALL ZEXP(CZR, CZI, CKR, CKI)
|
||||
DO 90 I=1,NN
|
||||
STR = YR(I)*CKR - YI(I)*CKI
|
||||
YI(I) = YR(I)*CKI + YI(I)*CKR
|
||||
YR(I) = STR
|
||||
90 CONTINUE
|
||||
RETURN
|
||||
100 CONTINUE
|
||||
NZ = -1
|
||||
RETURN
|
||||
110 CONTINUE
|
||||
NZ=-2
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,348 @@
|
|||
SUBROUTINE ZBESH(ZR, ZI, FNU, KODE, M, N, CYR, CYI, NZ, IERR)
|
||||
C***BEGIN PROLOGUE ZBESH
|
||||
C***DATE WRITTEN 830501 (YYMMDD)
|
||||
C***REVISION DATE 890801 (YYMMDD)
|
||||
C***CATEGORY NO. B5K
|
||||
C***KEYWORDS H-BESSEL FUNCTIONS,BESSEL FUNCTIONS OF COMPLEX ARGUMENT,
|
||||
C BESSEL FUNCTIONS OF THIRD KIND,HANKEL FUNCTIONS
|
||||
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
|
||||
C***PURPOSE TO COMPUTE THE H-BESSEL FUNCTIONS OF A COMPLEX ARGUMENT
|
||||
C***DESCRIPTION
|
||||
C
|
||||
C ***A DOUBLE PRECISION ROUTINE***
|
||||
C ON KODE=1, ZBESH COMPUTES AN N MEMBER SEQUENCE OF COMPLEX
|
||||
C HANKEL (BESSEL) FUNCTIONS CY(J)=H(M,FNU+J-1,Z) FOR KINDS M=1
|
||||
C OR 2, REAL, NONNEGATIVE ORDERS FNU+J-1, J=1,...,N, AND COMPLEX
|
||||
C Z.NE.CMPLX(0.0,0.0) IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI.
|
||||
C ON KODE=2, ZBESH RETURNS THE SCALED HANKEL FUNCTIONS
|
||||
C
|
||||
C CY(I)=EXP(-MM*Z*I)*H(M,FNU+J-1,Z) MM=3-2*M, I**2=-1.
|
||||
C
|
||||
C WHICH REMOVES THE EXPONENTIAL BEHAVIOR IN BOTH THE UPPER AND
|
||||
C LOWER HALF PLANES. DEFINITIONS AND NOTATION ARE FOUND IN THE
|
||||
C NBS HANDBOOK OF MATHEMATICAL FUNCTIONS (REF. 1).
|
||||
C
|
||||
C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION
|
||||
C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0),
|
||||
C -PT.LT.ARG(Z).LE.PI
|
||||
C FNU - ORDER OF INITIAL H FUNCTION, FNU.GE.0.0D0
|
||||
C KODE - A PARAMETER TO INDICATE THE SCALING OPTION
|
||||
C KODE= 1 RETURNS
|
||||
C CY(J)=H(M,FNU+J-1,Z), J=1,...,N
|
||||
C = 2 RETURNS
|
||||
C CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M))
|
||||
C J=1,...,N , I**2=-1
|
||||
C M - KIND OF HANKEL FUNCTION, M=1 OR 2
|
||||
C N - NUMBER OF MEMBERS IN THE SEQUENCE, N.GE.1
|
||||
C
|
||||
C OUTPUT CYR,CYI ARE DOUBLE PRECISION
|
||||
C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS
|
||||
C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE
|
||||
C CY(J)=H(M,FNU+J-1,Z) OR
|
||||
C CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) J=1,...,N
|
||||
C DEPENDING ON KODE, I**2=-1.
|
||||
C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW,
|
||||
C NZ= 0 , NORMAL RETURN
|
||||
C NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO DUE
|
||||
C TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0)
|
||||
C J=1,...,NZ WHEN Y.GT.0.0 AND M=1 OR
|
||||
C Y.LT.0.0 AND M=2. FOR THE COMPLMENTARY
|
||||
C HALF PLANES, NZ STATES ONLY THE NUMBER
|
||||
C OF UNDERFLOWS.
|
||||
C IERR - ERROR FLAG
|
||||
C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
|
||||
C IERR=1, INPUT ERROR - NO COMPUTATION
|
||||
C IERR=2, OVERFLOW - NO COMPUTATION, FNU TOO
|
||||
C LARGE OR CABS(Z) TOO SMALL OR BOTH
|
||||
C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
|
||||
C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
|
||||
C REDUCTION PRODUCE LESS THAN HALF OF MACHINE
|
||||
C ACCURACY
|
||||
C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
|
||||
C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
|
||||
C CANCE BY ARGUMENT REDUCTION
|
||||
C IERR=5, ERROR - NO COMPUTATION,
|
||||
C ALGORITHM TERMINATION CONDITION NOT MET
|
||||
C
|
||||
C***LONG DESCRIPTION
|
||||
C
|
||||
C THE COMPUTATION IS CARRIED OUT BY THE RELATION
|
||||
C
|
||||
C H(M,FNU,Z)=(1/MP)*EXP(-MP*FNU)*K(FNU,Z*EXP(-MP))
|
||||
C MP=MM*HPI*I, MM=3-2*M, HPI=PI/2, I**2=-1
|
||||
C
|
||||
C FOR M=1 OR 2 WHERE THE K BESSEL FUNCTION IS COMPUTED FOR THE
|
||||
C RIGHT HALF PLANE RE(Z).GE.0.0. THE K FUNCTION IS CONTINUED
|
||||
C TO THE LEFT HALF PLANE BY THE RELATION
|
||||
C
|
||||
C K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z)
|
||||
C MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1
|
||||
C
|
||||
C WHERE I(FNU,Z) IS THE I BESSEL FUNCTION.
|
||||
C
|
||||
C EXPONENTIAL DECAY OF H(M,FNU,Z) OCCURS IN THE UPPER HALF Z
|
||||
C PLANE FOR M=1 AND THE LOWER HALF Z PLANE FOR M=2. EXPONENTIAL
|
||||
C GROWTH OCCURS IN THE COMPLEMENTARY HALF PLANES. SCALING
|
||||
C BY EXP(-MM*Z*I) REMOVES THE EXPONENTIAL BEHAVIOR IN THE
|
||||
C WHOLE Z PLANE FOR Z TO INFINITY.
|
||||
C
|
||||
C FOR NEGATIVE ORDERS,THE FORMULAE
|
||||
C
|
||||
C H(1,-FNU,Z) = H(1,FNU,Z)*CEXP( PI*FNU*I)
|
||||
C H(2,-FNU,Z) = H(2,FNU,Z)*CEXP(-PI*FNU*I)
|
||||
C I**2=-1
|
||||
C
|
||||
C CAN BE USED.
|
||||
C
|
||||
C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
|
||||
C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS
|
||||
C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.
|
||||
C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN
|
||||
C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG
|
||||
C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
|
||||
C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
|
||||
C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS
|
||||
C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS
|
||||
C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE
|
||||
C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS
|
||||
C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
|
||||
C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
|
||||
C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
|
||||
C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
|
||||
C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
|
||||
C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
|
||||
C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
|
||||
C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
|
||||
C
|
||||
C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
|
||||
C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
|
||||
C ROUNDOFF,1.0D-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
|
||||
C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
|
||||
C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
|
||||
C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
|
||||
C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
|
||||
C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
|
||||
C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
|
||||
C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
|
||||
C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
|
||||
C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
|
||||
C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
|
||||
C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
|
||||
C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
|
||||
C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
|
||||
C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
|
||||
C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
|
||||
C OR -PI/2+P.
|
||||
C
|
||||
C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
|
||||
C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
|
||||
C COMMERCE, 1955.
|
||||
C
|
||||
C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
|
||||
C BY D. E. AMOS, SAND83-0083, MAY, 1983.
|
||||
C
|
||||
C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
|
||||
C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
|
||||
C
|
||||
C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
|
||||
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
|
||||
C 1018, MAY, 1985
|
||||
C
|
||||
C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
|
||||
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
|
||||
C MATH. SOFTWARE, 1986
|
||||
C
|
||||
C***ROUTINES CALLED ZACON,ZBKNU,ZBUNK,ZUOIK,ZABS,I1MACH,D1MACH
|
||||
C***END PROLOGUE ZBESH
|
||||
C
|
||||
C COMPLEX CY,Z,ZN,ZT,CSGN
|
||||
DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM,
|
||||
* FMM, FN, FNU, FNUL, HPI, RHPI, RL, R1M5, SGN, STR, TOL, UFL, ZI,
|
||||
* ZNI, ZNR, ZR, ZTI, D1MACH, ZABS, BB, ASCLE, RTOL, ATOL, STI,
|
||||
* CSGNR, CSGNI
|
||||
INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, M,
|
||||
* MM, MR, N, NN, NUF, NW, NZ, I1MACH
|
||||
DIMENSION CYR(N), CYI(N)
|
||||
C
|
||||
DATA HPI /1.57079632679489662D0/
|
||||
C
|
||||
C***FIRST EXECUTABLE STATEMENT ZBESH
|
||||
IERR = 0
|
||||
NZ=0
|
||||
IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1
|
||||
IF (FNU.LT.0.0D0) IERR=1
|
||||
IF (M.LT.1 .OR. M.GT.2) IERR=1
|
||||
IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
|
||||
IF (N.LT.1) IERR=1
|
||||
IF (IERR.NE.0) RETURN
|
||||
NN = N
|
||||
C-----------------------------------------------------------------------
|
||||
C SET PARAMETERS RELATED TO MACHINE CONSTANTS.
|
||||
C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
|
||||
C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
|
||||
C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND
|
||||
C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR
|
||||
C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
|
||||
C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
|
||||
C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
|
||||
C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU
|
||||
C-----------------------------------------------------------------------
|
||||
TOL = DMAX1(D1MACH(4),1.0D-18)
|
||||
K1 = I1MACH(15)
|
||||
K2 = I1MACH(16)
|
||||
R1M5 = D1MACH(5)
|
||||
K = MIN0(IABS(K1),IABS(K2))
|
||||
ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
|
||||
K1 = I1MACH(14) - 1
|
||||
AA = R1M5*DBLE(FLOAT(K1))
|
||||
DIG = DMIN1(AA,18.0D0)
|
||||
AA = AA*2.303D0
|
||||
ALIM = ELIM + DMAX1(-AA,-41.45D0)
|
||||
FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
|
||||
RL = 1.2D0*DIG + 3.0D0
|
||||
FN = FNU + DBLE(FLOAT(NN-1))
|
||||
MM = 3 - M - M
|
||||
FMM = DBLE(FLOAT(MM))
|
||||
ZNR = FMM*ZI
|
||||
ZNI = -FMM*ZR
|
||||
C-----------------------------------------------------------------------
|
||||
C TEST FOR PROPER RANGE
|
||||
C-----------------------------------------------------------------------
|
||||
AZ = ZABS(ZR,ZI)
|
||||
AA = 0.5D0/TOL
|
||||
BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
|
||||
AA = DMIN1(AA,BB)
|
||||
IF (AZ.GT.AA) GO TO 260
|
||||
IF (FN.GT.AA) GO TO 260
|
||||
AA = DSQRT(AA)
|
||||
IF (AZ.GT.AA) IERR=3
|
||||
IF (FN.GT.AA) IERR=3
|
||||
C-----------------------------------------------------------------------
|
||||
C OVERFLOW TEST ON THE LAST MEMBER OF THE SEQUENCE
|
||||
C-----------------------------------------------------------------------
|
||||
UFL = D1MACH(1)*1.0D+3
|
||||
IF (AZ.LT.UFL) GO TO 230
|
||||
IF (FNU.GT.FNUL) GO TO 90
|
||||
IF (FN.LE.1.0D0) GO TO 70
|
||||
IF (FN.GT.2.0D0) GO TO 60
|
||||
IF (AZ.GT.TOL) GO TO 70
|
||||
ARG = 0.5D0*AZ
|
||||
ALN = -FN*DLOG(ARG)
|
||||
IF (ALN.GT.ELIM) GO TO 230
|
||||
GO TO 70
|
||||
60 CONTINUE
|
||||
CALL ZUOIK(ZNR, ZNI, FNU, KODE, 2, NN, CYR, CYI, NUF, TOL, ELIM,
|
||||
* ALIM)
|
||||
IF (NUF.LT.0) GO TO 230
|
||||
NZ = NZ + NUF
|
||||
NN = NN - NUF
|
||||
C-----------------------------------------------------------------------
|
||||
C HERE NN=N OR NN=0 SINCE NUF=0,NN, OR -1 ON RETURN FROM CUOIK
|
||||
C IF NUF=NN, THEN CY(I)=CZERO FOR ALL I
|
||||
C-----------------------------------------------------------------------
|
||||
IF (NN.EQ.0) GO TO 140
|
||||
70 CONTINUE
|
||||
IF ((ZNR.LT.0.0D0) .OR. (ZNR.EQ.0.0D0 .AND. ZNI.LT.0.0D0 .AND.
|
||||
* M.EQ.2)) GO TO 80
|
||||
C-----------------------------------------------------------------------
|
||||
C RIGHT HALF PLANE COMPUTATION, XN.GE.0. .AND. (XN.NE.0. .OR.
|
||||
C YN.GE.0. .OR. M=1)
|
||||
C-----------------------------------------------------------------------
|
||||
CALL ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NZ, TOL, ELIM, ALIM)
|
||||
GO TO 110
|
||||
C-----------------------------------------------------------------------
|
||||
C LEFT HALF PLANE COMPUTATION
|
||||
C-----------------------------------------------------------------------
|
||||
80 CONTINUE
|
||||
MR = -MM
|
||||
CALL ZACON(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, RL, FNUL,
|
||||
* TOL, ELIM, ALIM)
|
||||
IF (NW.LT.0) GO TO 240
|
||||
NZ=NW
|
||||
GO TO 110
|
||||
90 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C UNIFORM ASYMPTOTIC EXPANSIONS FOR FNU.GT.FNUL
|
||||
C-----------------------------------------------------------------------
|
||||
MR = 0
|
||||
IF ((ZNR.GE.0.0D0) .AND. (ZNR.NE.0.0D0 .OR. ZNI.GE.0.0D0 .OR.
|
||||
* M.NE.2)) GO TO 100
|
||||
MR = -MM
|
||||
IF (ZNR.NE.0.0D0 .OR. ZNI.GE.0.0D0) GO TO 100
|
||||
ZNR = -ZNR
|
||||
ZNI = -ZNI
|
||||
100 CONTINUE
|
||||
CALL ZBUNK(ZNR, ZNI, FNU, KODE, MR, NN, CYR, CYI, NW, TOL, ELIM,
|
||||
* ALIM)
|
||||
IF (NW.LT.0) GO TO 240
|
||||
NZ = NZ + NW
|
||||
110 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C H(M,FNU,Z) = -FMM*(I/HPI)*(ZT**FNU)*K(FNU,-Z*ZT)
|
||||
C
|
||||
C ZT=EXP(-FMM*HPI*I) = CMPLX(0.0,-FMM), FMM=3-2*M, M=1,2
|
||||
C-----------------------------------------------------------------------
|
||||
SGN = DSIGN(HPI,-FMM)
|
||||
C-----------------------------------------------------------------------
|
||||
C CALCULATE EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
|
||||
C WHEN FNU IS LARGE
|
||||
C-----------------------------------------------------------------------
|
||||
INU = INT(SNGL(FNU))
|
||||
INUH = INU/2
|
||||
IR = INU - 2*INUH
|
||||
ARG = (FNU-DBLE(FLOAT(INU-IR)))*SGN
|
||||
RHPI = 1.0D0/SGN
|
||||
C ZNI = RHPI*DCOS(ARG)
|
||||
C ZNR = -RHPI*DSIN(ARG)
|
||||
CSGNI = RHPI*DCOS(ARG)
|
||||
CSGNR = -RHPI*DSIN(ARG)
|
||||
IF (MOD(INUH,2).EQ.0) GO TO 120
|
||||
C ZNR = -ZNR
|
||||
C ZNI = -ZNI
|
||||
CSGNR = -CSGNR
|
||||
CSGNI = -CSGNI
|
||||
120 CONTINUE
|
||||
ZTI = -FMM
|
||||
RTOL = 1.0D0/TOL
|
||||
ASCLE = UFL*RTOL
|
||||
DO 130 I=1,NN
|
||||
C STR = CYR(I)*ZNR - CYI(I)*ZNI
|
||||
C CYI(I) = CYR(I)*ZNI + CYI(I)*ZNR
|
||||
C CYR(I) = STR
|
||||
C STR = -ZNI*ZTI
|
||||
C ZNI = ZNR*ZTI
|
||||
C ZNR = STR
|
||||
AA = CYR(I)
|
||||
BB = CYI(I)
|
||||
ATOL = 1.0D0
|
||||
IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 135
|
||||
AA = AA*RTOL
|
||||
BB = BB*RTOL
|
||||
ATOL = TOL
|
||||
135 CONTINUE
|
||||
STR = AA*CSGNR - BB*CSGNI
|
||||
STI = AA*CSGNI + BB*CSGNR
|
||||
CYR(I) = STR*ATOL
|
||||
CYI(I) = STI*ATOL
|
||||
STR = -CSGNI*ZTI
|
||||
CSGNI = CSGNR*ZTI
|
||||
CSGNR = STR
|
||||
130 CONTINUE
|
||||
RETURN
|
||||
140 CONTINUE
|
||||
IF (ZNR.LT.0.0D0) GO TO 230
|
||||
RETURN
|
||||
230 CONTINUE
|
||||
NZ=0
|
||||
IERR=2
|
||||
RETURN
|
||||
240 CONTINUE
|
||||
IF(NW.EQ.(-1)) GO TO 230
|
||||
NZ=0
|
||||
IERR=5
|
||||
RETURN
|
||||
260 CONTINUE
|
||||
NZ=0
|
||||
IERR=4
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,266 @@
|
|||
SUBROUTINE ZBESJ(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR)
|
||||
C***BEGIN PROLOGUE ZBESJ
|
||||
C***DATE WRITTEN 830501 (YYMMDD)
|
||||
C***REVISION DATE 890801 (YYMMDD)
|
||||
C***CATEGORY NO. B5K
|
||||
C***KEYWORDS J-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT,
|
||||
C BESSEL FUNCTION OF FIRST KIND
|
||||
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
|
||||
C***PURPOSE TO COMPUTE THE J-BESSEL FUNCTION OF A COMPLEX ARGUMENT
|
||||
C***DESCRIPTION
|
||||
C
|
||||
C ***A DOUBLE PRECISION ROUTINE***
|
||||
C ON KODE=1, CBESJ COMPUTES AN N MEMBER SEQUENCE OF COMPLEX
|
||||
C BESSEL FUNCTIONS CY(I)=J(FNU+I-1,Z) FOR REAL, NONNEGATIVE
|
||||
C ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE
|
||||
C -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESJ RETURNS THE SCALED
|
||||
C FUNCTIONS
|
||||
C
|
||||
C CY(I)=EXP(-ABS(Y))*J(FNU+I-1,Z) I = 1,...,N , Y=AIMAG(Z)
|
||||
C
|
||||
C WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND
|
||||
C LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION
|
||||
C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS
|
||||
C (REF. 1).
|
||||
C
|
||||
C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION
|
||||
C ZR,ZI - Z=CMPLX(ZR,ZI), -PI.LT.ARG(Z).LE.PI
|
||||
C FNU - ORDER OF INITIAL J FUNCTION, FNU.GE.0.0D0
|
||||
C KODE - A PARAMETER TO INDICATE THE SCALING OPTION
|
||||
C KODE= 1 RETURNS
|
||||
C CY(I)=J(FNU+I-1,Z), I=1,...,N
|
||||
C = 2 RETURNS
|
||||
C CY(I)=J(FNU+I-1,Z)EXP(-ABS(Y)), I=1,...,N
|
||||
C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1
|
||||
C
|
||||
C OUTPUT CYR,CYI ARE DOUBLE PRECISION
|
||||
C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS
|
||||
C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE
|
||||
C CY(I)=J(FNU+I-1,Z) OR
|
||||
C CY(I)=J(FNU+I-1,Z)EXP(-ABS(Y)) I=1,...,N
|
||||
C DEPENDING ON KODE, Y=AIMAG(Z).
|
||||
C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW,
|
||||
C NZ= 0 , NORMAL RETURN
|
||||
C NZ.GT.0 , LAST NZ COMPONENTS OF CY SET ZERO DUE
|
||||
C TO UNDERFLOW, CY(I)=CMPLX(0.0D0,0.0D0),
|
||||
C I = N-NZ+1,...,N
|
||||
C IERR - ERROR FLAG
|
||||
C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
|
||||
C IERR=1, INPUT ERROR - NO COMPUTATION
|
||||
C IERR=2, OVERFLOW - NO COMPUTATION, AIMAG(Z)
|
||||
C TOO LARGE ON KODE=1
|
||||
C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
|
||||
C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
|
||||
C REDUCTION PRODUCE LESS THAN HALF OF MACHINE
|
||||
C ACCURACY
|
||||
C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
|
||||
C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
|
||||
C CANCE BY ARGUMENT REDUCTION
|
||||
C IERR=5, ERROR - NO COMPUTATION,
|
||||
C ALGORITHM TERMINATION CONDITION NOT MET
|
||||
C
|
||||
C***LONG DESCRIPTION
|
||||
C
|
||||
C THE COMPUTATION IS CARRIED OUT BY THE FORMULA
|
||||
C
|
||||
C J(FNU,Z)=EXP( FNU*PI*I/2)*I(FNU,-I*Z) AIMAG(Z).GE.0.0
|
||||
C
|
||||
C J(FNU,Z)=EXP(-FNU*PI*I/2)*I(FNU, I*Z) AIMAG(Z).LT.0.0
|
||||
C
|
||||
C WHERE I**2 = -1 AND I(FNU,Z) IS THE I BESSEL FUNCTION.
|
||||
C
|
||||
C FOR NEGATIVE ORDERS,THE FORMULA
|
||||
C
|
||||
C J(-FNU,Z) = J(FNU,Z)*COS(PI*FNU) - Y(FNU,Z)*SIN(PI*FNU)
|
||||
C
|
||||
C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO INTEGERS, THE
|
||||
C THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE POSITIVE
|
||||
C INTEGER,THE MAGNITUDE OF J(-FNU,Z)=J(FNU,Z)*COS(PI*FNU) IS A
|
||||
C LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS NOT AN INTEGER,
|
||||
C Y(FNU,Z) DOMINATES IN MAGNITUDE WITH A LARGE POSITIVE POWER OF
|
||||
C TEN AND THE MOST THAT THE SECOND TERM CAN BE REDUCED IS BY
|
||||
C UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, WIDE CHANGES CAN
|
||||
C OCCUR WITHIN UNIT ROUNDOFF OF A LARGE INTEGER FOR FNU. HERE,
|
||||
C LARGE MEANS FNU.GT.CABS(Z).
|
||||
C
|
||||
C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
|
||||
C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS
|
||||
C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.
|
||||
C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN
|
||||
C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG
|
||||
C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
|
||||
C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
|
||||
C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS
|
||||
C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS
|
||||
C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE
|
||||
C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS
|
||||
C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
|
||||
C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
|
||||
C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
|
||||
C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
|
||||
C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
|
||||
C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
|
||||
C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
|
||||
C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
|
||||
C
|
||||
C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
|
||||
C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
|
||||
C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
|
||||
C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
|
||||
C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
|
||||
C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
|
||||
C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
|
||||
C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
|
||||
C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
|
||||
C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
|
||||
C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
|
||||
C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
|
||||
C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
|
||||
C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
|
||||
C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
|
||||
C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
|
||||
C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
|
||||
C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
|
||||
C OR -PI/2+P.
|
||||
C
|
||||
C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
|
||||
C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
|
||||
C COMMERCE, 1955.
|
||||
C
|
||||
C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
|
||||
C BY D. E. AMOS, SAND83-0083, MAY, 1983.
|
||||
C
|
||||
C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
|
||||
C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
|
||||
C
|
||||
C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
|
||||
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
|
||||
C 1018, MAY, 1985
|
||||
C
|
||||
C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
|
||||
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
|
||||
C MATH. SOFTWARE, 1986
|
||||
C
|
||||
C***ROUTINES CALLED ZBINU,I1MACH,D1MACH
|
||||
C***END PROLOGUE ZBESJ
|
||||
C
|
||||
C COMPLEX CI,CSGN,CY,Z,ZN
|
||||
DOUBLE PRECISION AA, ALIM, ARG, CII, CSGNI, CSGNR, CYI, CYR, DIG,
|
||||
* ELIM, FNU, FNUL, HPI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR, ZR,
|
||||
* D1MACH, BB, FN, AZ, ZABS, ASCLE, RTOL, ATOL, STI
|
||||
INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, N, NL, NZ, I1MACH
|
||||
DIMENSION CYR(N), CYI(N)
|
||||
DATA HPI /1.57079632679489662D0/
|
||||
C
|
||||
C***FIRST EXECUTABLE STATEMENT ZBESJ
|
||||
IERR = 0
|
||||
NZ=0
|
||||
IF (FNU.LT.0.0D0) IERR=1
|
||||
IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
|
||||
IF (N.LT.1) IERR=1
|
||||
IF (IERR.NE.0) RETURN
|
||||
C-----------------------------------------------------------------------
|
||||
C SET PARAMETERS RELATED TO MACHINE CONSTANTS.
|
||||
C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18.
|
||||
C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT.
|
||||
C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND
|
||||
C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR
|
||||
C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE.
|
||||
C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z.
|
||||
C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG).
|
||||
C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU.
|
||||
C-----------------------------------------------------------------------
|
||||
TOL = DMAX1(D1MACH(4),1.0D-18)
|
||||
K1 = I1MACH(15)
|
||||
K2 = I1MACH(16)
|
||||
R1M5 = D1MACH(5)
|
||||
K = MIN0(IABS(K1),IABS(K2))
|
||||
ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
|
||||
K1 = I1MACH(14) - 1
|
||||
AA = R1M5*DBLE(FLOAT(K1))
|
||||
DIG = DMIN1(AA,18.0D0)
|
||||
AA = AA*2.303D0
|
||||
ALIM = ELIM + DMAX1(-AA,-41.45D0)
|
||||
RL = 1.2D0*DIG + 3.0D0
|
||||
FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0)
|
||||
C-----------------------------------------------------------------------
|
||||
C TEST FOR PROPER RANGE
|
||||
C-----------------------------------------------------------------------
|
||||
AZ = ZABS(ZR,ZI)
|
||||
FN = FNU+DBLE(FLOAT(N-1))
|
||||
AA = 0.5D0/TOL
|
||||
BB=DBLE(FLOAT(I1MACH(9)))*0.5D0
|
||||
AA = DMIN1(AA,BB)
|
||||
IF (AZ.GT.AA) GO TO 260
|
||||
IF (FN.GT.AA) GO TO 260
|
||||
AA = DSQRT(AA)
|
||||
IF (AZ.GT.AA) IERR=3
|
||||
IF (FN.GT.AA) IERR=3
|
||||
C-----------------------------------------------------------------------
|
||||
C CALCULATE CSGN=EXP(FNU*HPI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE
|
||||
C WHEN FNU IS LARGE
|
||||
C-----------------------------------------------------------------------
|
||||
CII = 1.0D0
|
||||
INU = INT(SNGL(FNU))
|
||||
INUH = INU/2
|
||||
IR = INU - 2*INUH
|
||||
ARG = (FNU-DBLE(FLOAT(INU-IR)))*HPI
|
||||
CSGNR = DCOS(ARG)
|
||||
CSGNI = DSIN(ARG)
|
||||
IF (MOD(INUH,2).EQ.0) GO TO 40
|
||||
CSGNR = -CSGNR
|
||||
CSGNI = -CSGNI
|
||||
40 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C ZN IS IN THE RIGHT HALF PLANE
|
||||
C-----------------------------------------------------------------------
|
||||
ZNR = ZI
|
||||
ZNI = -ZR
|
||||
IF (ZI.GE.0.0D0) GO TO 50
|
||||
ZNR = -ZNR
|
||||
ZNI = -ZNI
|
||||
CSGNI = -CSGNI
|
||||
CII = -CII
|
||||
50 CONTINUE
|
||||
CALL ZBINU(ZNR, ZNI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, TOL,
|
||||
* ELIM, ALIM)
|
||||
IF (NZ.LT.0) GO TO 130
|
||||
NL = N - NZ
|
||||
IF (NL.EQ.0) RETURN
|
||||
RTOL = 1.0D0/TOL
|
||||
ASCLE = D1MACH(1)*RTOL*1.0D+3
|
||||
DO 60 I=1,NL
|
||||
C STR = CYR(I)*CSGNR - CYI(I)*CSGNI
|
||||
C CYI(I) = CYR(I)*CSGNI + CYI(I)*CSGNR
|
||||
C CYR(I) = STR
|
||||
AA = CYR(I)
|
||||
BB = CYI(I)
|
||||
ATOL = 1.0D0
|
||||
IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 55
|
||||
AA = AA*RTOL
|
||||
BB = BB*RTOL
|
||||
ATOL = TOL
|
||||
55 CONTINUE
|
||||
STR = AA*CSGNR - BB*CSGNI
|
||||
STI = AA*CSGNI + BB*CSGNR
|
||||
CYR(I) = STR*ATOL
|
||||
CYI(I) = STI*ATOL
|
||||
STR = -CSGNI*CII
|
||||
CSGNI = CSGNR*CII
|
||||
CSGNR = STR
|
||||
60 CONTINUE
|
||||
RETURN
|
||||
130 CONTINUE
|
||||
IF(NZ.EQ.(-2)) GO TO 140
|
||||
NZ = 0
|
||||
IERR = 2
|
||||
RETURN
|
||||
140 CONTINUE
|
||||
NZ=0
|
||||
IERR=5
|
||||
RETURN
|
||||
260 CONTINUE
|
||||
NZ=0
|
||||
IERR=4
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,244 @@
|
|||
SUBROUTINE ZBESY(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, CWRKR, CWRKI,
|
||||
* IERR)
|
||||
C***BEGIN PROLOGUE ZBESY
|
||||
C***DATE WRITTEN 830501 (YYMMDD)
|
||||
C***REVISION DATE 890801 (YYMMDD)
|
||||
C***CATEGORY NO. B5K
|
||||
C***KEYWORDS Y-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT,
|
||||
C BESSEL FUNCTION OF SECOND KIND
|
||||
C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES
|
||||
C***PURPOSE TO COMPUTE THE Y-BESSEL FUNCTION OF A COMPLEX ARGUMENT
|
||||
C***DESCRIPTION
|
||||
C
|
||||
C ***A DOUBLE PRECISION ROUTINE***
|
||||
C
|
||||
C ON KODE=1, CBESY COMPUTES AN N MEMBER SEQUENCE OF COMPLEX
|
||||
C BESSEL FUNCTIONS CY(I)=Y(FNU+I-1,Z) FOR REAL, NONNEGATIVE
|
||||
C ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE
|
||||
C -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESY RETURNS THE SCALED
|
||||
C FUNCTIONS
|
||||
C
|
||||
C CY(I)=EXP(-ABS(Y))*Y(FNU+I-1,Z) I = 1,...,N , Y=AIMAG(Z)
|
||||
C
|
||||
C WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND
|
||||
C LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION
|
||||
C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS
|
||||
C (REF. 1).
|
||||
C
|
||||
C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION
|
||||
C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0),
|
||||
C -PI.LT.ARG(Z).LE.PI
|
||||
C FNU - ORDER OF INITIAL Y FUNCTION, FNU.GE.0.0D0
|
||||
C KODE - A PARAMETER TO INDICATE THE SCALING OPTION
|
||||
C KODE= 1 RETURNS
|
||||
C CY(I)=Y(FNU+I-1,Z), I=1,...,N
|
||||
C = 2 RETURNS
|
||||
C CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y)), I=1,...,N
|
||||
C WHERE Y=AIMAG(Z)
|
||||
C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1
|
||||
C CWRKR, - DOUBLE PRECISION WORK VECTORS OF DIMENSION AT
|
||||
C CWRKI AT LEAST N
|
||||
C
|
||||
C OUTPUT CYR,CYI ARE DOUBLE PRECISION
|
||||
C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS
|
||||
C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE
|
||||
C CY(I)=Y(FNU+I-1,Z) OR
|
||||
C CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y)) I=1,...,N
|
||||
C DEPENDING ON KODE.
|
||||
C NZ - NZ=0 , A NORMAL RETURN
|
||||
C NZ.GT.0 , NZ COMPONENTS OF CY SET TO ZERO DUE TO
|
||||
C UNDERFLOW (GENERALLY ON KODE=2)
|
||||
C IERR - ERROR FLAG
|
||||
C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED
|
||||
C IERR=1, INPUT ERROR - NO COMPUTATION
|
||||
C IERR=2, OVERFLOW - NO COMPUTATION, FNU IS
|
||||
C TOO LARGE OR CABS(Z) IS TOO SMALL OR BOTH
|
||||
C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE
|
||||
C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT
|
||||
C REDUCTION PRODUCE LESS THAN HALF OF MACHINE
|
||||
C ACCURACY
|
||||
C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA-
|
||||
C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI-
|
||||
C CANCE BY ARGUMENT REDUCTION
|
||||
C IERR=5, ERROR - NO COMPUTATION,
|
||||
C ALGORITHM TERMINATION CONDITION NOT MET
|
||||
C
|
||||
C***LONG DESCRIPTION
|
||||
C
|
||||
C THE COMPUTATION IS CARRIED OUT BY THE FORMULA
|
||||
C
|
||||
C Y(FNU,Z)=0.5*(H(1,FNU,Z)-H(2,FNU,Z))/I
|
||||
C
|
||||
C WHERE I**2 = -1 AND THE HANKEL BESSEL FUNCTIONS H(1,FNU,Z)
|
||||
C AND H(2,FNU,Z) ARE CALCULATED IN CBESH.
|
||||
C
|
||||
C FOR NEGATIVE ORDERS,THE FORMULA
|
||||
C
|
||||
C Y(-FNU,Z) = Y(FNU,Z)*COS(PI*FNU) + J(FNU,Z)*SIN(PI*FNU)
|
||||
C
|
||||
C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO HALF ODD
|
||||
C INTEGERS THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE
|
||||
C POSITIVE HALF ODD INTEGER,THE MAGNITUDE OF Y(-FNU,Z)=J(FNU,Z)*
|
||||
C SIN(PI*FNU) IS A LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS
|
||||
C NOT A HALF ODD INTEGER, Y(FNU,Z) DOMINATES IN MAGNITUDE WITH A
|
||||
C LARGE POSITIVE POWER OF TEN AND THE MOST THAT THE SECOND TERM
|
||||
C CAN BE REDUCED IS BY UNIT ROUNDOFF FROM THE COEFFICIENT. THUS,
|
||||
C WIDE CHANGES CAN OCCUR WITHIN UNIT ROUNDOFF OF A LARGE HALF
|
||||
C ODD INTEGER. HERE, LARGE MEANS FNU.GT.CABS(Z).
|
||||
C
|
||||
C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE-
|
||||
C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS
|
||||
C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR.
|
||||
C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN
|
||||
C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG
|
||||
C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS
|
||||
C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION.
|
||||
C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS
|
||||
C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS
|
||||
C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE
|
||||
C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS
|
||||
C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3
|
||||
C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION
|
||||
C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION
|
||||
C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN
|
||||
C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT
|
||||
C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS
|
||||
C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC.
|
||||
C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES.
|
||||
C
|
||||
C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX
|
||||
C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT
|
||||
C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE-
|
||||
C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE
|
||||
C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))),
|
||||
C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF
|
||||
C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY
|
||||
C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN
|
||||
C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY
|
||||
C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER
|
||||
C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K,
|
||||
C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS
|
||||
C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER
|
||||
C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY
|
||||
C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER
|
||||
C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE
|
||||
C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES,
|
||||
C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P,
|
||||
C OR -PI/2+P.
|
||||
C
|
||||
C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ
|
||||
C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF
|
||||
C COMMERCE, 1955.
|
||||
C
|
||||
C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
|
||||
C BY D. E. AMOS, SAND83-0083, MAY, 1983.
|
||||
C
|
||||
C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
|
||||
C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983
|
||||
C
|
||||
C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
|
||||
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85-
|
||||
C 1018, MAY, 1985
|
||||
C
|
||||
C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX
|
||||
C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS.
|
||||
C MATH. SOFTWARE, 1986
|
||||
C
|
||||
C***ROUTINES CALLED ZBESH,I1MACH,D1MACH
|
||||
C***END PROLOGUE ZBESY
|
||||
C
|
||||
C COMPLEX CWRK,CY,C1,C2,EX,HCI,Z,ZU,ZV
|
||||
DOUBLE PRECISION CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2R,
|
||||
* ELIM, EXI, EXR, EY, FNU, HCII, STI, STR, TAY, ZI, ZR, DEXP,
|
||||
* D1MACH, ASCLE, RTOL, ATOL, AA, BB, TOL
|
||||
INTEGER I, IERR, K, KODE, K1, K2, N, NZ, NZ1, NZ2, I1MACH
|
||||
DIMENSION CYR(N), CYI(N), CWRKR(N), CWRKI(N)
|
||||
C***FIRST EXECUTABLE STATEMENT ZBESY
|
||||
IERR = 0
|
||||
NZ=0
|
||||
IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1
|
||||
IF (FNU.LT.0.0D0) IERR=1
|
||||
IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1
|
||||
IF (N.LT.1) IERR=1
|
||||
IF (IERR.NE.0) RETURN
|
||||
HCII = 0.5D0
|
||||
CALL ZBESH(ZR, ZI, FNU, KODE, 1, N, CYR, CYI, NZ1, IERR)
|
||||
IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170
|
||||
CALL ZBESH(ZR, ZI, FNU, KODE, 2, N, CWRKR, CWRKI, NZ2, IERR)
|
||||
IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170
|
||||
NZ = MIN0(NZ1,NZ2)
|
||||
IF (KODE.EQ.2) GO TO 60
|
||||
DO 50 I=1,N
|
||||
STR = CWRKR(I) - CYR(I)
|
||||
STI = CWRKI(I) - CYI(I)
|
||||
CYR(I) = -STI*HCII
|
||||
CYI(I) = STR*HCII
|
||||
50 CONTINUE
|
||||
RETURN
|
||||
60 CONTINUE
|
||||
TOL = DMAX1(D1MACH(4),1.0D-18)
|
||||
K1 = I1MACH(15)
|
||||
K2 = I1MACH(16)
|
||||
K = MIN0(IABS(K1),IABS(K2))
|
||||
R1M5 = D1MACH(5)
|
||||
C-----------------------------------------------------------------------
|
||||
C ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT
|
||||
C-----------------------------------------------------------------------
|
||||
ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0)
|
||||
EXR = DCOS(ZR)
|
||||
EXI = DSIN(ZR)
|
||||
EY = 0.0D0
|
||||
TAY = DABS(ZI+ZI)
|
||||
IF (TAY.LT.ELIM) EY = DEXP(-TAY)
|
||||
IF (ZI.LT.0.0D0) GO TO 90
|
||||
C1R = EXR*EY
|
||||
C1I = EXI*EY
|
||||
C2R = EXR
|
||||
C2I = -EXI
|
||||
70 CONTINUE
|
||||
NZ = 0
|
||||
RTOL = 1.0D0/TOL
|
||||
ASCLE = D1MACH(1)*RTOL*1.0D+3
|
||||
DO 80 I=1,N
|
||||
C STR = C1R*CYR(I) - C1I*CYI(I)
|
||||
C STI = C1R*CYI(I) + C1I*CYR(I)
|
||||
C STR = -STR + C2R*CWRKR(I) - C2I*CWRKI(I)
|
||||
C STI = -STI + C2R*CWRKI(I) + C2I*CWRKR(I)
|
||||
C CYR(I) = -STI*HCII
|
||||
C CYI(I) = STR*HCII
|
||||
AA = CWRKR(I)
|
||||
BB = CWRKI(I)
|
||||
ATOL = 1.0D0
|
||||
IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 75
|
||||
AA = AA*RTOL
|
||||
BB = BB*RTOL
|
||||
ATOL = TOL
|
||||
75 CONTINUE
|
||||
STR = (AA*C2R - BB*C2I)*ATOL
|
||||
STI = (AA*C2I + BB*C2R)*ATOL
|
||||
AA = CYR(I)
|
||||
BB = CYI(I)
|
||||
ATOL = 1.0D0
|
||||
IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 85
|
||||
AA = AA*RTOL
|
||||
BB = BB*RTOL
|
||||
ATOL = TOL
|
||||
85 CONTINUE
|
||||
STR = STR - (AA*C1R - BB*C1I)*ATOL
|
||||
STI = STI - (AA*C1I + BB*C1R)*ATOL
|
||||
CYR(I) = -STI*HCII
|
||||
CYI(I) = STR*HCII
|
||||
IF (STR.EQ.0.0D0 .AND. STI.EQ.0.0D0 .AND. EY.EQ.0.0D0) NZ = NZ
|
||||
* + 1
|
||||
80 CONTINUE
|
||||
RETURN
|
||||
90 CONTINUE
|
||||
C1R = EXR
|
||||
C1I = EXI
|
||||
C2R = EXR*EY
|
||||
C2I = -EXI*EY
|
||||
GO TO 70
|
||||
170 CONTINUE
|
||||
NZ = 0
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,110 @@
|
|||
SUBROUTINE ZBINU(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL,
|
||||
* TOL, ELIM, ALIM)
|
||||
C***BEGIN PROLOGUE ZBINU
|
||||
C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZAIRY,ZBIRY
|
||||
C
|
||||
C ZBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE
|
||||
C
|
||||
C***ROUTINES CALLED ZABS,ZASYI,ZBUNI,ZMLRI,ZSERI,ZUOIK,ZWRSK
|
||||
C***END PROLOGUE ZBINU
|
||||
DOUBLE PRECISION ALIM, AZ, CWI, CWR, CYI, CYR, DFNU, ELIM, FNU,
|
||||
* FNUL, RL, TOL, ZEROI, ZEROR, ZI, ZR, ZABS
|
||||
INTEGER I, INW, KODE, N, NLAST, NN, NUI, NW, NZ
|
||||
DIMENSION CYR(N), CYI(N), CWR(2), CWI(2)
|
||||
DATA ZEROR,ZEROI / 0.0D0, 0.0D0 /
|
||||
C
|
||||
NZ = 0
|
||||
AZ = ZABS(ZR,ZI)
|
||||
NN = N
|
||||
DFNU = FNU + DBLE(FLOAT(N-1))
|
||||
IF (AZ.LE.2.0D0) GO TO 10
|
||||
IF (AZ*AZ*0.25D0.GT.DFNU+1.0D0) GO TO 20
|
||||
10 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C POWER SERIES
|
||||
C-----------------------------------------------------------------------
|
||||
CALL ZSERI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM)
|
||||
INW = IABS(NW)
|
||||
NZ = NZ + INW
|
||||
NN = NN - INW
|
||||
IF (NN.EQ.0) RETURN
|
||||
IF (NW.GE.0) GO TO 120
|
||||
DFNU = FNU + DBLE(FLOAT(NN-1))
|
||||
20 CONTINUE
|
||||
IF (AZ.LT.RL) GO TO 40
|
||||
IF (DFNU.LE.1.0D0) GO TO 30
|
||||
IF (AZ+AZ.LT.DFNU*DFNU) GO TO 50
|
||||
C-----------------------------------------------------------------------
|
||||
C ASYMPTOTIC EXPANSION FOR LARGE Z
|
||||
C-----------------------------------------------------------------------
|
||||
30 CONTINUE
|
||||
CALL ZASYI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, RL, TOL, ELIM,
|
||||
* ALIM)
|
||||
IF (NW.LT.0) GO TO 130
|
||||
GO TO 120
|
||||
40 CONTINUE
|
||||
IF (DFNU.LE.1.0D0) GO TO 70
|
||||
50 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C OVERFLOW AND UNDERFLOW TEST ON I SEQUENCE FOR MILLER ALGORITHM
|
||||
C-----------------------------------------------------------------------
|
||||
CALL ZUOIK(ZR, ZI, FNU, KODE, 1, NN, CYR, CYI, NW, TOL, ELIM,
|
||||
* ALIM)
|
||||
IF (NW.LT.0) GO TO 130
|
||||
NZ = NZ + NW
|
||||
NN = NN - NW
|
||||
IF (NN.EQ.0) RETURN
|
||||
DFNU = FNU+DBLE(FLOAT(NN-1))
|
||||
IF (DFNU.GT.FNUL) GO TO 110
|
||||
IF (AZ.GT.FNUL) GO TO 110
|
||||
60 CONTINUE
|
||||
IF (AZ.GT.RL) GO TO 80
|
||||
70 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C MILLER ALGORITHM NORMALIZED BY THE SERIES
|
||||
C-----------------------------------------------------------------------
|
||||
CALL ZMLRI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, TOL)
|
||||
IF(NW.LT.0) GO TO 130
|
||||
GO TO 120
|
||||
80 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C MILLER ALGORITHM NORMALIZED BY THE WRONSKIAN
|
||||
C-----------------------------------------------------------------------
|
||||
C-----------------------------------------------------------------------
|
||||
C OVERFLOW TEST ON K FUNCTIONS USED IN WRONSKIAN
|
||||
C-----------------------------------------------------------------------
|
||||
CALL ZUOIK(ZR, ZI, FNU, KODE, 2, 2, CWR, CWI, NW, TOL, ELIM,
|
||||
* ALIM)
|
||||
IF (NW.GE.0) GO TO 100
|
||||
NZ = NN
|
||||
DO 90 I=1,NN
|
||||
CYR(I) = ZEROR
|
||||
CYI(I) = ZEROI
|
||||
90 CONTINUE
|
||||
RETURN
|
||||
100 CONTINUE
|
||||
IF (NW.GT.0) GO TO 130
|
||||
CALL ZWRSK(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, CWR, CWI, TOL,
|
||||
* ELIM, ALIM)
|
||||
IF (NW.LT.0) GO TO 130
|
||||
GO TO 120
|
||||
110 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C INCREMENT FNU+NN-1 UP TO FNUL, COMPUTE AND RECUR BACKWARD
|
||||
C-----------------------------------------------------------------------
|
||||
NUI = INT(SNGL(FNUL-DFNU)) + 1
|
||||
NUI = MAX0(NUI,0)
|
||||
CALL ZBUNI(ZR, ZI, FNU, KODE, NN, CYR, CYI, NW, NUI, NLAST, FNUL,
|
||||
* TOL, ELIM, ALIM)
|
||||
IF (NW.LT.0) GO TO 130
|
||||
NZ = NZ + NW
|
||||
IF (NLAST.EQ.0) GO TO 120
|
||||
NN = NLAST
|
||||
GO TO 60
|
||||
120 CONTINUE
|
||||
RETURN
|
||||
130 CONTINUE
|
||||
NZ = -1
|
||||
IF(NW.EQ.(-2)) NZ=-2
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,568 @@
|
|||
SUBROUTINE ZBKNU(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM,
|
||||
* ALIM)
|
||||
C***BEGIN PROLOGUE ZBKNU
|
||||
C***REFER TO ZBESI,ZBESK,ZAIRY,ZBESH
|
||||
C
|
||||
C ZBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE.
|
||||
C
|
||||
C***ROUTINES CALLED DGAMLN,I1MACH,D1MACH,ZKSCL,ZSHCH,ZUCHK,ZABS,ZDIV,
|
||||
C ZEXP,ZLOG,ZMLT,ZSQRT
|
||||
C***END PROLOGUE ZBKNU
|
||||
C
|
||||
DOUBLE PRECISION AA, AK, ALIM, ASCLE, A1, A2, BB, BK, BRY, CAZ,
|
||||
* CBI, CBR, CC, CCHI, CCHR, CKI, CKR, COEFI, COEFR, CONEI, CONER,
|
||||
* CRSCR, CSCLR, CSHI, CSHR, CSI, CSR, CSRR, CSSR, CTWOR,
|
||||
* CZEROI, CZEROR, CZI, CZR, DNU, DNU2, DPI, ELIM, ETEST, FC, FHS,
|
||||
* FI, FK, FKS, FMUI, FMUR, FNU, FPI, FR, G1, G2, HPI, PI, PR, PTI,
|
||||
* PTR, P1I, P1R, P2I, P2M, P2R, QI, QR, RAK, RCAZ, RTHPI, RZI,
|
||||
* RZR, R1, S, SMUI, SMUR, SPI, STI, STR, S1I, S1R, S2I, S2R, TM,
|
||||
* TOL, TTH, T1, T2, YI, YR, ZI, ZR, DGAMLN, D1MACH, ZABS, ELM,
|
||||
* CELMR, ZDR, ZDI, AS, ALAS, HELIM, CYR, CYI
|
||||
INTEGER I, IFLAG, INU, K, KFLAG, KK, KMAX, KODE, KODED, N, NZ,
|
||||
* IDUM, I1MACH, J, IC, INUB, NW
|
||||
DIMENSION YR(N), YI(N), CC(8), CSSR(3), CSRR(3), BRY(3), CYR(2),
|
||||
* CYI(2)
|
||||
C COMPLEX Z,Y,A,B,RZ,SMU,FU,FMU,F,FLRZ,CZ,S1,S2,CSH,CCH
|
||||
C COMPLEX CK,P,Q,COEF,P1,P2,CBK,PT,CZERO,CONE,CTWO,ST,EZ,CS,DK
|
||||
C
|
||||
DATA KMAX / 30 /
|
||||
DATA CZEROR,CZEROI,CONER,CONEI,CTWOR,R1/
|
||||
1 0.0D0 , 0.0D0 , 1.0D0 , 0.0D0 , 2.0D0 , 2.0D0 /
|
||||
DATA DPI, RTHPI, SPI ,HPI, FPI, TTH /
|
||||
1 3.14159265358979324D0, 1.25331413731550025D0,
|
||||
2 1.90985931710274403D0, 1.57079632679489662D0,
|
||||
3 1.89769999331517738D0, 6.66666666666666666D-01/
|
||||
DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)/
|
||||
1 5.77215664901532861D-01, -4.20026350340952355D-02,
|
||||
2 -4.21977345555443367D-02, 7.21894324666309954D-03,
|
||||
3 -2.15241674114950973D-04, -2.01348547807882387D-05,
|
||||
4 1.13302723198169588D-06, 6.11609510448141582D-09/
|
||||
C
|
||||
CAZ = ZABS(ZR,ZI)
|
||||
CSCLR = 1.0D0/TOL
|
||||
CRSCR = TOL
|
||||
CSSR(1) = CSCLR
|
||||
CSSR(2) = 1.0D0
|
||||
CSSR(3) = CRSCR
|
||||
CSRR(1) = CRSCR
|
||||
CSRR(2) = 1.0D0
|
||||
CSRR(3) = CSCLR
|
||||
BRY(1) = 1.0D+3*D1MACH(1)/TOL
|
||||
BRY(2) = 1.0D0/BRY(1)
|
||||
BRY(3) = D1MACH(2)
|
||||
NZ = 0
|
||||
IFLAG = 0
|
||||
KODED = KODE
|
||||
RCAZ = 1.0D0/CAZ
|
||||
STR = ZR*RCAZ
|
||||
STI = -ZI*RCAZ
|
||||
RZR = (STR+STR)*RCAZ
|
||||
RZI = (STI+STI)*RCAZ
|
||||
INU = INT(SNGL(FNU+0.5D0))
|
||||
DNU = FNU - DBLE(FLOAT(INU))
|
||||
IF (DABS(DNU).EQ.0.5D0) GO TO 110
|
||||
DNU2 = 0.0D0
|
||||
IF (DABS(DNU).GT.TOL) DNU2 = DNU*DNU
|
||||
IF (CAZ.GT.R1) GO TO 110
|
||||
C-----------------------------------------------------------------------
|
||||
C SERIES FOR CABS(Z).LE.R1
|
||||
C-----------------------------------------------------------------------
|
||||
FC = 1.0D0
|
||||
CALL ZLOG(RZR, RZI, SMUR, SMUI, IDUM)
|
||||
FMUR = SMUR*DNU
|
||||
FMUI = SMUI*DNU
|
||||
CALL ZSHCH(FMUR, FMUI, CSHR, CSHI, CCHR, CCHI)
|
||||
IF (DNU.EQ.0.0D0) GO TO 10
|
||||
FC = DNU*DPI
|
||||
FC = FC/DSIN(FC)
|
||||
SMUR = CSHR/DNU
|
||||
SMUI = CSHI/DNU
|
||||
10 CONTINUE
|
||||
A2 = 1.0D0 + DNU
|
||||
C-----------------------------------------------------------------------
|
||||
C GAM(1-Z)*GAM(1+Z)=PI*Z/SIN(PI*Z), T1=1/GAM(1-DNU), T2=1/GAM(1+DNU)
|
||||
C-----------------------------------------------------------------------
|
||||
T2 = DEXP(-DGAMLN(A2,IDUM))
|
||||
T1 = 1.0D0/(T2*FC)
|
||||
IF (DABS(DNU).GT.0.1D0) GO TO 40
|
||||
C-----------------------------------------------------------------------
|
||||
C SERIES FOR F0 TO RESOLVE INDETERMINACY FOR SMALL ABS(DNU)
|
||||
C-----------------------------------------------------------------------
|
||||
AK = 1.0D0
|
||||
S = CC(1)
|
||||
DO 20 K=2,8
|
||||
AK = AK*DNU2
|
||||
TM = CC(K)*AK
|
||||
S = S + TM
|
||||
IF (DABS(TM).LT.TOL) GO TO 30
|
||||
20 CONTINUE
|
||||
30 G1 = -S
|
||||
GO TO 50
|
||||
40 CONTINUE
|
||||
G1 = (T1-T2)/(DNU+DNU)
|
||||
50 CONTINUE
|
||||
G2 = (T1+T2)*0.5D0
|
||||
FR = FC*(CCHR*G1+SMUR*G2)
|
||||
FI = FC*(CCHI*G1+SMUI*G2)
|
||||
CALL ZEXP(FMUR, FMUI, STR, STI)
|
||||
PR = 0.5D0*STR/T2
|
||||
PI = 0.5D0*STI/T2
|
||||
CALL ZDIV(0.5D0, 0.0D0, STR, STI, PTR, PTI)
|
||||
QR = PTR/T1
|
||||
QI = PTI/T1
|
||||
S1R = FR
|
||||
S1I = FI
|
||||
S2R = PR
|
||||
S2I = PI
|
||||
AK = 1.0D0
|
||||
A1 = 1.0D0
|
||||
CKR = CONER
|
||||
CKI = CONEI
|
||||
BK = 1.0D0 - DNU2
|
||||
IF (INU.GT.0 .OR. N.GT.1) GO TO 80
|
||||
C-----------------------------------------------------------------------
|
||||
C GENERATE K(FNU,Z), 0.0D0 .LE. FNU .LT. 0.5D0 AND N=1
|
||||
C-----------------------------------------------------------------------
|
||||
IF (CAZ.LT.TOL) GO TO 70
|
||||
CALL ZMLT(ZR, ZI, ZR, ZI, CZR, CZI)
|
||||
CZR = 0.25D0*CZR
|
||||
CZI = 0.25D0*CZI
|
||||
T1 = 0.25D0*CAZ*CAZ
|
||||
60 CONTINUE
|
||||
FR = (FR*AK+PR+QR)/BK
|
||||
FI = (FI*AK+PI+QI)/BK
|
||||
STR = 1.0D0/(AK-DNU)
|
||||
PR = PR*STR
|
||||
PI = PI*STR
|
||||
STR = 1.0D0/(AK+DNU)
|
||||
QR = QR*STR
|
||||
QI = QI*STR
|
||||
STR = CKR*CZR - CKI*CZI
|
||||
RAK = 1.0D0/AK
|
||||
CKI = (CKR*CZI+CKI*CZR)*RAK
|
||||
CKR = STR*RAK
|
||||
S1R = CKR*FR - CKI*FI + S1R
|
||||
S1I = CKR*FI + CKI*FR + S1I
|
||||
A1 = A1*T1*RAK
|
||||
BK = BK + AK + AK + 1.0D0
|
||||
AK = AK + 1.0D0
|
||||
IF (A1.GT.TOL) GO TO 60
|
||||
70 CONTINUE
|
||||
YR(1) = S1R
|
||||
YI(1) = S1I
|
||||
IF (KODED.EQ.1) RETURN
|
||||
CALL ZEXP(ZR, ZI, STR, STI)
|
||||
CALL ZMLT(S1R, S1I, STR, STI, YR(1), YI(1))
|
||||
RETURN
|
||||
C-----------------------------------------------------------------------
|
||||
C GENERATE K(DNU,Z) AND K(DNU+1,Z) FOR FORWARD RECURRENCE
|
||||
C-----------------------------------------------------------------------
|
||||
80 CONTINUE
|
||||
IF (CAZ.LT.TOL) GO TO 100
|
||||
CALL ZMLT(ZR, ZI, ZR, ZI, CZR, CZI)
|
||||
CZR = 0.25D0*CZR
|
||||
CZI = 0.25D0*CZI
|
||||
T1 = 0.25D0*CAZ*CAZ
|
||||
90 CONTINUE
|
||||
FR = (FR*AK+PR+QR)/BK
|
||||
FI = (FI*AK+PI+QI)/BK
|
||||
STR = 1.0D0/(AK-DNU)
|
||||
PR = PR*STR
|
||||
PI = PI*STR
|
||||
STR = 1.0D0/(AK+DNU)
|
||||
QR = QR*STR
|
||||
QI = QI*STR
|
||||
STR = CKR*CZR - CKI*CZI
|
||||
RAK = 1.0D0/AK
|
||||
CKI = (CKR*CZI+CKI*CZR)*RAK
|
||||
CKR = STR*RAK
|
||||
S1R = CKR*FR - CKI*FI + S1R
|
||||
S1I = CKR*FI + CKI*FR + S1I
|
||||
STR = PR - FR*AK
|
||||
STI = PI - FI*AK
|
||||
S2R = CKR*STR - CKI*STI + S2R
|
||||
S2I = CKR*STI + CKI*STR + S2I
|
||||
A1 = A1*T1*RAK
|
||||
BK = BK + AK + AK + 1.0D0
|
||||
AK = AK + 1.0D0
|
||||
IF (A1.GT.TOL) GO TO 90
|
||||
100 CONTINUE
|
||||
KFLAG = 2
|
||||
A1 = FNU + 1.0D0
|
||||
AK = A1*DABS(SMUR)
|
||||
IF (AK.GT.ALIM) KFLAG = 3
|
||||
STR = CSSR(KFLAG)
|
||||
P2R = S2R*STR
|
||||
P2I = S2I*STR
|
||||
CALL ZMLT(P2R, P2I, RZR, RZI, S2R, S2I)
|
||||
S1R = S1R*STR
|
||||
S1I = S1I*STR
|
||||
IF (KODED.EQ.1) GO TO 210
|
||||
CALL ZEXP(ZR, ZI, FR, FI)
|
||||
CALL ZMLT(S1R, S1I, FR, FI, S1R, S1I)
|
||||
CALL ZMLT(S2R, S2I, FR, FI, S2R, S2I)
|
||||
GO TO 210
|
||||
C-----------------------------------------------------------------------
|
||||
C IFLAG=0 MEANS NO UNDERFLOW OCCURRED
|
||||
C IFLAG=1 MEANS AN UNDERFLOW OCCURRED- COMPUTATION PROCEEDS WITH
|
||||
C KODED=2 AND A TEST FOR ON SCALE VALUES IS MADE DURING FORWARD
|
||||
C RECURSION
|
||||
C-----------------------------------------------------------------------
|
||||
110 CONTINUE
|
||||
CALL ZSQRT(ZR, ZI, STR, STI)
|
||||
CALL ZDIV(RTHPI, CZEROI, STR, STI, COEFR, COEFI)
|
||||
KFLAG = 2
|
||||
IF (KODED.EQ.2) GO TO 120
|
||||
IF (ZR.GT.ALIM) GO TO 290
|
||||
C BLANK LINE
|
||||
STR = DEXP(-ZR)*CSSR(KFLAG)
|
||||
STI = -STR*DSIN(ZI)
|
||||
STR = STR*DCOS(ZI)
|
||||
CALL ZMLT(COEFR, COEFI, STR, STI, COEFR, COEFI)
|
||||
120 CONTINUE
|
||||
IF (DABS(DNU).EQ.0.5D0) GO TO 300
|
||||
C-----------------------------------------------------------------------
|
||||
C MILLER ALGORITHM FOR CABS(Z).GT.R1
|
||||
C-----------------------------------------------------------------------
|
||||
AK = DCOS(DPI*DNU)
|
||||
AK = DABS(AK)
|
||||
IF (AK.EQ.CZEROR) GO TO 300
|
||||
FHS = DABS(0.25D0-DNU2)
|
||||
IF (FHS.EQ.CZEROR) GO TO 300
|
||||
C-----------------------------------------------------------------------
|
||||
C COMPUTE R2=F(E). IF CABS(Z).GE.R2, USE FORWARD RECURRENCE TO
|
||||
C DETERMINE THE BACKWARD INDEX K. R2=F(E) IS A STRAIGHT LINE ON
|
||||
C 12.LE.E.LE.60. E IS COMPUTED FROM 2**(-E)=B**(1-I1MACH(14))=
|
||||
C TOL WHERE B IS THE BASE OF THE ARITHMETIC.
|
||||
C-----------------------------------------------------------------------
|
||||
T1 = DBLE(FLOAT(I1MACH(14)-1))
|
||||
T1 = T1*D1MACH(5)*3.321928094D0
|
||||
T1 = DMAX1(T1,12.0D0)
|
||||
T1 = DMIN1(T1,60.0D0)
|
||||
T2 = TTH*T1 - 6.0D0
|
||||
IF (ZR.NE.0.0D0) GO TO 130
|
||||
T1 = HPI
|
||||
GO TO 140
|
||||
130 CONTINUE
|
||||
T1 = DATAN(ZI/ZR)
|
||||
T1 = DABS(T1)
|
||||
140 CONTINUE
|
||||
IF (T2.GT.CAZ) GO TO 170
|
||||
C-----------------------------------------------------------------------
|
||||
C FORWARD RECURRENCE LOOP WHEN CABS(Z).GE.R2
|
||||
C-----------------------------------------------------------------------
|
||||
ETEST = AK/(DPI*CAZ*TOL)
|
||||
FK = CONER
|
||||
IF (ETEST.LT.CONER) GO TO 180
|
||||
FKS = CTWOR
|
||||
CKR = CAZ + CAZ + CTWOR
|
||||
P1R = CZEROR
|
||||
P2R = CONER
|
||||
DO 150 I=1,KMAX
|
||||
AK = FHS/FKS
|
||||
CBR = CKR/(FK+CONER)
|
||||
PTR = P2R
|
||||
P2R = CBR*P2R - P1R*AK
|
||||
P1R = PTR
|
||||
CKR = CKR + CTWOR
|
||||
FKS = FKS + FK + FK + CTWOR
|
||||
FHS = FHS + FK + FK
|
||||
FK = FK + CONER
|
||||
STR = DABS(P2R)*FK
|
||||
IF (ETEST.LT.STR) GO TO 160
|
||||
150 CONTINUE
|
||||
GO TO 310
|
||||
160 CONTINUE
|
||||
FK = FK + SPI*T1*DSQRT(T2/CAZ)
|
||||
FHS = DABS(0.25D0-DNU2)
|
||||
GO TO 180
|
||||
170 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C COMPUTE BACKWARD INDEX K FOR CABS(Z).LT.R2
|
||||
C-----------------------------------------------------------------------
|
||||
A2 = DSQRT(CAZ)
|
||||
AK = FPI*AK/(TOL*DSQRT(A2))
|
||||
AA = 3.0D0*T1/(1.0D0+CAZ)
|
||||
BB = 14.7D0*T1/(28.0D0+CAZ)
|
||||
AK = (DLOG(AK)+CAZ*DCOS(AA)/(1.0D0+0.008D0*CAZ))/DCOS(BB)
|
||||
FK = 0.12125D0*AK*AK/CAZ + 1.5D0
|
||||
180 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C BACKWARD RECURRENCE LOOP FOR MILLER ALGORITHM
|
||||
C-----------------------------------------------------------------------
|
||||
K = INT(SNGL(FK))
|
||||
FK = DBLE(FLOAT(K))
|
||||
FKS = FK*FK
|
||||
P1R = CZEROR
|
||||
P1I = CZEROI
|
||||
P2R = TOL
|
||||
P2I = CZEROI
|
||||
CSR = P2R
|
||||
CSI = P2I
|
||||
DO 190 I=1,K
|
||||
A1 = FKS - FK
|
||||
AK = (FKS+FK)/(A1+FHS)
|
||||
RAK = 2.0D0/(FK+CONER)
|
||||
CBR = (FK+ZR)*RAK
|
||||
CBI = ZI*RAK
|
||||
PTR = P2R
|
||||
PTI = P2I
|
||||
P2R = (PTR*CBR-PTI*CBI-P1R)*AK
|
||||
P2I = (PTI*CBR+PTR*CBI-P1I)*AK
|
||||
P1R = PTR
|
||||
P1I = PTI
|
||||
CSR = CSR + P2R
|
||||
CSI = CSI + P2I
|
||||
FKS = A1 - FK + CONER
|
||||
FK = FK - CONER
|
||||
190 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C COMPUTE (P2/CS)=(P2/CABS(CS))*(CONJG(CS)/CABS(CS)) FOR BETTER
|
||||
C SCALING
|
||||
C-----------------------------------------------------------------------
|
||||
TM = ZABS(CSR,CSI)
|
||||
PTR = 1.0D0/TM
|
||||
S1R = P2R*PTR
|
||||
S1I = P2I*PTR
|
||||
CSR = CSR*PTR
|
||||
CSI = -CSI*PTR
|
||||
CALL ZMLT(COEFR, COEFI, S1R, S1I, STR, STI)
|
||||
CALL ZMLT(STR, STI, CSR, CSI, S1R, S1I)
|
||||
IF (INU.GT.0 .OR. N.GT.1) GO TO 200
|
||||
ZDR = ZR
|
||||
ZDI = ZI
|
||||
IF(IFLAG.EQ.1) GO TO 270
|
||||
GO TO 240
|
||||
200 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C COMPUTE P1/P2=(P1/CABS(P2)*CONJG(P2)/CABS(P2) FOR SCALING
|
||||
C-----------------------------------------------------------------------
|
||||
TM = ZABS(P2R,P2I)
|
||||
PTR = 1.0D0/TM
|
||||
P1R = P1R*PTR
|
||||
P1I = P1I*PTR
|
||||
P2R = P2R*PTR
|
||||
P2I = -P2I*PTR
|
||||
CALL ZMLT(P1R, P1I, P2R, P2I, PTR, PTI)
|
||||
STR = DNU + 0.5D0 - PTR
|
||||
STI = -PTI
|
||||
CALL ZDIV(STR, STI, ZR, ZI, STR, STI)
|
||||
STR = STR + 1.0D0
|
||||
CALL ZMLT(STR, STI, S1R, S1I, S2R, S2I)
|
||||
C-----------------------------------------------------------------------
|
||||
C FORWARD RECURSION ON THE THREE TERM RECURSION WITH RELATION WITH
|
||||
C SCALING NEAR EXPONENT EXTREMES ON KFLAG=1 OR KFLAG=3
|
||||
C-----------------------------------------------------------------------
|
||||
210 CONTINUE
|
||||
STR = DNU + 1.0D0
|
||||
CKR = STR*RZR
|
||||
CKI = STR*RZI
|
||||
IF (N.EQ.1) INU = INU - 1
|
||||
IF (INU.GT.0) GO TO 220
|
||||
IF (N.GT.1) GO TO 215
|
||||
S1R = S2R
|
||||
S1I = S2I
|
||||
215 CONTINUE
|
||||
ZDR = ZR
|
||||
ZDI = ZI
|
||||
IF(IFLAG.EQ.1) GO TO 270
|
||||
GO TO 240
|
||||
220 CONTINUE
|
||||
INUB = 1
|
||||
IF(IFLAG.EQ.1) GO TO 261
|
||||
225 CONTINUE
|
||||
P1R = CSRR(KFLAG)
|
||||
ASCLE = BRY(KFLAG)
|
||||
DO 230 I=INUB,INU
|
||||
STR = S2R
|
||||
STI = S2I
|
||||
S2R = CKR*STR - CKI*STI + S1R
|
||||
S2I = CKR*STI + CKI*STR + S1I
|
||||
S1R = STR
|
||||
S1I = STI
|
||||
CKR = CKR + RZR
|
||||
CKI = CKI + RZI
|
||||
IF (KFLAG.GE.3) GO TO 230
|
||||
P2R = S2R*P1R
|
||||
P2I = S2I*P1R
|
||||
STR = DABS(P2R)
|
||||
STI = DABS(P2I)
|
||||
P2M = DMAX1(STR,STI)
|
||||
IF (P2M.LE.ASCLE) GO TO 230
|
||||
KFLAG = KFLAG + 1
|
||||
ASCLE = BRY(KFLAG)
|
||||
S1R = S1R*P1R
|
||||
S1I = S1I*P1R
|
||||
S2R = P2R
|
||||
S2I = P2I
|
||||
STR = CSSR(KFLAG)
|
||||
S1R = S1R*STR
|
||||
S1I = S1I*STR
|
||||
S2R = S2R*STR
|
||||
S2I = S2I*STR
|
||||
P1R = CSRR(KFLAG)
|
||||
230 CONTINUE
|
||||
IF (N.NE.1) GO TO 240
|
||||
S1R = S2R
|
||||
S1I = S2I
|
||||
240 CONTINUE
|
||||
STR = CSRR(KFLAG)
|
||||
YR(1) = S1R*STR
|
||||
YI(1) = S1I*STR
|
||||
IF (N.EQ.1) RETURN
|
||||
YR(2) = S2R*STR
|
||||
YI(2) = S2I*STR
|
||||
IF (N.EQ.2) RETURN
|
||||
KK = 2
|
||||
250 CONTINUE
|
||||
KK = KK + 1
|
||||
IF (KK.GT.N) RETURN
|
||||
P1R = CSRR(KFLAG)
|
||||
ASCLE = BRY(KFLAG)
|
||||
DO 260 I=KK,N
|
||||
P2R = S2R
|
||||
P2I = S2I
|
||||
S2R = CKR*P2R - CKI*P2I + S1R
|
||||
S2I = CKI*P2R + CKR*P2I + S1I
|
||||
S1R = P2R
|
||||
S1I = P2I
|
||||
CKR = CKR + RZR
|
||||
CKI = CKI + RZI
|
||||
P2R = S2R*P1R
|
||||
P2I = S2I*P1R
|
||||
YR(I) = P2R
|
||||
YI(I) = P2I
|
||||
IF (KFLAG.GE.3) GO TO 260
|
||||
STR = DABS(P2R)
|
||||
STI = DABS(P2I)
|
||||
P2M = DMAX1(STR,STI)
|
||||
IF (P2M.LE.ASCLE) GO TO 260
|
||||
KFLAG = KFLAG + 1
|
||||
ASCLE = BRY(KFLAG)
|
||||
S1R = S1R*P1R
|
||||
S1I = S1I*P1R
|
||||
S2R = P2R
|
||||
S2I = P2I
|
||||
STR = CSSR(KFLAG)
|
||||
S1R = S1R*STR
|
||||
S1I = S1I*STR
|
||||
S2R = S2R*STR
|
||||
S2I = S2I*STR
|
||||
P1R = CSRR(KFLAG)
|
||||
260 CONTINUE
|
||||
RETURN
|
||||
C-----------------------------------------------------------------------
|
||||
C IFLAG=1 CASES, FORWARD RECURRENCE ON SCALED VALUES ON UNDERFLOW
|
||||
C-----------------------------------------------------------------------
|
||||
261 CONTINUE
|
||||
HELIM = 0.5D0*ELIM
|
||||
ELM = DEXP(-ELIM)
|
||||
CELMR = ELM
|
||||
ASCLE = BRY(1)
|
||||
ZDR = ZR
|
||||
ZDI = ZI
|
||||
IC = -1
|
||||
J = 2
|
||||
DO 262 I=1,INU
|
||||
STR = S2R
|
||||
STI = S2I
|
||||
S2R = STR*CKR-STI*CKI+S1R
|
||||
S2I = STI*CKR+STR*CKI+S1I
|
||||
S1R = STR
|
||||
S1I = STI
|
||||
CKR = CKR+RZR
|
||||
CKI = CKI+RZI
|
||||
AS = ZABS(S2R,S2I)
|
||||
ALAS = DLOG(AS)
|
||||
P2R = -ZDR+ALAS
|
||||
IF(P2R.LT.(-ELIM)) GO TO 263
|
||||
CALL ZLOG(S2R,S2I,STR,STI,IDUM)
|
||||
P2R = -ZDR+STR
|
||||
P2I = -ZDI+STI
|
||||
P2M = DEXP(P2R)/TOL
|
||||
P1R = P2M*DCOS(P2I)
|
||||
P1I = P2M*DSIN(P2I)
|
||||
CALL ZUCHK(P1R,P1I,NW,ASCLE,TOL)
|
||||
IF(NW.NE.0) GO TO 263
|
||||
J = 3 - J
|
||||
CYR(J) = P1R
|
||||
CYI(J) = P1I
|
||||
IF(IC.EQ.(I-1)) GO TO 264
|
||||
IC = I
|
||||
GO TO 262
|
||||
263 CONTINUE
|
||||
IF(ALAS.LT.HELIM) GO TO 262
|
||||
ZDR = ZDR-ELIM
|
||||
S1R = S1R*CELMR
|
||||
S1I = S1I*CELMR
|
||||
S2R = S2R*CELMR
|
||||
S2I = S2I*CELMR
|
||||
262 CONTINUE
|
||||
IF(N.NE.1) GO TO 270
|
||||
S1R = S2R
|
||||
S1I = S2I
|
||||
GO TO 270
|
||||
264 CONTINUE
|
||||
KFLAG = 1
|
||||
INUB = I+1
|
||||
S2R = CYR(J)
|
||||
S2I = CYI(J)
|
||||
J = 3 - J
|
||||
S1R = CYR(J)
|
||||
S1I = CYI(J)
|
||||
IF(INUB.LE.INU) GO TO 225
|
||||
IF(N.NE.1) GO TO 240
|
||||
S1R = S2R
|
||||
S1I = S2I
|
||||
GO TO 240
|
||||
270 CONTINUE
|
||||
YR(1) = S1R
|
||||
YI(1) = S1I
|
||||
IF(N.EQ.1) GO TO 280
|
||||
YR(2) = S2R
|
||||
YI(2) = S2I
|
||||
280 CONTINUE
|
||||
ASCLE = BRY(1)
|
||||
CALL ZKSCL(ZDR,ZDI,FNU,N,YR,YI,NZ,RZR,RZI,ASCLE,TOL,ELIM)
|
||||
INU = N - NZ
|
||||
IF (INU.LE.0) RETURN
|
||||
KK = NZ + 1
|
||||
S1R = YR(KK)
|
||||
S1I = YI(KK)
|
||||
YR(KK) = S1R*CSRR(1)
|
||||
YI(KK) = S1I*CSRR(1)
|
||||
IF (INU.EQ.1) RETURN
|
||||
KK = NZ + 2
|
||||
S2R = YR(KK)
|
||||
S2I = YI(KK)
|
||||
YR(KK) = S2R*CSRR(1)
|
||||
YI(KK) = S2I*CSRR(1)
|
||||
IF (INU.EQ.2) RETURN
|
||||
T2 = FNU + DBLE(FLOAT(KK-1))
|
||||
CKR = T2*RZR
|
||||
CKI = T2*RZI
|
||||
KFLAG = 1
|
||||
GO TO 250
|
||||
290 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C SCALE BY DEXP(Z), IFLAG = 1 CASES
|
||||
C-----------------------------------------------------------------------
|
||||
KODED = 2
|
||||
IFLAG = 1
|
||||
KFLAG = 2
|
||||
GO TO 120
|
||||
C-----------------------------------------------------------------------
|
||||
C FNU=HALF ODD INTEGER CASE, DNU=-0.5
|
||||
C-----------------------------------------------------------------------
|
||||
300 CONTINUE
|
||||
S1R = COEFR
|
||||
S1I = COEFI
|
||||
S2R = COEFR
|
||||
S2I = COEFI
|
||||
GO TO 210
|
||||
C
|
||||
C
|
||||
310 CONTINUE
|
||||
NZ=-2
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,174 @@
|
|||
SUBROUTINE ZBUNI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NUI, NLAST,
|
||||
* FNUL, TOL, ELIM, ALIM)
|
||||
C***BEGIN PROLOGUE ZBUNI
|
||||
C***REFER TO ZBESI,ZBESK
|
||||
C
|
||||
C ZBUNI COMPUTES THE I BESSEL FUNCTION FOR LARGE CABS(Z).GT.
|
||||
C FNUL AND FNU+N-1.LT.FNUL. THE ORDER IS INCREASED FROM
|
||||
C FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING
|
||||
C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z)
|
||||
C ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2
|
||||
C
|
||||
C***ROUTINES CALLED ZUNI1,ZUNI2,ZABS,D1MACH
|
||||
C***END PROLOGUE ZBUNI
|
||||
C COMPLEX CSCL,CSCR,CY,RZ,ST,S1,S2,Y,Z
|
||||
DOUBLE PRECISION ALIM, AX, AY, CSCLR, CSCRR, CYI, CYR, DFNU,
|
||||
* ELIM, FNU, FNUI, FNUL, GNU, RAZ, RZI, RZR, STI, STR, S1I, S1R,
|
||||
* S2I, S2R, TOL, YI, YR, ZI, ZR, ZABS, ASCLE, BRY, C1R, C1I, C1M,
|
||||
* D1MACH
|
||||
INTEGER I, IFLAG, IFORM, K, KODE, N, NL, NLAST, NUI, NW, NZ
|
||||
DIMENSION YR(N), YI(N), CYR(2), CYI(2), BRY(3)
|
||||
NZ = 0
|
||||
AX = DABS(ZR)*1.7321D0
|
||||
AY = DABS(ZI)
|
||||
IFORM = 1
|
||||
IF (AY.GT.AX) IFORM = 2
|
||||
IF (NUI.EQ.0) GO TO 60
|
||||
FNUI = DBLE(FLOAT(NUI))
|
||||
DFNU = FNU + DBLE(FLOAT(N-1))
|
||||
GNU = DFNU + FNUI
|
||||
IF (IFORM.EQ.2) GO TO 10
|
||||
C-----------------------------------------------------------------------
|
||||
C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN
|
||||
C -PI/3.LE.ARG(Z).LE.PI/3
|
||||
C-----------------------------------------------------------------------
|
||||
CALL ZUNI1(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL,
|
||||
* ELIM, ALIM)
|
||||
GO TO 20
|
||||
10 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU
|
||||
C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I
|
||||
C AND HPI=PI/2
|
||||
C-----------------------------------------------------------------------
|
||||
CALL ZUNI2(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL,
|
||||
* ELIM, ALIM)
|
||||
20 CONTINUE
|
||||
IF (NW.LT.0) GO TO 50
|
||||
IF (NW.NE.0) GO TO 90
|
||||
STR = ZABS(CYR(1),CYI(1))
|
||||
C----------------------------------------------------------------------
|
||||
C SCALE BACKWARD RECURRENCE, BRY(3) IS DEFINED BUT NEVER USED
|
||||
C----------------------------------------------------------------------
|
||||
BRY(1)=1.0D+3*D1MACH(1)/TOL
|
||||
BRY(2) = 1.0D0/BRY(1)
|
||||
BRY(3) = BRY(2)
|
||||
IFLAG = 2
|
||||
ASCLE = BRY(2)
|
||||
CSCLR = 1.0D0
|
||||
IF (STR.GT.BRY(1)) GO TO 21
|
||||
IFLAG = 1
|
||||
ASCLE = BRY(1)
|
||||
CSCLR = 1.0D0/TOL
|
||||
GO TO 25
|
||||
21 CONTINUE
|
||||
IF (STR.LT.BRY(2)) GO TO 25
|
||||
IFLAG = 3
|
||||
ASCLE=BRY(3)
|
||||
CSCLR = TOL
|
||||
25 CONTINUE
|
||||
CSCRR = 1.0D0/CSCLR
|
||||
S1R = CYR(2)*CSCLR
|
||||
S1I = CYI(2)*CSCLR
|
||||
S2R = CYR(1)*CSCLR
|
||||
S2I = CYI(1)*CSCLR
|
||||
RAZ = 1.0D0/ZABS(ZR,ZI)
|
||||
STR = ZR*RAZ
|
||||
STI = -ZI*RAZ
|
||||
RZR = (STR+STR)*RAZ
|
||||
RZI = (STI+STI)*RAZ
|
||||
DO 30 I=1,NUI
|
||||
STR = S2R
|
||||
STI = S2I
|
||||
S2R = (DFNU+FNUI)*(RZR*STR-RZI*STI) + S1R
|
||||
S2I = (DFNU+FNUI)*(RZR*STI+RZI*STR) + S1I
|
||||
S1R = STR
|
||||
S1I = STI
|
||||
FNUI = FNUI - 1.0D0
|
||||
IF (IFLAG.GE.3) GO TO 30
|
||||
STR = S2R*CSCRR
|
||||
STI = S2I*CSCRR
|
||||
C1R = DABS(STR)
|
||||
C1I = DABS(STI)
|
||||
C1M = DMAX1(C1R,C1I)
|
||||
IF (C1M.LE.ASCLE) GO TO 30
|
||||
IFLAG = IFLAG+1
|
||||
ASCLE = BRY(IFLAG)
|
||||
S1R = S1R*CSCRR
|
||||
S1I = S1I*CSCRR
|
||||
S2R = STR
|
||||
S2I = STI
|
||||
CSCLR = CSCLR*TOL
|
||||
CSCRR = 1.0D0/CSCLR
|
||||
S1R = S1R*CSCLR
|
||||
S1I = S1I*CSCLR
|
||||
S2R = S2R*CSCLR
|
||||
S2I = S2I*CSCLR
|
||||
30 CONTINUE
|
||||
YR(N) = S2R*CSCRR
|
||||
YI(N) = S2I*CSCRR
|
||||
IF (N.EQ.1) RETURN
|
||||
NL = N - 1
|
||||
FNUI = DBLE(FLOAT(NL))
|
||||
K = NL
|
||||
DO 40 I=1,NL
|
||||
STR = S2R
|
||||
STI = S2I
|
||||
S2R = (FNU+FNUI)*(RZR*STR-RZI*STI) + S1R
|
||||
S2I = (FNU+FNUI)*(RZR*STI+RZI*STR) + S1I
|
||||
S1R = STR
|
||||
S1I = STI
|
||||
STR = S2R*CSCRR
|
||||
STI = S2I*CSCRR
|
||||
YR(K) = STR
|
||||
YI(K) = STI
|
||||
FNUI = FNUI - 1.0D0
|
||||
K = K - 1
|
||||
IF (IFLAG.GE.3) GO TO 40
|
||||
C1R = DABS(STR)
|
||||
C1I = DABS(STI)
|
||||
C1M = DMAX1(C1R,C1I)
|
||||
IF (C1M.LE.ASCLE) GO TO 40
|
||||
IFLAG = IFLAG+1
|
||||
ASCLE = BRY(IFLAG)
|
||||
S1R = S1R*CSCRR
|
||||
S1I = S1I*CSCRR
|
||||
S2R = STR
|
||||
S2I = STI
|
||||
CSCLR = CSCLR*TOL
|
||||
CSCRR = 1.0D0/CSCLR
|
||||
S1R = S1R*CSCLR
|
||||
S1I = S1I*CSCLR
|
||||
S2R = S2R*CSCLR
|
||||
S2I = S2I*CSCLR
|
||||
40 CONTINUE
|
||||
RETURN
|
||||
50 CONTINUE
|
||||
NZ = -1
|
||||
IF(NW.EQ.(-2)) NZ=-2
|
||||
RETURN
|
||||
60 CONTINUE
|
||||
IF (IFORM.EQ.2) GO TO 70
|
||||
C-----------------------------------------------------------------------
|
||||
C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN
|
||||
C -PI/3.LE.ARG(Z).LE.PI/3
|
||||
C-----------------------------------------------------------------------
|
||||
CALL ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL,
|
||||
* ELIM, ALIM)
|
||||
GO TO 80
|
||||
70 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU
|
||||
C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I
|
||||
C AND HPI=PI/2
|
||||
C-----------------------------------------------------------------------
|
||||
CALL ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NW, NLAST, FNUL, TOL,
|
||||
* ELIM, ALIM)
|
||||
80 CONTINUE
|
||||
IF (NW.LT.0) GO TO 50
|
||||
NZ = NW
|
||||
RETURN
|
||||
90 CONTINUE
|
||||
NLAST = N
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,35 @@
|
|||
SUBROUTINE ZBUNK(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM,
|
||||
* ALIM)
|
||||
C***BEGIN PROLOGUE ZBUNK
|
||||
C***REFER TO ZBESK,ZBESH
|
||||
C
|
||||
C ZBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU.GT.FNUL.
|
||||
C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z)
|
||||
C IN ZUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN ZUNK2
|
||||
C
|
||||
C***ROUTINES CALLED ZUNK1,ZUNK2
|
||||
C***END PROLOGUE ZBUNK
|
||||
C COMPLEX Y,Z
|
||||
DOUBLE PRECISION ALIM, AX, AY, ELIM, FNU, TOL, YI, YR, ZI, ZR
|
||||
INTEGER KODE, MR, N, NZ
|
||||
DIMENSION YR(N), YI(N)
|
||||
NZ = 0
|
||||
AX = DABS(ZR)*1.7321D0
|
||||
AY = DABS(ZI)
|
||||
IF (AY.GT.AX) GO TO 10
|
||||
C-----------------------------------------------------------------------
|
||||
C ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN
|
||||
C -PI/3.LE.ARG(Z).LE.PI/3
|
||||
C-----------------------------------------------------------------------
|
||||
CALL ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM)
|
||||
GO TO 20
|
||||
10 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU
|
||||
C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I
|
||||
C AND HPI=PI/2
|
||||
C-----------------------------------------------------------------------
|
||||
CALL ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM)
|
||||
20 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,19 @@
|
|||
SUBROUTINE ZDIV(AR, AI, BR, BI, CR, CI)
|
||||
C***BEGIN PROLOGUE ZDIV
|
||||
C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
|
||||
C
|
||||
C DOUBLE PRECISION COMPLEX DIVIDE C=A/B.
|
||||
C
|
||||
C***ROUTINES CALLED ZABS
|
||||
C***END PROLOGUE ZDIV
|
||||
DOUBLE PRECISION AR, AI, BR, BI, CR, CI, BM, CA, CB, CC, CD
|
||||
DOUBLE PRECISION ZABS
|
||||
BM = 1.0D0/ZABS(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
|
||||
|
|
@ -0,0 +1,16 @@
|
|||
SUBROUTINE ZEXP(AR, AI, BR, BI)
|
||||
C***BEGIN PROLOGUE ZEXP
|
||||
C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
|
||||
C
|
||||
C DOUBLE PRECISION COMPLEX EXPONENTIAL FUNCTION B=EXP(A)
|
||||
C
|
||||
C***ROUTINES CALLED (NONE)
|
||||
C***END PROLOGUE ZEXP
|
||||
DOUBLE PRECISION AR, AI, BR, BI, ZM, CA, CB
|
||||
ZM = DEXP(AR)
|
||||
CA = ZM*DCOS(AI)
|
||||
CB = ZM*DSIN(AI)
|
||||
BR = CA
|
||||
BI = CB
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,121 @@
|
|||
SUBROUTINE ZKSCL(ZRR,ZRI,FNU,N,YR,YI,NZ,RZR,RZI,ASCLE,TOL,ELIM)
|
||||
C***BEGIN PROLOGUE ZKSCL
|
||||
C***REFER TO ZBESK
|
||||
C
|
||||
C SET K FUNCTIONS TO ZERO ON UNDERFLOW, CONTINUE RECURRENCE
|
||||
C ON SCALED FUNCTIONS UNTIL TWO MEMBERS COME ON SCALE, THEN
|
||||
C RETURN WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL.
|
||||
C
|
||||
C***ROUTINES CALLED ZUCHK,ZABS,ZLOG
|
||||
C***END PROLOGUE ZKSCL
|
||||
C COMPLEX CK,CS,CY,CZERO,RZ,S1,S2,Y,ZR,ZD,CELM
|
||||
DOUBLE PRECISION ACS, AS, ASCLE, CKI, CKR, CSI, CSR, CYI,
|
||||
* CYR, ELIM, FN, FNU, RZI, RZR, STR, S1I, S1R, S2I,
|
||||
* S2R, TOL, YI, YR, ZEROI, ZEROR, ZRI, ZRR, ZABS,
|
||||
* ZDR, ZDI, CELMR, ELM, HELIM, ALAS
|
||||
INTEGER I, IC, IDUM, KK, N, NN, NW, NZ
|
||||
DIMENSION YR(N), YI(N), CYR(2), CYI(2)
|
||||
DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 /
|
||||
C
|
||||
NZ = 0
|
||||
IC = 0
|
||||
NN = MIN0(2,N)
|
||||
DO 10 I=1,NN
|
||||
S1R = YR(I)
|
||||
S1I = YI(I)
|
||||
CYR(I) = S1R
|
||||
CYI(I) = S1I
|
||||
AS = ZABS(S1R,S1I)
|
||||
ACS = -ZRR + DLOG(AS)
|
||||
NZ = NZ + 1
|
||||
YR(I) = ZEROR
|
||||
YI(I) = ZEROI
|
||||
IF (ACS.LT.(-ELIM)) GO TO 10
|
||||
CALL ZLOG(S1R, S1I, CSR, CSI, IDUM)
|
||||
CSR = CSR - ZRR
|
||||
CSI = CSI - ZRI
|
||||
STR = DEXP(CSR)/TOL
|
||||
CSR = STR*DCOS(CSI)
|
||||
CSI = STR*DSIN(CSI)
|
||||
CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL)
|
||||
IF (NW.NE.0) GO TO 10
|
||||
YR(I) = CSR
|
||||
YI(I) = CSI
|
||||
IC = I
|
||||
NZ = NZ - 1
|
||||
10 CONTINUE
|
||||
IF (N.EQ.1) RETURN
|
||||
IF (IC.GT.1) GO TO 20
|
||||
YR(1) = ZEROR
|
||||
YI(1) = ZEROI
|
||||
NZ = 2
|
||||
20 CONTINUE
|
||||
IF (N.EQ.2) RETURN
|
||||
IF (NZ.EQ.0) RETURN
|
||||
FN = FNU + 1.0D0
|
||||
CKR = FN*RZR
|
||||
CKI = FN*RZI
|
||||
S1R = CYR(1)
|
||||
S1I = CYI(1)
|
||||
S2R = CYR(2)
|
||||
S2I = CYI(2)
|
||||
HELIM = 0.5D0*ELIM
|
||||
ELM = DEXP(-ELIM)
|
||||
CELMR = ELM
|
||||
ZDR = ZRR
|
||||
ZDI = ZRI
|
||||
C
|
||||
C FIND TWO CONSECUTIVE Y VALUES ON SCALE. SCALE RECURRENCE IF
|
||||
C S2 GETS LARGER THAN EXP(ELIM/2)
|
||||
C
|
||||
DO 30 I=3,N
|
||||
KK = I
|
||||
CSR = S2R
|
||||
CSI = S2I
|
||||
S2R = CKR*CSR - CKI*CSI + S1R
|
||||
S2I = CKI*CSR + CKR*CSI + S1I
|
||||
S1R = CSR
|
||||
S1I = CSI
|
||||
CKR = CKR + RZR
|
||||
CKI = CKI + RZI
|
||||
AS = ZABS(S2R,S2I)
|
||||
ALAS = DLOG(AS)
|
||||
ACS = -ZDR + ALAS
|
||||
NZ = NZ + 1
|
||||
YR(I) = ZEROR
|
||||
YI(I) = ZEROI
|
||||
IF (ACS.LT.(-ELIM)) GO TO 25
|
||||
CALL ZLOG(S2R, S2I, CSR, CSI, IDUM)
|
||||
CSR = CSR - ZDR
|
||||
CSI = CSI - ZDI
|
||||
STR = DEXP(CSR)/TOL
|
||||
CSR = STR*DCOS(CSI)
|
||||
CSI = STR*DSIN(CSI)
|
||||
CALL ZUCHK(CSR, CSI, NW, ASCLE, TOL)
|
||||
IF (NW.NE.0) GO TO 25
|
||||
YR(I) = CSR
|
||||
YI(I) = CSI
|
||||
NZ = NZ - 1
|
||||
IF (IC.EQ.KK-1) GO TO 40
|
||||
IC = KK
|
||||
GO TO 30
|
||||
25 CONTINUE
|
||||
IF(ALAS.LT.HELIM) GO TO 30
|
||||
ZDR = ZDR - ELIM
|
||||
S1R = S1R*CELMR
|
||||
S1I = S1I*CELMR
|
||||
S2R = S2R*CELMR
|
||||
S2I = S2I*CELMR
|
||||
30 CONTINUE
|
||||
NZ = N
|
||||
IF(IC.EQ.N) NZ=N-1
|
||||
GO TO 45
|
||||
40 CONTINUE
|
||||
NZ = KK - 2
|
||||
45 CONTINUE
|
||||
DO 50 I=1,NZ
|
||||
YR(I) = ZEROR
|
||||
YI(I) = ZEROI
|
||||
50 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,41 @@
|
|||
SUBROUTINE ZLOG(AR, AI, BR, BI, IERR)
|
||||
C***BEGIN PROLOGUE ZLOG
|
||||
C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
|
||||
C
|
||||
C DOUBLE PRECISION COMPLEX LOGARITHM B=CLOG(A)
|
||||
C IERR=0,NORMAL RETURN IERR=1, Z=CMPLX(0.0,0.0)
|
||||
C***ROUTINES CALLED ZABS
|
||||
C***END PROLOGUE ZLOG
|
||||
DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DHPI
|
||||
DOUBLE PRECISION ZABS
|
||||
DATA DPI , DHPI / 3.141592653589793238462643383D+0,
|
||||
1 1.570796326794896619231321696D+0/
|
||||
C
|
||||
IERR=0
|
||||
IF (AR.EQ.0.0D+0) GO TO 10
|
||||
IF (AI.EQ.0.0D+0) GO TO 20
|
||||
DTHETA = DATAN(AI/AR)
|
||||
IF (DTHETA.LE.0.0D+0) GO TO 40
|
||||
IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI
|
||||
GO TO 50
|
||||
10 IF (AI.EQ.0.0D+0) GO TO 60
|
||||
BI = DHPI
|
||||
BR = DLOG(DABS(AI))
|
||||
IF (AI.LT.0.0D+0) BI = -BI
|
||||
RETURN
|
||||
20 IF (AR.GT.0.0D+0) GO TO 30
|
||||
BR = DLOG(DABS(AR))
|
||||
BI = DPI
|
||||
RETURN
|
||||
30 BR = DLOG(AR)
|
||||
BI = 0.0D+0
|
||||
RETURN
|
||||
40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI
|
||||
50 ZM = ZABS(AR,AI)
|
||||
BR = DLOG(ZM)
|
||||
BI = DTHETA
|
||||
RETURN
|
||||
60 CONTINUE
|
||||
IERR=1
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,204 @@
|
|||
SUBROUTINE ZMLRI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL)
|
||||
C***BEGIN PROLOGUE ZMLRI
|
||||
C***REFER TO ZBESI,ZBESK
|
||||
C
|
||||
C ZMLRI COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY THE
|
||||
C MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES.
|
||||
C
|
||||
C***ROUTINES CALLED DGAMLN,D1MACH,ZABS,ZEXP,ZLOG,ZMLT
|
||||
C***END PROLOGUE ZMLRI
|
||||
C COMPLEX CK,CNORM,CONE,CTWO,CZERO,PT,P1,P2,RZ,SUM,Y,Z
|
||||
DOUBLE PRECISION ACK, AK, AP, AT, AZ, BK, CKI, CKR, CNORMI,
|
||||
* CNORMR, CONEI, CONER, FKAP, FKK, FLAM, FNF, FNU, PTI, PTR, P1I,
|
||||
* P1R, P2I, P2R, RAZ, RHO, RHO2, RZI, RZR, SCLE, STI, STR, SUMI,
|
||||
* SUMR, TFNF, TOL, TST, YI, YR, ZEROI, ZEROR, ZI, ZR, DGAMLN,
|
||||
* D1MACH, ZABS
|
||||
INTEGER I, IAZ, IDUM, IFNU, INU, ITIME, K, KK, KM, KODE, M, N, NZ
|
||||
DIMENSION YR(N), YI(N)
|
||||
DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
|
||||
SCLE = D1MACH(1)/TOL
|
||||
NZ=0
|
||||
AZ = ZABS(ZR,ZI)
|
||||
IAZ = INT(SNGL(AZ))
|
||||
IFNU = INT(SNGL(FNU))
|
||||
INU = IFNU + N - 1
|
||||
AT = DBLE(FLOAT(IAZ)) + 1.0D0
|
||||
RAZ = 1.0D0/AZ
|
||||
STR = ZR*RAZ
|
||||
STI = -ZI*RAZ
|
||||
CKR = STR*AT*RAZ
|
||||
CKI = STI*AT*RAZ
|
||||
RZR = (STR+STR)*RAZ
|
||||
RZI = (STI+STI)*RAZ
|
||||
P1R = ZEROR
|
||||
P1I = ZEROI
|
||||
P2R = CONER
|
||||
P2I = CONEI
|
||||
ACK = (AT+1.0D0)*RAZ
|
||||
RHO = ACK + DSQRT(ACK*ACK-1.0D0)
|
||||
RHO2 = RHO*RHO
|
||||
TST = (RHO2+RHO2)/((RHO2-1.0D0)*(RHO-1.0D0))
|
||||
TST = TST/TOL
|
||||
C-----------------------------------------------------------------------
|
||||
C COMPUTE RELATIVE TRUNCATION ERROR INDEX FOR SERIES
|
||||
C-----------------------------------------------------------------------
|
||||
AK = AT
|
||||
DO 10 I=1,80
|
||||
PTR = P2R
|
||||
PTI = P2I
|
||||
P2R = P1R - (CKR*PTR-CKI*PTI)
|
||||
P2I = P1I - (CKI*PTR+CKR*PTI)
|
||||
P1R = PTR
|
||||
P1I = PTI
|
||||
CKR = CKR + RZR
|
||||
CKI = CKI + RZI
|
||||
AP = ZABS(P2R,P2I)
|
||||
IF (AP.GT.TST*AK*AK) GO TO 20
|
||||
AK = AK + 1.0D0
|
||||
10 CONTINUE
|
||||
GO TO 110
|
||||
20 CONTINUE
|
||||
I = I + 1
|
||||
K = 0
|
||||
IF (INU.LT.IAZ) GO TO 40
|
||||
C-----------------------------------------------------------------------
|
||||
C COMPUTE RELATIVE TRUNCATION ERROR FOR RATIOS
|
||||
C-----------------------------------------------------------------------
|
||||
P1R = ZEROR
|
||||
P1I = ZEROI
|
||||
P2R = CONER
|
||||
P2I = CONEI
|
||||
AT = DBLE(FLOAT(INU)) + 1.0D0
|
||||
STR = ZR*RAZ
|
||||
STI = -ZI*RAZ
|
||||
CKR = STR*AT*RAZ
|
||||
CKI = STI*AT*RAZ
|
||||
ACK = AT*RAZ
|
||||
TST = DSQRT(ACK/TOL)
|
||||
ITIME = 1
|
||||
DO 30 K=1,80
|
||||
PTR = P2R
|
||||
PTI = P2I
|
||||
P2R = P1R - (CKR*PTR-CKI*PTI)
|
||||
P2I = P1I - (CKR*PTI+CKI*PTR)
|
||||
P1R = PTR
|
||||
P1I = PTI
|
||||
CKR = CKR + RZR
|
||||
CKI = CKI + RZI
|
||||
AP = ZABS(P2R,P2I)
|
||||
IF (AP.LT.TST) GO TO 30
|
||||
IF (ITIME.EQ.2) GO TO 40
|
||||
ACK = ZABS(CKR,CKI)
|
||||
FLAM = ACK + DSQRT(ACK*ACK-1.0D0)
|
||||
FKAP = AP/ZABS(P1R,P1I)
|
||||
RHO = DMIN1(FLAM,FKAP)
|
||||
TST = TST*DSQRT(RHO/(RHO*RHO-1.0D0))
|
||||
ITIME = 2
|
||||
30 CONTINUE
|
||||
GO TO 110
|
||||
40 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C BACKWARD RECURRENCE AND SUM NORMALIZING RELATION
|
||||
C-----------------------------------------------------------------------
|
||||
K = K + 1
|
||||
KK = MAX0(I+IAZ,K+INU)
|
||||
FKK = DBLE(FLOAT(KK))
|
||||
P1R = ZEROR
|
||||
P1I = ZEROI
|
||||
C-----------------------------------------------------------------------
|
||||
C SCALE P2 AND SUM BY SCLE
|
||||
C-----------------------------------------------------------------------
|
||||
P2R = SCLE
|
||||
P2I = ZEROI
|
||||
FNF = FNU - DBLE(FLOAT(IFNU))
|
||||
TFNF = FNF + FNF
|
||||
BK = DGAMLN(FKK+TFNF+1.0D0,IDUM) - DGAMLN(FKK+1.0D0,IDUM) -
|
||||
* DGAMLN(TFNF+1.0D0,IDUM)
|
||||
BK = DEXP(BK)
|
||||
SUMR = ZEROR
|
||||
SUMI = ZEROI
|
||||
KM = KK - INU
|
||||
DO 50 I=1,KM
|
||||
PTR = P2R
|
||||
PTI = P2I
|
||||
P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI)
|
||||
P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI)
|
||||
P1R = PTR
|
||||
P1I = PTI
|
||||
AK = 1.0D0 - TFNF/(FKK+TFNF)
|
||||
ACK = BK*AK
|
||||
SUMR = SUMR + (ACK+BK)*P1R
|
||||
SUMI = SUMI + (ACK+BK)*P1I
|
||||
BK = ACK
|
||||
FKK = FKK - 1.0D0
|
||||
50 CONTINUE
|
||||
YR(N) = P2R
|
||||
YI(N) = P2I
|
||||
IF (N.EQ.1) GO TO 70
|
||||
DO 60 I=2,N
|
||||
PTR = P2R
|
||||
PTI = P2I
|
||||
P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI)
|
||||
P2I = P1I + (FKK+FNF)*(RZI*PTR+RZR*PTI)
|
||||
P1R = PTR
|
||||
P1I = PTI
|
||||
AK = 1.0D0 - TFNF/(FKK+TFNF)
|
||||
ACK = BK*AK
|
||||
SUMR = SUMR + (ACK+BK)*P1R
|
||||
SUMI = SUMI + (ACK+BK)*P1I
|
||||
BK = ACK
|
||||
FKK = FKK - 1.0D0
|
||||
M = N - I + 1
|
||||
YR(M) = P2R
|
||||
YI(M) = P2I
|
||||
60 CONTINUE
|
||||
70 CONTINUE
|
||||
IF (IFNU.LE.0) GO TO 90
|
||||
DO 80 I=1,IFNU
|
||||
PTR = P2R
|
||||
PTI = P2I
|
||||
P2R = P1R + (FKK+FNF)*(RZR*PTR-RZI*PTI)
|
||||
P2I = P1I + (FKK+FNF)*(RZR*PTI+RZI*PTR)
|
||||
P1R = PTR
|
||||
P1I = PTI
|
||||
AK = 1.0D0 - TFNF/(FKK+TFNF)
|
||||
ACK = BK*AK
|
||||
SUMR = SUMR + (ACK+BK)*P1R
|
||||
SUMI = SUMI + (ACK+BK)*P1I
|
||||
BK = ACK
|
||||
FKK = FKK - 1.0D0
|
||||
80 CONTINUE
|
||||
90 CONTINUE
|
||||
PTR = ZR
|
||||
PTI = ZI
|
||||
IF (KODE.EQ.2) PTR = ZEROR
|
||||
CALL ZLOG(RZR, RZI, STR, STI, IDUM)
|
||||
P1R = -FNF*STR + PTR
|
||||
P1I = -FNF*STI + PTI
|
||||
AP = DGAMLN(1.0D0+FNF,IDUM)
|
||||
PTR = P1R - AP
|
||||
PTI = P1I
|
||||
C-----------------------------------------------------------------------
|
||||
C THE DIVISION CEXP(PT)/(SUM+P2) IS ALTERED TO AVOID OVERFLOW
|
||||
C IN THE DENOMINATOR BY SQUARING LARGE QUANTITIES
|
||||
C-----------------------------------------------------------------------
|
||||
P2R = P2R + SUMR
|
||||
P2I = P2I + SUMI
|
||||
AP = ZABS(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
|
||||
|
|
@ -0,0 +1,15 @@
|
|||
SUBROUTINE ZMLT(AR, AI, BR, BI, CR, CI)
|
||||
C***BEGIN PROLOGUE ZMLT
|
||||
C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
|
||||
C
|
||||
C DOUBLE PRECISION COMPLEX MULTIPLY, C=A*B.
|
||||
C
|
||||
C***ROUTINES CALLED (NONE)
|
||||
C***END PROLOGUE ZMLT
|
||||
DOUBLE PRECISION AR, AI, BR, BI, CR, CI, CA, CB
|
||||
CA = AR*BR - AI*BI
|
||||
CB = AR*BI + AI*BR
|
||||
CR = CA
|
||||
CI = CB
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,132 @@
|
|||
SUBROUTINE ZRATI(ZR, ZI, FNU, N, CYR, CYI, TOL)
|
||||
C***BEGIN PROLOGUE ZRATI
|
||||
C***REFER TO ZBESI,ZBESK,ZBESH
|
||||
C
|
||||
C ZRATI COMPUTES RATIOS OF I BESSEL FUNCTIONS BY BACKWARD
|
||||
C RECURRENCE. THE STARTING INDEX IS DETERMINED BY FORWARD
|
||||
C RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B,
|
||||
C MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973,
|
||||
C BESSEL FUNCTIONS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER,
|
||||
C BY D. J. SOOKNE.
|
||||
C
|
||||
C***ROUTINES CALLED ZABS,ZDIV
|
||||
C***END PROLOGUE ZRATI
|
||||
C COMPLEX Z,CY(1),CONE,CZERO,P1,P2,T1,RZ,PT,CDFNU
|
||||
DOUBLE PRECISION AK, AMAGZ, AP1, AP2, ARG, AZ, CDFNUI, CDFNUR,
|
||||
* CONEI, CONER, CYI, CYR, CZEROI, CZEROR, DFNU, FDNU, FLAM, FNU,
|
||||
* FNUP, PTI, PTR, P1I, P1R, P2I, P2R, RAK, RAP1, RHO, RT2, RZI,
|
||||
* RZR, TEST, TEST1, TOL, TTI, TTR, T1I, T1R, ZI, ZR, ZABS
|
||||
INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ, N
|
||||
DIMENSION CYR(N), CYI(N)
|
||||
DATA CZEROR,CZEROI,CONER,CONEI,RT2/
|
||||
1 0.0D0, 0.0D0, 1.0D0, 0.0D0, 1.41421356237309505D0 /
|
||||
AZ = ZABS(ZR,ZI)
|
||||
INU = INT(SNGL(FNU))
|
||||
IDNU = INU + N - 1
|
||||
MAGZ = INT(SNGL(AZ))
|
||||
AMAGZ = DBLE(FLOAT(MAGZ+1))
|
||||
FDNU = DBLE(FLOAT(IDNU))
|
||||
FNUP = DMAX1(AMAGZ,FDNU)
|
||||
ID = IDNU - MAGZ - 1
|
||||
ITIME = 1
|
||||
K = 1
|
||||
PTR = 1.0D0/AZ
|
||||
RZR = PTR*(ZR+ZR)*PTR
|
||||
RZI = -PTR*(ZI+ZI)*PTR
|
||||
T1R = RZR*FNUP
|
||||
T1I = RZI*FNUP
|
||||
P2R = -T1R
|
||||
P2I = -T1I
|
||||
P1R = CONER
|
||||
P1I = CONEI
|
||||
T1R = T1R + RZR
|
||||
T1I = T1I + RZI
|
||||
IF (ID.GT.0) ID = 0
|
||||
AP2 = ZABS(P2R,P2I)
|
||||
AP1 = ZABS(P1R,P1I)
|
||||
C-----------------------------------------------------------------------
|
||||
C THE OVERFLOW TEST ON K(FNU+I-1,Z) BEFORE THE CALL TO CBKNU
|
||||
C GUARANTEES THAT P2 IS ON SCALE. SCALE TEST1 AND ALL SUBSEQUENT
|
||||
C P2 VALUES BY AP1 TO ENSURE THAT AN OVERFLOW DOES NOT OCCUR
|
||||
C PREMATURELY.
|
||||
C-----------------------------------------------------------------------
|
||||
ARG = (AP2+AP2)/(AP1*TOL)
|
||||
TEST1 = DSQRT(ARG)
|
||||
TEST = TEST1
|
||||
RAP1 = 1.0D0/AP1
|
||||
P1R = P1R*RAP1
|
||||
P1I = P1I*RAP1
|
||||
P2R = P2R*RAP1
|
||||
P2I = P2I*RAP1
|
||||
AP2 = AP2*RAP1
|
||||
10 CONTINUE
|
||||
K = K + 1
|
||||
AP1 = AP2
|
||||
PTR = P2R
|
||||
PTI = P2I
|
||||
P2R = P1R - (T1R*PTR-T1I*PTI)
|
||||
P2I = P1I - (T1R*PTI+T1I*PTR)
|
||||
P1R = PTR
|
||||
P1I = PTI
|
||||
T1R = T1R + RZR
|
||||
T1I = T1I + RZI
|
||||
AP2 = ZABS(P2R,P2I)
|
||||
IF (AP1.LE.TEST) GO TO 10
|
||||
IF (ITIME.EQ.2) GO TO 20
|
||||
AK = ZABS(T1R,T1I)*0.5D0
|
||||
FLAM = AK + DSQRT(AK*AK-1.0D0)
|
||||
RHO = DMIN1(AP2/AP1,FLAM)
|
||||
TEST = TEST1*DSQRT(RHO/(RHO*RHO-1.0D0))
|
||||
ITIME = 2
|
||||
GO TO 10
|
||||
20 CONTINUE
|
||||
KK = K + 1 - ID
|
||||
AK = DBLE(FLOAT(KK))
|
||||
T1R = AK
|
||||
T1I = CZEROI
|
||||
DFNU = FNU + DBLE(FLOAT(N-1))
|
||||
P1R = 1.0D0/AP2
|
||||
P1I = CZEROI
|
||||
P2R = CZEROR
|
||||
P2I = CZEROI
|
||||
DO 30 I=1,KK
|
||||
PTR = P1R
|
||||
PTI = P1I
|
||||
RAP1 = DFNU + T1R
|
||||
TTR = RZR*RAP1
|
||||
TTI = RZI*RAP1
|
||||
P1R = (PTR*TTR-PTI*TTI) + P2R
|
||||
P1I = (PTR*TTI+PTI*TTR) + P2I
|
||||
P2R = PTR
|
||||
P2I = PTI
|
||||
T1R = T1R - CONER
|
||||
30 CONTINUE
|
||||
IF (P1R.NE.CZEROR .OR. P1I.NE.CZEROI) GO TO 40
|
||||
P1R = TOL
|
||||
P1I = TOL
|
||||
40 CONTINUE
|
||||
CALL ZDIV(P2R, P2I, P1R, P1I, CYR(N), CYI(N))
|
||||
IF (N.EQ.1) RETURN
|
||||
K = N - 1
|
||||
AK = DBLE(FLOAT(K))
|
||||
T1R = AK
|
||||
T1I = CZEROI
|
||||
CDFNUR = FNU*RZR
|
||||
CDFNUI = FNU*RZI
|
||||
DO 60 I=2,N
|
||||
PTR = CDFNUR + (T1R*RZR-T1I*RZI) + CYR(K+1)
|
||||
PTI = CDFNUI + (T1R*RZI+T1I*RZR) + CYI(K+1)
|
||||
AK = ZABS(PTR,PTI)
|
||||
IF (AK.NE.CZEROR) GO TO 50
|
||||
PTR = TOL
|
||||
PTI = TOL
|
||||
AK = TOL*RT2
|
||||
50 CONTINUE
|
||||
RAK = CONER/AK
|
||||
CYR(K) = RAK*PTR*RAK
|
||||
CYI(K) = -RAK*PTI*RAK
|
||||
T1R = T1R - CONER
|
||||
K = K - 1
|
||||
60 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,49 @@
|
|||
SUBROUTINE ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NZ, ASCLE, ALIM,
|
||||
* IUF)
|
||||
C***BEGIN PROLOGUE ZS1S2
|
||||
C***REFER TO ZBESK,ZAIRY
|
||||
C
|
||||
C ZS1S2 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE
|
||||
C ADDITION OF THE I AND K FUNCTIONS IN THE ANALYTIC CON-
|
||||
C TINUATION FORMULA WHERE S1=K FUNCTION AND S2=I FUNCTION.
|
||||
C ON KODE=1 THE I AND K FUNCTIONS ARE DIFFERENT ORDERS OF
|
||||
C MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER
|
||||
C OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE
|
||||
C PRECISION ABOVE THE UNDERFLOW LIMIT.
|
||||
C
|
||||
C***ROUTINES CALLED ZABS,ZEXP,ZLOG
|
||||
C***END PROLOGUE ZS1S2
|
||||
C COMPLEX CZERO,C1,S1,S1D,S2,ZR
|
||||
DOUBLE PRECISION AA, ALIM, ALN, ASCLE, AS1, AS2, C1I, C1R, S1DI,
|
||||
* S1DR, S1I, S1R, S2I, S2R, ZEROI, ZEROR, ZRI, ZRR, ZABS
|
||||
INTEGER IUF, IDUM, NZ
|
||||
DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 /
|
||||
NZ = 0
|
||||
AS1 = ZABS(S1R,S1I)
|
||||
AS2 = ZABS(S2R,S2I)
|
||||
IF (S1R.EQ.0.0D0 .AND. S1I.EQ.0.0D0) GO TO 10
|
||||
IF (AS1.EQ.0.0D0) GO TO 10
|
||||
ALN = -ZRR - ZRR + DLOG(AS1)
|
||||
S1DR = S1R
|
||||
S1DI = S1I
|
||||
S1R = ZEROR
|
||||
S1I = ZEROI
|
||||
AS1 = ZEROR
|
||||
IF (ALN.LT.(-ALIM)) GO TO 10
|
||||
CALL ZLOG(S1DR, S1DI, C1R, C1I, IDUM)
|
||||
C1R = C1R - ZRR - ZRR
|
||||
C1I = C1I - ZRI - ZRI
|
||||
CALL ZEXP(C1R, C1I, S1R, S1I)
|
||||
AS1 = ZABS(S1R,S1I)
|
||||
IUF = IUF + 1
|
||||
10 CONTINUE
|
||||
AA = DMAX1(AS1,AS2)
|
||||
IF (AA.GT.ASCLE) RETURN
|
||||
S1R = ZEROR
|
||||
S1I = ZEROI
|
||||
S2R = ZEROR
|
||||
S2I = ZEROI
|
||||
NZ = 1
|
||||
IUF = 0
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,190 @@
|
|||
SUBROUTINE ZSERI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM,
|
||||
* ALIM)
|
||||
C***BEGIN PROLOGUE ZSERI
|
||||
C***REFER TO ZBESI,ZBESK
|
||||
C
|
||||
C ZSERI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY
|
||||
C MEANS OF THE POWER SERIES FOR LARGE CABS(Z) IN THE
|
||||
C REGION CABS(Z).LE.2*SQRT(FNU+1). NZ=0 IS A NORMAL RETURN.
|
||||
C NZ.GT.0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO
|
||||
C DUE TO UNDERFLOW. NZ.LT.0 MEANS UNDERFLOW OCCURRED, BUT THE
|
||||
C CONDITION CABS(Z).LE.2*SQRT(FNU+1) WAS VIOLATED AND THE
|
||||
C COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ).
|
||||
C
|
||||
C***ROUTINES CALLED DGAMLN,D1MACH,ZUCHK,ZABS,ZDIV,ZLOG,ZMLT
|
||||
C***END PROLOGUE ZSERI
|
||||
C COMPLEX AK1,CK,COEF,CONE,CRSC,CSCL,CZ,CZERO,HZ,RZ,S1,S2,Y,Z
|
||||
DOUBLE PRECISION AA, ACZ, AK, AK1I, AK1R, ALIM, ARM, ASCLE, ATOL,
|
||||
* AZ, CKI, CKR, COEFI, COEFR, CONEI, CONER, CRSCR, CZI, CZR, DFNU,
|
||||
* ELIM, FNU, FNUP, HZI, HZR, RAZ, RS, RTR1, RZI, RZR, S, SS, STI,
|
||||
* STR, S1I, S1R, S2I, S2R, TOL, YI, YR, WI, WR, ZEROI, ZEROR, ZI,
|
||||
* ZR, DGAMLN, D1MACH, ZABS
|
||||
INTEGER I, IB, IDUM, IFLAG, IL, K, KODE, L, M, N, NN, NZ, NW
|
||||
DIMENSION YR(N), YI(N), WR(2), WI(2)
|
||||
DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
|
||||
C
|
||||
NZ = 0
|
||||
AZ = ZABS(ZR,ZI)
|
||||
IF (AZ.EQ.0.0D0) GO TO 160
|
||||
ARM = 1.0D+3*D1MACH(1)
|
||||
RTR1 = DSQRT(ARM)
|
||||
CRSCR = 1.0D0
|
||||
IFLAG = 0
|
||||
IF (AZ.LT.ARM) GO TO 150
|
||||
HZR = 0.5D0*ZR
|
||||
HZI = 0.5D0*ZI
|
||||
CZR = ZEROR
|
||||
CZI = ZEROI
|
||||
IF (AZ.LE.RTR1) GO TO 10
|
||||
CALL ZMLT(HZR, HZI, HZR, HZI, CZR, CZI)
|
||||
10 CONTINUE
|
||||
ACZ = ZABS(CZR,CZI)
|
||||
NN = N
|
||||
CALL ZLOG(HZR, HZI, CKR, CKI, IDUM)
|
||||
20 CONTINUE
|
||||
DFNU = FNU + DBLE(FLOAT(NN-1))
|
||||
FNUP = DFNU + 1.0D0
|
||||
C-----------------------------------------------------------------------
|
||||
C UNDERFLOW TEST
|
||||
C-----------------------------------------------------------------------
|
||||
AK1R = CKR*DFNU
|
||||
AK1I = CKI*DFNU
|
||||
AK = DGAMLN(FNUP,IDUM)
|
||||
AK1R = AK1R - AK
|
||||
IF (KODE.EQ.2) AK1R = AK1R - ZR
|
||||
IF (AK1R.GT.(-ELIM)) GO TO 40
|
||||
30 CONTINUE
|
||||
NZ = NZ + 1
|
||||
YR(NN) = ZEROR
|
||||
YI(NN) = ZEROI
|
||||
IF (ACZ.GT.DFNU) GO TO 190
|
||||
NN = NN - 1
|
||||
IF (NN.EQ.0) RETURN
|
||||
GO TO 20
|
||||
40 CONTINUE
|
||||
IF (AK1R.GT.(-ALIM)) GO TO 50
|
||||
IFLAG = 1
|
||||
SS = 1.0D0/TOL
|
||||
CRSCR = TOL
|
||||
ASCLE = ARM*SS
|
||||
50 CONTINUE
|
||||
AA = DEXP(AK1R)
|
||||
IF (IFLAG.EQ.1) AA = AA*SS
|
||||
COEFR = AA*DCOS(AK1I)
|
||||
COEFI = AA*DSIN(AK1I)
|
||||
ATOL = TOL*ACZ/FNUP
|
||||
IL = MIN0(2,NN)
|
||||
DO 90 I=1,IL
|
||||
DFNU = FNU + DBLE(FLOAT(NN-I))
|
||||
FNUP = DFNU + 1.0D0
|
||||
S1R = CONER
|
||||
S1I = CONEI
|
||||
IF (ACZ.LT.TOL*FNUP) GO TO 70
|
||||
AK1R = CONER
|
||||
AK1I = CONEI
|
||||
AK = FNUP + 2.0D0
|
||||
S = FNUP
|
||||
AA = 2.0D0
|
||||
60 CONTINUE
|
||||
RS = 1.0D0/S
|
||||
STR = AK1R*CZR - AK1I*CZI
|
||||
STI = AK1R*CZI + AK1I*CZR
|
||||
AK1R = STR*RS
|
||||
AK1I = STI*RS
|
||||
S1R = S1R + AK1R
|
||||
S1I = S1I + AK1I
|
||||
S = S + AK
|
||||
AK = AK + 2.0D0
|
||||
AA = AA*ACZ*RS
|
||||
IF (AA.GT.ATOL) GO TO 60
|
||||
70 CONTINUE
|
||||
S2R = S1R*COEFR - S1I*COEFI
|
||||
S2I = S1R*COEFI + S1I*COEFR
|
||||
WR(I) = S2R
|
||||
WI(I) = S2I
|
||||
IF (IFLAG.EQ.0) GO TO 80
|
||||
CALL ZUCHK(S2R, S2I, NW, ASCLE, TOL)
|
||||
IF (NW.NE.0) GO TO 30
|
||||
80 CONTINUE
|
||||
M = NN - I + 1
|
||||
YR(M) = S2R*CRSCR
|
||||
YI(M) = S2I*CRSCR
|
||||
IF (I.EQ.IL) GO TO 90
|
||||
CALL ZDIV(COEFR, COEFI, HZR, HZI, STR, STI)
|
||||
COEFR = STR*DFNU
|
||||
COEFI = STI*DFNU
|
||||
90 CONTINUE
|
||||
IF (NN.LE.2) RETURN
|
||||
K = NN - 2
|
||||
AK = DBLE(FLOAT(K))
|
||||
RAZ = 1.0D0/AZ
|
||||
STR = ZR*RAZ
|
||||
STI = -ZI*RAZ
|
||||
RZR = (STR+STR)*RAZ
|
||||
RZI = (STI+STI)*RAZ
|
||||
IF (IFLAG.EQ.1) GO TO 120
|
||||
IB = 3
|
||||
100 CONTINUE
|
||||
DO 110 I=IB,NN
|
||||
YR(K) = (AK+FNU)*(RZR*YR(K+1)-RZI*YI(K+1)) + YR(K+2)
|
||||
YI(K) = (AK+FNU)*(RZR*YI(K+1)+RZI*YR(K+1)) + YI(K+2)
|
||||
AK = AK - 1.0D0
|
||||
K = K - 1
|
||||
110 CONTINUE
|
||||
RETURN
|
||||
C-----------------------------------------------------------------------
|
||||
C RECUR BACKWARD WITH SCALED VALUES
|
||||
C-----------------------------------------------------------------------
|
||||
120 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION ABOVE THE
|
||||
C UNDERFLOW LIMIT = ASCLE = D1MACH(1)*SS*1.0D+3
|
||||
C-----------------------------------------------------------------------
|
||||
S1R = WR(1)
|
||||
S1I = WI(1)
|
||||
S2R = WR(2)
|
||||
S2I = WI(2)
|
||||
DO 130 L=3,NN
|
||||
CKR = S2R
|
||||
CKI = S2I
|
||||
S2R = S1R + (AK+FNU)*(RZR*CKR-RZI*CKI)
|
||||
S2I = S1I + (AK+FNU)*(RZR*CKI+RZI*CKR)
|
||||
S1R = CKR
|
||||
S1I = CKI
|
||||
CKR = S2R*CRSCR
|
||||
CKI = S2I*CRSCR
|
||||
YR(K) = CKR
|
||||
YI(K) = CKI
|
||||
AK = AK - 1.0D0
|
||||
K = K - 1
|
||||
IF (ZABS(CKR,CKI).GT.ASCLE) GO TO 140
|
||||
130 CONTINUE
|
||||
RETURN
|
||||
140 CONTINUE
|
||||
IB = L + 1
|
||||
IF (IB.GT.NN) RETURN
|
||||
GO TO 100
|
||||
150 CONTINUE
|
||||
NZ = N
|
||||
IF (FNU.EQ.0.0D0) NZ = NZ - 1
|
||||
160 CONTINUE
|
||||
YR(1) = ZEROR
|
||||
YI(1) = ZEROI
|
||||
IF (FNU.NE.0.0D0) GO TO 170
|
||||
YR(1) = CONER
|
||||
YI(1) = CONEI
|
||||
170 CONTINUE
|
||||
IF (N.EQ.1) RETURN
|
||||
DO 180 I=2,N
|
||||
YR(I) = ZEROR
|
||||
YI(I) = ZEROI
|
||||
180 CONTINUE
|
||||
RETURN
|
||||
C-----------------------------------------------------------------------
|
||||
C RETURN WITH NZ.LT.0 IF CABS(Z*Z/4).GT.FNU+N-NZ-1 COMPLETE
|
||||
C THE CALCULATION IN CBINU WITH N=N-IABS(NZ)
|
||||
C-----------------------------------------------------------------------
|
||||
190 CONTINUE
|
||||
NZ = -NZ
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,22 @@
|
|||
SUBROUTINE ZSHCH(ZR, ZI, CSHR, CSHI, CCHR, CCHI)
|
||||
C***BEGIN PROLOGUE ZSHCH
|
||||
C***REFER TO ZBESK,ZBESH
|
||||
C
|
||||
C ZSHCH COMPUTES THE COMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y)
|
||||
C AND CCH=COSH(X+I*Y), WHERE I**2=-1.
|
||||
C
|
||||
C***ROUTINES CALLED (NONE)
|
||||
C***END PROLOGUE ZSHCH
|
||||
C
|
||||
DOUBLE PRECISION CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, ZI, ZR,
|
||||
* DCOSH, DSINH
|
||||
SH = DSINH(ZR)
|
||||
CH = DCOSH(ZR)
|
||||
SN = DSIN(ZI)
|
||||
CN = DCOS(ZI)
|
||||
CSHR = SH*CN
|
||||
CSHI = CH*SN
|
||||
CCHR = CH*CN
|
||||
CCHI = SH*SN
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,44 @@
|
|||
SUBROUTINE ZSQRT(AR, AI, BR, BI)
|
||||
C***BEGIN PROLOGUE ZSQRT
|
||||
C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY
|
||||
C
|
||||
C DOUBLE PRECISION COMPLEX SQUARE ROOT, B=CSQRT(A)
|
||||
C
|
||||
C***ROUTINES CALLED ZABS
|
||||
C***END PROLOGUE ZSQRT
|
||||
DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DRT
|
||||
DOUBLE PRECISION ZABS
|
||||
DATA DRT , DPI / 7.071067811865475244008443621D-1,
|
||||
1 3.141592653589793238462643383D+0/
|
||||
ZM = ZABS(AR,AI)
|
||||
ZM = DSQRT(ZM)
|
||||
IF (AR.EQ.0.0D+0) GO TO 10
|
||||
IF (AI.EQ.0.0D+0) GO TO 20
|
||||
DTHETA = DATAN(AI/AR)
|
||||
IF (DTHETA.LE.0.0D+0) GO TO 40
|
||||
IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI
|
||||
GO TO 50
|
||||
10 IF (AI.GT.0.0D+0) GO TO 60
|
||||
IF (AI.LT.0.0D+0) GO TO 70
|
||||
BR = 0.0D+0
|
||||
BI = 0.0D+0
|
||||
RETURN
|
||||
20 IF (AR.GT.0.0D+0) GO TO 30
|
||||
BR = 0.0D+0
|
||||
BI = DSQRT(DABS(AR))
|
||||
RETURN
|
||||
30 BR = DSQRT(AR)
|
||||
BI = 0.0D+0
|
||||
RETURN
|
||||
40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI
|
||||
50 DTHETA = DTHETA*0.5D+0
|
||||
BR = ZM*DCOS(DTHETA)
|
||||
BI = ZM*DSIN(DTHETA)
|
||||
RETURN
|
||||
60 BR = ZM*DRT
|
||||
BI = ZM*DRT
|
||||
RETURN
|
||||
70 BR = ZM*DRT
|
||||
BI = -ZM*DRT
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,28 @@
|
|||
SUBROUTINE ZUCHK(YR, YI, NZ, ASCLE, TOL)
|
||||
C***BEGIN PROLOGUE ZUCHK
|
||||
C***REFER TO ZSERI,ZUOIK,ZUNK1,ZUNK2,ZUNI1,ZUNI2,ZKSCL
|
||||
C
|
||||
C Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN
|
||||
C EXP(-ALIM)=ASCLE=1.0E+3*D1MACH(1)/TOL. THE TEST IS MADE TO SEE
|
||||
C IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDERFLOW
|
||||
C WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED
|
||||
C IF THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE
|
||||
C OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE
|
||||
C ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED.
|
||||
C
|
||||
C***ROUTINES CALLED (NONE)
|
||||
C***END PROLOGUE ZUCHK
|
||||
C
|
||||
C COMPLEX Y
|
||||
DOUBLE PRECISION ASCLE, SS, ST, TOL, WR, WI, YR, YI
|
||||
INTEGER NZ
|
||||
NZ = 0
|
||||
WR = DABS(YR)
|
||||
WI = DABS(YI)
|
||||
ST = DMIN1(WR,WI)
|
||||
IF (ST.GT.ASCLE) RETURN
|
||||
SS = DMAX1(WR,WI)
|
||||
ST = ST/TOL
|
||||
IF (SS.LT.ST) NZ = 1
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,714 @@
|
|||
SUBROUTINE ZUNHJ(ZR, ZI, FNU, IPMTR, TOL, PHIR, PHII, ARGR, ARGI,
|
||||
* ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI)
|
||||
C***BEGIN PROLOGUE ZUNHJ
|
||||
C***REFER TO ZBESI,ZBESK
|
||||
C
|
||||
C REFERENCES
|
||||
C HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ AND I.A.
|
||||
C STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9.
|
||||
C
|
||||
C ASYMPTOTICS AND SPECIAL FUNCTIONS BY F.W.J. OLVER, ACADEMIC
|
||||
C PRESS, N.Y., 1974, PAGE 420
|
||||
C
|
||||
C ABSTRACT
|
||||
C ZUNHJ COMPUTES PARAMETERS FOR BESSEL FUNCTIONS C(FNU,Z) =
|
||||
C J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU
|
||||
C BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION
|
||||
C
|
||||
C C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) )
|
||||
C
|
||||
C FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS
|
||||
C AN AIRY FUNCTION AND DAIRY IS ITS DERIVATIVE.
|
||||
C
|
||||
C (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2,
|
||||
C
|
||||
C ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING
|
||||
C PURPOSES IN AIRY FUNCTIONS FROM CAIRY OR CBIRY.
|
||||
C
|
||||
C MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND
|
||||
C MUST BE SPECIFIED. IPMTR=0 RETURNS ALL PARAMETERS. IPMTR=
|
||||
C 1 COMPUTES ALL EXCEPT ASUM AND BSUM.
|
||||
C
|
||||
C***ROUTINES CALLED ZABS,ZDIV,ZLOG,ZSQRT,D1MACH
|
||||
C***END PROLOGUE ZUNHJ
|
||||
C COMPLEX ARG,ASUM,BSUM,CFNU,CONE,CR,CZERO,DR,P,PHI,PRZTH,PTFN,
|
||||
C *RFN13,RTZTA,RZTH,SUMA,SUMB,TFN,T2,UP,W,W2,Z,ZA,ZB,ZC,ZETA,ZETA1,
|
||||
C *ZETA2,ZTH
|
||||
DOUBLE PRECISION ALFA, ANG, AP, AR, ARGI, ARGR, ASUMI, ASUMR,
|
||||
* ATOL, AW2, AZTH, BETA, BR, BSUMI, BSUMR, BTOL, C, CONEI, CONER,
|
||||
* CRI, CRR, DRI, DRR, EX1, EX2, FNU, FN13, FN23, GAMA, GPI, HPI,
|
||||
* PHII, PHIR, PI, PP, PR, PRZTHI, PRZTHR, PTFNI, PTFNR, RAW, RAW2,
|
||||
* RAZTH, RFNU, RFNU2, RFN13, RTZTI, RTZTR, RZTHI, RZTHR, STI, STR,
|
||||
* SUMAI, SUMAR, SUMBI, SUMBR, TEST, TFNI, TFNR, THPI, TOL, TZAI,
|
||||
* TZAR, T2I, T2R, UPI, UPR, WI, WR, W2I, W2R, ZAI, ZAR, ZBI, ZBR,
|
||||
* ZCI, ZCR, ZEROI, ZEROR, ZETAI, ZETAR, ZETA1I, ZETA1R, ZETA2I,
|
||||
* ZETA2R, ZI, ZR, ZTHI, ZTHR, ZABS, AC, D1MACH
|
||||
INTEGER IAS, IBS, IPMTR, IS, J, JR, JU, K, KMAX, KP1, KS, L, LR,
|
||||
* LRP1, L1, L2, M, IDUM
|
||||
DIMENSION AR(14), BR(14), C(105), ALFA(180), BETA(210), GAMA(30),
|
||||
* AP(30), PR(30), PI(30), UPR(14), UPI(14), CRR(14), CRI(14),
|
||||
* DRR(14), DRI(14)
|
||||
DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), AR(8),
|
||||
1 AR(9), AR(10), AR(11), AR(12), AR(13), AR(14)/
|
||||
2 1.00000000000000000D+00, 1.04166666666666667D-01,
|
||||
3 8.35503472222222222D-02, 1.28226574556327160D-01,
|
||||
4 2.91849026464140464D-01, 8.81627267443757652D-01,
|
||||
5 3.32140828186276754D+00, 1.49957629868625547D+01,
|
||||
6 7.89230130115865181D+01, 4.74451538868264323D+02,
|
||||
7 3.20749009089066193D+03, 2.40865496408740049D+04,
|
||||
8 1.98923119169509794D+05, 1.79190200777534383D+06/
|
||||
DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8),
|
||||
1 BR(9), BR(10), BR(11), BR(12), BR(13), BR(14)/
|
||||
2 1.00000000000000000D+00, -1.45833333333333333D-01,
|
||||
3 -9.87413194444444444D-02, -1.43312053915895062D-01,
|
||||
4 -3.17227202678413548D-01, -9.42429147957120249D-01,
|
||||
5 -3.51120304082635426D+00, -1.57272636203680451D+01,
|
||||
6 -8.22814390971859444D+01, -4.92355370523670524D+02,
|
||||
7 -3.31621856854797251D+03, -2.48276742452085896D+04,
|
||||
8 -2.04526587315129788D+05, -1.83844491706820990D+06/
|
||||
DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10),
|
||||
1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18),
|
||||
2 C(19), C(20), C(21), C(22), C(23), C(24)/
|
||||
3 1.00000000000000000D+00, -2.08333333333333333D-01,
|
||||
4 1.25000000000000000D-01, 3.34201388888888889D-01,
|
||||
5 -4.01041666666666667D-01, 7.03125000000000000D-02,
|
||||
6 -1.02581259645061728D+00, 1.84646267361111111D+00,
|
||||
7 -8.91210937500000000D-01, 7.32421875000000000D-02,
|
||||
8 4.66958442342624743D+00, -1.12070026162229938D+01,
|
||||
9 8.78912353515625000D+00, -2.36408691406250000D+00,
|
||||
A 1.12152099609375000D-01, -2.82120725582002449D+01,
|
||||
B 8.46362176746007346D+01, -9.18182415432400174D+01,
|
||||
C 4.25349987453884549D+01, -7.36879435947963170D+00,
|
||||
D 2.27108001708984375D-01, 2.12570130039217123D+02,
|
||||
E -7.65252468141181642D+02, 1.05999045252799988D+03/
|
||||
DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32),
|
||||
1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40),
|
||||
2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/
|
||||
3 -6.99579627376132541D+02, 2.18190511744211590D+02,
|
||||
4 -2.64914304869515555D+01, 5.72501420974731445D-01,
|
||||
5 -1.91945766231840700D+03, 8.06172218173730938D+03,
|
||||
6 -1.35865500064341374D+04, 1.16553933368645332D+04,
|
||||
7 -5.30564697861340311D+03, 1.20090291321635246D+03,
|
||||
8 -1.08090919788394656D+02, 1.72772750258445740D+00,
|
||||
9 2.02042913309661486D+04, -9.69805983886375135D+04,
|
||||
A 1.92547001232531532D+05, -2.03400177280415534D+05,
|
||||
B 1.22200464983017460D+05, -4.11926549688975513D+04,
|
||||
C 7.10951430248936372D+03, -4.93915304773088012D+02,
|
||||
D 6.07404200127348304D+00, -2.42919187900551333D+05,
|
||||
E 1.31176361466297720D+06, -2.99801591853810675D+06/
|
||||
DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56),
|
||||
1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64),
|
||||
2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/
|
||||
3 3.76327129765640400D+06, -2.81356322658653411D+06,
|
||||
4 1.26836527332162478D+06, -3.31645172484563578D+05,
|
||||
5 4.52187689813627263D+04, -2.49983048181120962D+03,
|
||||
6 2.43805296995560639D+01, 3.28446985307203782D+06,
|
||||
7 -1.97068191184322269D+07, 5.09526024926646422D+07,
|
||||
8 -7.41051482115326577D+07, 6.63445122747290267D+07,
|
||||
9 -3.75671766607633513D+07, 1.32887671664218183D+07,
|
||||
A -2.78561812808645469D+06, 3.08186404612662398D+05,
|
||||
B -1.38860897537170405D+04, 1.10017140269246738D+02,
|
||||
C -4.93292536645099620D+07, 3.25573074185765749D+08,
|
||||
D -9.39462359681578403D+08, 1.55359689957058006D+09,
|
||||
E -1.62108055210833708D+09, 1.10684281682301447D+09/
|
||||
DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80),
|
||||
1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88),
|
||||
2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/
|
||||
3 -4.95889784275030309D+08, 1.42062907797533095D+08,
|
||||
4 -2.44740627257387285D+07, 2.24376817792244943D+06,
|
||||
5 -8.40054336030240853D+04, 5.51335896122020586D+02,
|
||||
6 8.14789096118312115D+08, -5.86648149205184723D+09,
|
||||
7 1.86882075092958249D+10, -3.46320433881587779D+10,
|
||||
8 4.12801855797539740D+10, -3.30265997498007231D+10,
|
||||
9 1.79542137311556001D+10, -6.56329379261928433D+09,
|
||||
A 1.55927986487925751D+09, -2.25105661889415278D+08,
|
||||
B 1.73951075539781645D+07, -5.49842327572288687D+05,
|
||||
C 3.03809051092238427D+03, -1.46792612476956167D+10,
|
||||
D 1.14498237732025810D+11, -3.99096175224466498D+11,
|
||||
E 8.19218669548577329D+11, -1.09837515608122331D+12/
|
||||
DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104),
|
||||
1 C(105)/
|
||||
2 1.00815810686538209D+12, -6.45364869245376503D+11,
|
||||
3 2.87900649906150589D+11, -8.78670721780232657D+10,
|
||||
4 1.76347306068349694D+10, -2.16716498322379509D+09,
|
||||
5 1.43157876718888981D+08, -3.87183344257261262D+06,
|
||||
6 1.82577554742931747D+04/
|
||||
DATA ALFA(1), ALFA(2), ALFA(3), ALFA(4), ALFA(5), ALFA(6),
|
||||
1 ALFA(7), ALFA(8), ALFA(9), ALFA(10), ALFA(11), ALFA(12),
|
||||
2 ALFA(13), ALFA(14), ALFA(15), ALFA(16), ALFA(17), ALFA(18),
|
||||
3 ALFA(19), ALFA(20), ALFA(21), ALFA(22)/
|
||||
4 -4.44444444444444444D-03, -9.22077922077922078D-04,
|
||||
5 -8.84892884892884893D-05, 1.65927687832449737D-04,
|
||||
6 2.46691372741792910D-04, 2.65995589346254780D-04,
|
||||
7 2.61824297061500945D-04, 2.48730437344655609D-04,
|
||||
8 2.32721040083232098D-04, 2.16362485712365082D-04,
|
||||
9 2.00738858762752355D-04, 1.86267636637545172D-04,
|
||||
A 1.73060775917876493D-04, 1.61091705929015752D-04,
|
||||
B 1.50274774160908134D-04, 1.40503497391269794D-04,
|
||||
C 1.31668816545922806D-04, 1.23667445598253261D-04,
|
||||
D 1.16405271474737902D-04, 1.09798298372713369D-04,
|
||||
E 1.03772410422992823D-04, 9.82626078369363448D-05/
|
||||
DATA ALFA(23), ALFA(24), ALFA(25), ALFA(26), ALFA(27), ALFA(28),
|
||||
1 ALFA(29), ALFA(30), ALFA(31), ALFA(32), ALFA(33), ALFA(34),
|
||||
2 ALFA(35), ALFA(36), ALFA(37), ALFA(38), ALFA(39), ALFA(40),
|
||||
3 ALFA(41), ALFA(42), ALFA(43), ALFA(44)/
|
||||
4 9.32120517249503256D-05, 8.85710852478711718D-05,
|
||||
5 8.42963105715700223D-05, 8.03497548407791151D-05,
|
||||
6 7.66981345359207388D-05, 7.33122157481777809D-05,
|
||||
7 7.01662625163141333D-05, 6.72375633790160292D-05,
|
||||
8 6.93735541354588974D-04, 2.32241745182921654D-04,
|
||||
9 -1.41986273556691197D-05, -1.16444931672048640D-04,
|
||||
A -1.50803558053048762D-04, -1.55121924918096223D-04,
|
||||
B -1.46809756646465549D-04, -1.33815503867491367D-04,
|
||||
C -1.19744975684254051D-04, -1.06184319207974020D-04,
|
||||
D -9.37699549891194492D-05, -8.26923045588193274D-05,
|
||||
E -7.29374348155221211D-05, -6.44042357721016283D-05/
|
||||
DATA ALFA(45), ALFA(46), ALFA(47), ALFA(48), ALFA(49), ALFA(50),
|
||||
1 ALFA(51), ALFA(52), ALFA(53), ALFA(54), ALFA(55), ALFA(56),
|
||||
2 ALFA(57), ALFA(58), ALFA(59), ALFA(60), ALFA(61), ALFA(62),
|
||||
3 ALFA(63), ALFA(64), ALFA(65), ALFA(66)/
|
||||
4 -5.69611566009369048D-05, -5.04731044303561628D-05,
|
||||
5 -4.48134868008882786D-05, -3.98688727717598864D-05,
|
||||
6 -3.55400532972042498D-05, -3.17414256609022480D-05,
|
||||
7 -2.83996793904174811D-05, -2.54522720634870566D-05,
|
||||
8 -2.28459297164724555D-05, -2.05352753106480604D-05,
|
||||
9 -1.84816217627666085D-05, -1.66519330021393806D-05,
|
||||
A -1.50179412980119482D-05, -1.35554031379040526D-05,
|
||||
B -1.22434746473858131D-05, -1.10641884811308169D-05,
|
||||
C -3.54211971457743841D-04, -1.56161263945159416D-04,
|
||||
D 3.04465503594936410D-05, 1.30198655773242693D-04,
|
||||
E 1.67471106699712269D-04, 1.70222587683592569D-04/
|
||||
DATA ALFA(67), ALFA(68), ALFA(69), ALFA(70), ALFA(71), ALFA(72),
|
||||
1 ALFA(73), ALFA(74), ALFA(75), ALFA(76), ALFA(77), ALFA(78),
|
||||
2 ALFA(79), ALFA(80), ALFA(81), ALFA(82), ALFA(83), ALFA(84),
|
||||
3 ALFA(85), ALFA(86), ALFA(87), ALFA(88)/
|
||||
4 1.56501427608594704D-04, 1.36339170977445120D-04,
|
||||
5 1.14886692029825128D-04, 9.45869093034688111D-05,
|
||||
6 7.64498419250898258D-05, 6.07570334965197354D-05,
|
||||
7 4.74394299290508799D-05, 3.62757512005344297D-05,
|
||||
8 2.69939714979224901D-05, 1.93210938247939253D-05,
|
||||
9 1.30056674793963203D-05, 7.82620866744496661D-06,
|
||||
A 3.59257485819351583D-06, 1.44040049814251817D-07,
|
||||
B -2.65396769697939116D-06, -4.91346867098485910D-06,
|
||||
C -6.72739296091248287D-06, -8.17269379678657923D-06,
|
||||
D -9.31304715093561232D-06, -1.02011418798016441D-05,
|
||||
E -1.08805962510592880D-05, -1.13875481509603555D-05/
|
||||
DATA ALFA(89), ALFA(90), ALFA(91), ALFA(92), ALFA(93), ALFA(94),
|
||||
1 ALFA(95), ALFA(96), ALFA(97), ALFA(98), ALFA(99), ALFA(100),
|
||||
2 ALFA(101), ALFA(102), ALFA(103), ALFA(104), ALFA(105),
|
||||
3 ALFA(106), ALFA(107), ALFA(108), ALFA(109), ALFA(110)/
|
||||
4 -1.17519675674556414D-05, -1.19987364870944141D-05,
|
||||
5 3.78194199201772914D-04, 2.02471952761816167D-04,
|
||||
6 -6.37938506318862408D-05, -2.38598230603005903D-04,
|
||||
7 -3.10916256027361568D-04, -3.13680115247576316D-04,
|
||||
8 -2.78950273791323387D-04, -2.28564082619141374D-04,
|
||||
9 -1.75245280340846749D-04, -1.25544063060690348D-04,
|
||||
A -8.22982872820208365D-05, -4.62860730588116458D-05,
|
||||
B -1.72334302366962267D-05, 5.60690482304602267D-06,
|
||||
C 2.31395443148286800D-05, 3.62642745856793957D-05,
|
||||
D 4.58006124490188752D-05, 5.24595294959114050D-05,
|
||||
E 5.68396208545815266D-05, 5.94349820393104052D-05/
|
||||
DATA ALFA(111), ALFA(112), ALFA(113), ALFA(114), ALFA(115),
|
||||
1 ALFA(116), ALFA(117), ALFA(118), ALFA(119), ALFA(120),
|
||||
2 ALFA(121), ALFA(122), ALFA(123), ALFA(124), ALFA(125),
|
||||
3 ALFA(126), ALFA(127), ALFA(128), ALFA(129), ALFA(130)/
|
||||
4 6.06478527578421742D-05, 6.08023907788436497D-05,
|
||||
5 6.01577894539460388D-05, 5.89199657344698500D-05,
|
||||
6 5.72515823777593053D-05, 5.52804375585852577D-05,
|
||||
7 5.31063773802880170D-05, 5.08069302012325706D-05,
|
||||
8 4.84418647620094842D-05, 4.60568581607475370D-05,
|
||||
9 -6.91141397288294174D-04, -4.29976633058871912D-04,
|
||||
A 1.83067735980039018D-04, 6.60088147542014144D-04,
|
||||
B 8.75964969951185931D-04, 8.77335235958235514D-04,
|
||||
C 7.49369585378990637D-04, 5.63832329756980918D-04,
|
||||
D 3.68059319971443156D-04, 1.88464535514455599D-04/
|
||||
DATA ALFA(131), ALFA(132), ALFA(133), ALFA(134), ALFA(135),
|
||||
1 ALFA(136), ALFA(137), ALFA(138), ALFA(139), ALFA(140),
|
||||
2 ALFA(141), ALFA(142), ALFA(143), ALFA(144), ALFA(145),
|
||||
3 ALFA(146), ALFA(147), ALFA(148), ALFA(149), ALFA(150)/
|
||||
4 3.70663057664904149D-05, -8.28520220232137023D-05,
|
||||
5 -1.72751952869172998D-04, -2.36314873605872983D-04,
|
||||
6 -2.77966150694906658D-04, -3.02079514155456919D-04,
|
||||
7 -3.12594712643820127D-04, -3.12872558758067163D-04,
|
||||
8 -3.05678038466324377D-04, -2.93226470614557331D-04,
|
||||
9 -2.77255655582934777D-04, -2.59103928467031709D-04,
|
||||
A -2.39784014396480342D-04, -2.20048260045422848D-04,
|
||||
B -2.00443911094971498D-04, -1.81358692210970687D-04,
|
||||
C -1.63057674478657464D-04, -1.45712672175205844D-04,
|
||||
D -1.29425421983924587D-04, -1.14245691942445952D-04/
|
||||
DATA ALFA(151), ALFA(152), ALFA(153), ALFA(154), ALFA(155),
|
||||
1 ALFA(156), ALFA(157), ALFA(158), ALFA(159), ALFA(160),
|
||||
2 ALFA(161), ALFA(162), ALFA(163), ALFA(164), ALFA(165),
|
||||
3 ALFA(166), ALFA(167), ALFA(168), ALFA(169), ALFA(170)/
|
||||
4 1.92821964248775885D-03, 1.35592576302022234D-03,
|
||||
5 -7.17858090421302995D-04, -2.58084802575270346D-03,
|
||||
6 -3.49271130826168475D-03, -3.46986299340960628D-03,
|
||||
7 -2.82285233351310182D-03, -1.88103076404891354D-03,
|
||||
8 -8.89531718383947600D-04, 3.87912102631035228D-06,
|
||||
9 7.28688540119691412D-04, 1.26566373053457758D-03,
|
||||
A 1.62518158372674427D-03, 1.83203153216373172D-03,
|
||||
B 1.91588388990527909D-03, 1.90588846755546138D-03,
|
||||
C 1.82798982421825727D-03, 1.70389506421121530D-03,
|
||||
D 1.55097127171097686D-03, 1.38261421852276159D-03/
|
||||
DATA ALFA(171), ALFA(172), ALFA(173), ALFA(174), ALFA(175),
|
||||
1 ALFA(176), ALFA(177), ALFA(178), ALFA(179), ALFA(180)/
|
||||
2 1.20881424230064774D-03, 1.03676532638344962D-03,
|
||||
3 8.71437918068619115D-04, 7.16080155297701002D-04,
|
||||
4 5.72637002558129372D-04, 4.42089819465802277D-04,
|
||||
5 3.24724948503090564D-04, 2.20342042730246599D-04,
|
||||
6 1.28412898401353882D-04, 4.82005924552095464D-05/
|
||||
DATA BETA(1), BETA(2), BETA(3), BETA(4), BETA(5), BETA(6),
|
||||
1 BETA(7), BETA(8), BETA(9), BETA(10), BETA(11), BETA(12),
|
||||
2 BETA(13), BETA(14), BETA(15), BETA(16), BETA(17), BETA(18),
|
||||
3 BETA(19), BETA(20), BETA(21), BETA(22)/
|
||||
4 1.79988721413553309D-02, 5.59964911064388073D-03,
|
||||
5 2.88501402231132779D-03, 1.80096606761053941D-03,
|
||||
6 1.24753110589199202D-03, 9.22878876572938311D-04,
|
||||
7 7.14430421727287357D-04, 5.71787281789704872D-04,
|
||||
8 4.69431007606481533D-04, 3.93232835462916638D-04,
|
||||
9 3.34818889318297664D-04, 2.88952148495751517D-04,
|
||||
A 2.52211615549573284D-04, 2.22280580798883327D-04,
|
||||
B 1.97541838033062524D-04, 1.76836855019718004D-04,
|
||||
C 1.59316899661821081D-04, 1.44347930197333986D-04,
|
||||
D 1.31448068119965379D-04, 1.20245444949302884D-04,
|
||||
E 1.10449144504599392D-04, 1.01828770740567258D-04/
|
||||
DATA BETA(23), BETA(24), BETA(25), BETA(26), BETA(27), BETA(28),
|
||||
1 BETA(29), BETA(30), BETA(31), BETA(32), BETA(33), BETA(34),
|
||||
2 BETA(35), BETA(36), BETA(37), BETA(38), BETA(39), BETA(40),
|
||||
3 BETA(41), BETA(42), BETA(43), BETA(44)/
|
||||
4 9.41998224204237509D-05, 8.74130545753834437D-05,
|
||||
5 8.13466262162801467D-05, 7.59002269646219339D-05,
|
||||
6 7.09906300634153481D-05, 6.65482874842468183D-05,
|
||||
7 6.25146958969275078D-05, 5.88403394426251749D-05,
|
||||
8 -1.49282953213429172D-03, -8.78204709546389328D-04,
|
||||
9 -5.02916549572034614D-04, -2.94822138512746025D-04,
|
||||
A -1.75463996970782828D-04, -1.04008550460816434D-04,
|
||||
B -5.96141953046457895D-05, -3.12038929076098340D-05,
|
||||
C -1.26089735980230047D-05, -2.42892608575730389D-07,
|
||||
D 8.05996165414273571D-06, 1.36507009262147391D-05,
|
||||
E 1.73964125472926261D-05, 1.98672978842133780D-05/
|
||||
DATA BETA(45), BETA(46), BETA(47), BETA(48), BETA(49), BETA(50),
|
||||
1 BETA(51), BETA(52), BETA(53), BETA(54), BETA(55), BETA(56),
|
||||
2 BETA(57), BETA(58), BETA(59), BETA(60), BETA(61), BETA(62),
|
||||
3 BETA(63), BETA(64), BETA(65), BETA(66)/
|
||||
4 2.14463263790822639D-05, 2.23954659232456514D-05,
|
||||
5 2.28967783814712629D-05, 2.30785389811177817D-05,
|
||||
6 2.30321976080909144D-05, 2.28236073720348722D-05,
|
||||
7 2.25005881105292418D-05, 2.20981015361991429D-05,
|
||||
8 2.16418427448103905D-05, 2.11507649256220843D-05,
|
||||
9 2.06388749782170737D-05, 2.01165241997081666D-05,
|
||||
A 1.95913450141179244D-05, 1.90689367910436740D-05,
|
||||
B 1.85533719641636667D-05, 1.80475722259674218D-05,
|
||||
C 5.52213076721292790D-04, 4.47932581552384646D-04,
|
||||
D 2.79520653992020589D-04, 1.52468156198446602D-04,
|
||||
E 6.93271105657043598D-05, 1.76258683069991397D-05/
|
||||
DATA BETA(67), BETA(68), BETA(69), BETA(70), BETA(71), BETA(72),
|
||||
1 BETA(73), BETA(74), BETA(75), BETA(76), BETA(77), BETA(78),
|
||||
2 BETA(79), BETA(80), BETA(81), BETA(82), BETA(83), BETA(84),
|
||||
3 BETA(85), BETA(86), BETA(87), BETA(88)/
|
||||
4 -1.35744996343269136D-05, -3.17972413350427135D-05,
|
||||
5 -4.18861861696693365D-05, -4.69004889379141029D-05,
|
||||
6 -4.87665447413787352D-05, -4.87010031186735069D-05,
|
||||
7 -4.74755620890086638D-05, -4.55813058138628452D-05,
|
||||
8 -4.33309644511266036D-05, -4.09230193157750364D-05,
|
||||
9 -3.84822638603221274D-05, -3.60857167535410501D-05,
|
||||
A -3.37793306123367417D-05, -3.15888560772109621D-05,
|
||||
B -2.95269561750807315D-05, -2.75978914828335759D-05,
|
||||
C -2.58006174666883713D-05, -2.41308356761280200D-05,
|
||||
D -2.25823509518346033D-05, -2.11479656768912971D-05,
|
||||
E -1.98200638885294927D-05, -1.85909870801065077D-05/
|
||||
DATA BETA(89), BETA(90), BETA(91), BETA(92), BETA(93), BETA(94),
|
||||
1 BETA(95), BETA(96), BETA(97), BETA(98), BETA(99), BETA(100),
|
||||
2 BETA(101), BETA(102), BETA(103), BETA(104), BETA(105),
|
||||
3 BETA(106), BETA(107), BETA(108), BETA(109), BETA(110)/
|
||||
4 -1.74532699844210224D-05, -1.63997823854497997D-05,
|
||||
5 -4.74617796559959808D-04, -4.77864567147321487D-04,
|
||||
6 -3.20390228067037603D-04, -1.61105016119962282D-04,
|
||||
7 -4.25778101285435204D-05, 3.44571294294967503D-05,
|
||||
8 7.97092684075674924D-05, 1.03138236708272200D-04,
|
||||
9 1.12466775262204158D-04, 1.13103642108481389D-04,
|
||||
A 1.08651634848774268D-04, 1.01437951597661973D-04,
|
||||
B 9.29298396593363896D-05, 8.40293133016089978D-05,
|
||||
C 7.52727991349134062D-05, 6.69632521975730872D-05,
|
||||
D 5.92564547323194704D-05, 5.22169308826975567D-05,
|
||||
E 4.58539485165360646D-05, 4.01445513891486808D-05/
|
||||
DATA BETA(111), BETA(112), BETA(113), BETA(114), BETA(115),
|
||||
1 BETA(116), BETA(117), BETA(118), BETA(119), BETA(120),
|
||||
2 BETA(121), BETA(122), BETA(123), BETA(124), BETA(125),
|
||||
3 BETA(126), BETA(127), BETA(128), BETA(129), BETA(130)/
|
||||
4 3.50481730031328081D-05, 3.05157995034346659D-05,
|
||||
5 2.64956119950516039D-05, 2.29363633690998152D-05,
|
||||
6 1.97893056664021636D-05, 1.70091984636412623D-05,
|
||||
7 1.45547428261524004D-05, 1.23886640995878413D-05,
|
||||
8 1.04775876076583236D-05, 8.79179954978479373D-06,
|
||||
9 7.36465810572578444D-04, 8.72790805146193976D-04,
|
||||
A 6.22614862573135066D-04, 2.85998154194304147D-04,
|
||||
B 3.84737672879366102D-06, -1.87906003636971558D-04,
|
||||
C -2.97603646594554535D-04, -3.45998126832656348D-04,
|
||||
D -3.53382470916037712D-04, -3.35715635775048757D-04/
|
||||
DATA BETA(131), BETA(132), BETA(133), BETA(134), BETA(135),
|
||||
1 BETA(136), BETA(137), BETA(138), BETA(139), BETA(140),
|
||||
2 BETA(141), BETA(142), BETA(143), BETA(144), BETA(145),
|
||||
3 BETA(146), BETA(147), BETA(148), BETA(149), BETA(150)/
|
||||
4 -3.04321124789039809D-04, -2.66722723047612821D-04,
|
||||
5 -2.27654214122819527D-04, -1.89922611854562356D-04,
|
||||
6 -1.55058918599093870D-04, -1.23778240761873630D-04,
|
||||
7 -9.62926147717644187D-05, -7.25178327714425337D-05,
|
||||
8 -5.22070028895633801D-05, -3.50347750511900522D-05,
|
||||
9 -2.06489761035551757D-05, -8.70106096849767054D-06,
|
||||
A 1.13698686675100290D-06, 9.16426474122778849D-06,
|
||||
B 1.56477785428872620D-05, 2.08223629482466847D-05,
|
||||
C 2.48923381004595156D-05, 2.80340509574146325D-05,
|
||||
D 3.03987774629861915D-05, 3.21156731406700616D-05/
|
||||
DATA BETA(151), BETA(152), BETA(153), BETA(154), BETA(155),
|
||||
1 BETA(156), BETA(157), BETA(158), BETA(159), BETA(160),
|
||||
2 BETA(161), BETA(162), BETA(163), BETA(164), BETA(165),
|
||||
3 BETA(166), BETA(167), BETA(168), BETA(169), BETA(170)/
|
||||
4 -1.80182191963885708D-03, -2.43402962938042533D-03,
|
||||
5 -1.83422663549856802D-03, -7.62204596354009765D-04,
|
||||
6 2.39079475256927218D-04, 9.49266117176881141D-04,
|
||||
7 1.34467449701540359D-03, 1.48457495259449178D-03,
|
||||
8 1.44732339830617591D-03, 1.30268261285657186D-03,
|
||||
9 1.10351597375642682D-03, 8.86047440419791759D-04,
|
||||
A 6.73073208165665473D-04, 4.77603872856582378D-04,
|
||||
B 3.05991926358789362D-04, 1.60315694594721630D-04,
|
||||
C 4.00749555270613286D-05, -5.66607461635251611D-05,
|
||||
D -1.32506186772982638D-04, -1.90296187989614057D-04/
|
||||
DATA BETA(171), BETA(172), BETA(173), BETA(174), BETA(175),
|
||||
1 BETA(176), BETA(177), BETA(178), BETA(179), BETA(180),
|
||||
2 BETA(181), BETA(182), BETA(183), BETA(184), BETA(185),
|
||||
3 BETA(186), BETA(187), BETA(188), BETA(189), BETA(190)/
|
||||
4 -2.32811450376937408D-04, -2.62628811464668841D-04,
|
||||
5 -2.82050469867598672D-04, -2.93081563192861167D-04,
|
||||
6 -2.97435962176316616D-04, -2.96557334239348078D-04,
|
||||
7 -2.91647363312090861D-04, -2.83696203837734166D-04,
|
||||
8 -2.73512317095673346D-04, -2.61750155806768580D-04,
|
||||
9 6.38585891212050914D-03, 9.62374215806377941D-03,
|
||||
A 7.61878061207001043D-03, 2.83219055545628054D-03,
|
||||
B -2.09841352012720090D-03, -5.73826764216626498D-03,
|
||||
C -7.70804244495414620D-03, -8.21011692264844401D-03,
|
||||
D -7.65824520346905413D-03, -6.47209729391045177D-03/
|
||||
DATA BETA(191), BETA(192), BETA(193), BETA(194), BETA(195),
|
||||
1 BETA(196), BETA(197), BETA(198), BETA(199), BETA(200),
|
||||
2 BETA(201), BETA(202), BETA(203), BETA(204), BETA(205),
|
||||
3 BETA(206), BETA(207), BETA(208), BETA(209), BETA(210)/
|
||||
4 -4.99132412004966473D-03, -3.45612289713133280D-03,
|
||||
5 -2.01785580014170775D-03, -7.59430686781961401D-04,
|
||||
6 2.84173631523859138D-04, 1.10891667586337403D-03,
|
||||
7 1.72901493872728771D-03, 2.16812590802684701D-03,
|
||||
8 2.45357710494539735D-03, 2.61281821058334862D-03,
|
||||
9 2.67141039656276912D-03, 2.65203073395980430D-03,
|
||||
A 2.57411652877287315D-03, 2.45389126236094427D-03,
|
||||
B 2.30460058071795494D-03, 2.13684837686712662D-03,
|
||||
C 1.95896528478870911D-03, 1.77737008679454412D-03,
|
||||
D 1.59690280765839059D-03, 1.42111975664438546D-03/
|
||||
DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), GAMA(6),
|
||||
1 GAMA(7), GAMA(8), GAMA(9), GAMA(10), GAMA(11), GAMA(12),
|
||||
2 GAMA(13), GAMA(14), GAMA(15), GAMA(16), GAMA(17), GAMA(18),
|
||||
3 GAMA(19), GAMA(20), GAMA(21), GAMA(22)/
|
||||
4 6.29960524947436582D-01, 2.51984209978974633D-01,
|
||||
5 1.54790300415655846D-01, 1.10713062416159013D-01,
|
||||
6 8.57309395527394825D-02, 6.97161316958684292D-02,
|
||||
7 5.86085671893713576D-02, 5.04698873536310685D-02,
|
||||
8 4.42600580689154809D-02, 3.93720661543509966D-02,
|
||||
9 3.54283195924455368D-02, 3.21818857502098231D-02,
|
||||
A 2.94646240791157679D-02, 2.71581677112934479D-02,
|
||||
B 2.51768272973861779D-02, 2.34570755306078891D-02,
|
||||
C 2.19508390134907203D-02, 2.06210828235646240D-02,
|
||||
D 1.94388240897880846D-02, 1.83810633800683158D-02,
|
||||
E 1.74293213231963172D-02, 1.65685837786612353D-02/
|
||||
DATA GAMA(23), GAMA(24), GAMA(25), GAMA(26), GAMA(27), GAMA(28),
|
||||
1 GAMA(29), GAMA(30)/
|
||||
2 1.57865285987918445D-02, 1.50729501494095594D-02,
|
||||
3 1.44193250839954639D-02, 1.38184805735341786D-02,
|
||||
4 1.32643378994276568D-02, 1.27517121970498651D-02,
|
||||
5 1.22761545318762767D-02, 1.18338262398482403D-02/
|
||||
DATA EX1, EX2, HPI, GPI, THPI /
|
||||
1 3.33333333333333333D-01, 6.66666666666666667D-01,
|
||||
2 1.57079632679489662D+00, 3.14159265358979324D+00,
|
||||
3 4.71238898038468986D+00/
|
||||
DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
|
||||
C
|
||||
RFNU = 1.0D0/FNU
|
||||
C-----------------------------------------------------------------------
|
||||
C OVERFLOW TEST (Z/FNU TOO SMALL)
|
||||
C-----------------------------------------------------------------------
|
||||
TEST = D1MACH(1)*1.0D+3
|
||||
AC = FNU*TEST
|
||||
IF (DABS(ZR).GT.AC .OR. DABS(ZI).GT.AC) GO TO 15
|
||||
ZETA1R = 2.0D0*DABS(DLOG(TEST))+FNU
|
||||
ZETA1I = 0.0D0
|
||||
ZETA2R = FNU
|
||||
ZETA2I = 0.0D0
|
||||
PHIR = 1.0D0
|
||||
PHII = 0.0D0
|
||||
ARGR = 1.0D0
|
||||
ARGI = 0.0D0
|
||||
RETURN
|
||||
15 CONTINUE
|
||||
ZBR = ZR*RFNU
|
||||
ZBI = ZI*RFNU
|
||||
RFNU2 = RFNU*RFNU
|
||||
C-----------------------------------------------------------------------
|
||||
C COMPUTE IN THE FOURTH QUADRANT
|
||||
C-----------------------------------------------------------------------
|
||||
FN13 = FNU**EX1
|
||||
FN23 = FN13*FN13
|
||||
RFN13 = 1.0D0/FN13
|
||||
W2R = CONER - ZBR*ZBR + ZBI*ZBI
|
||||
W2I = CONEI - ZBR*ZBI - ZBR*ZBI
|
||||
AW2 = ZABS(W2R,W2I)
|
||||
IF (AW2.GT.0.25D0) GO TO 130
|
||||
C-----------------------------------------------------------------------
|
||||
C POWER SERIES FOR CABS(W2).LE.0.25D0
|
||||
C-----------------------------------------------------------------------
|
||||
K = 1
|
||||
PR(1) = CONER
|
||||
PI(1) = CONEI
|
||||
SUMAR = GAMA(1)
|
||||
SUMAI = ZEROI
|
||||
AP(1) = 1.0D0
|
||||
IF (AW2.LT.TOL) GO TO 20
|
||||
DO 10 K=2,30
|
||||
PR(K) = PR(K-1)*W2R - PI(K-1)*W2I
|
||||
PI(K) = PR(K-1)*W2I + PI(K-1)*W2R
|
||||
SUMAR = SUMAR + PR(K)*GAMA(K)
|
||||
SUMAI = SUMAI + PI(K)*GAMA(K)
|
||||
AP(K) = AP(K-1)*AW2
|
||||
IF (AP(K).LT.TOL) GO TO 20
|
||||
10 CONTINUE
|
||||
K = 30
|
||||
20 CONTINUE
|
||||
KMAX = K
|
||||
ZETAR = W2R*SUMAR - W2I*SUMAI
|
||||
ZETAI = W2R*SUMAI + W2I*SUMAR
|
||||
ARGR = ZETAR*FN23
|
||||
ARGI = ZETAI*FN23
|
||||
CALL ZSQRT(SUMAR, SUMAI, ZAR, ZAI)
|
||||
CALL ZSQRT(W2R, W2I, STR, STI)
|
||||
ZETA2R = STR*FNU
|
||||
ZETA2I = STI*FNU
|
||||
STR = CONER + EX2*(ZETAR*ZAR-ZETAI*ZAI)
|
||||
STI = CONEI + EX2*(ZETAR*ZAI+ZETAI*ZAR)
|
||||
ZETA1R = STR*ZETA2R - STI*ZETA2I
|
||||
ZETA1I = STR*ZETA2I + STI*ZETA2R
|
||||
ZAR = ZAR + ZAR
|
||||
ZAI = ZAI + ZAI
|
||||
CALL ZSQRT(ZAR, ZAI, STR, STI)
|
||||
PHIR = STR*RFN13
|
||||
PHII = STI*RFN13
|
||||
IF (IPMTR.EQ.1) GO TO 120
|
||||
C-----------------------------------------------------------------------
|
||||
C SUM SERIES FOR ASUM AND BSUM
|
||||
C-----------------------------------------------------------------------
|
||||
SUMBR = ZEROR
|
||||
SUMBI = ZEROI
|
||||
DO 30 K=1,KMAX
|
||||
SUMBR = SUMBR + PR(K)*BETA(K)
|
||||
SUMBI = SUMBI + PI(K)*BETA(K)
|
||||
30 CONTINUE
|
||||
ASUMR = ZEROR
|
||||
ASUMI = ZEROI
|
||||
BSUMR = SUMBR
|
||||
BSUMI = SUMBI
|
||||
L1 = 0
|
||||
L2 = 30
|
||||
BTOL = TOL*(DABS(BSUMR)+DABS(BSUMI))
|
||||
ATOL = TOL
|
||||
PP = 1.0D0
|
||||
IAS = 0
|
||||
IBS = 0
|
||||
IF (RFNU2.LT.TOL) GO TO 110
|
||||
DO 100 IS=2,7
|
||||
ATOL = ATOL/RFNU2
|
||||
PP = PP*RFNU2
|
||||
IF (IAS.EQ.1) GO TO 60
|
||||
SUMAR = ZEROR
|
||||
SUMAI = ZEROI
|
||||
DO 40 K=1,KMAX
|
||||
M = L1 + K
|
||||
SUMAR = SUMAR + PR(K)*ALFA(M)
|
||||
SUMAI = SUMAI + PI(K)*ALFA(M)
|
||||
IF (AP(K).LT.ATOL) GO TO 50
|
||||
40 CONTINUE
|
||||
50 CONTINUE
|
||||
ASUMR = ASUMR + SUMAR*PP
|
||||
ASUMI = ASUMI + SUMAI*PP
|
||||
IF (PP.LT.TOL) IAS = 1
|
||||
60 CONTINUE
|
||||
IF (IBS.EQ.1) GO TO 90
|
||||
SUMBR = ZEROR
|
||||
SUMBI = ZEROI
|
||||
DO 70 K=1,KMAX
|
||||
M = L2 + K
|
||||
SUMBR = SUMBR + PR(K)*BETA(M)
|
||||
SUMBI = SUMBI + PI(K)*BETA(M)
|
||||
IF (AP(K).LT.ATOL) GO TO 80
|
||||
70 CONTINUE
|
||||
80 CONTINUE
|
||||
BSUMR = BSUMR + SUMBR*PP
|
||||
BSUMI = BSUMI + SUMBI*PP
|
||||
IF (PP.LT.BTOL) IBS = 1
|
||||
90 CONTINUE
|
||||
IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 110
|
||||
L1 = L1 + 30
|
||||
L2 = L2 + 30
|
||||
100 CONTINUE
|
||||
110 CONTINUE
|
||||
ASUMR = ASUMR + CONER
|
||||
PP = RFNU*RFN13
|
||||
BSUMR = BSUMR*PP
|
||||
BSUMI = BSUMI*PP
|
||||
120 CONTINUE
|
||||
RETURN
|
||||
C-----------------------------------------------------------------------
|
||||
C CABS(W2).GT.0.25D0
|
||||
C-----------------------------------------------------------------------
|
||||
130 CONTINUE
|
||||
CALL ZSQRT(W2R, W2I, WR, WI)
|
||||
IF (WR.LT.0.0D0) WR = 0.0D0
|
||||
IF (WI.LT.0.0D0) WI = 0.0D0
|
||||
STR = CONER + WR
|
||||
STI = WI
|
||||
CALL ZDIV(STR, STI, ZBR, ZBI, ZAR, ZAI)
|
||||
CALL ZLOG(ZAR, ZAI, ZCR, ZCI, IDUM)
|
||||
IF (ZCI.LT.0.0D0) ZCI = 0.0D0
|
||||
IF (ZCI.GT.HPI) ZCI = HPI
|
||||
IF (ZCR.LT.0.0D0) ZCR = 0.0D0
|
||||
ZTHR = (ZCR-WR)*1.5D0
|
||||
ZTHI = (ZCI-WI)*1.5D0
|
||||
ZETA1R = ZCR*FNU
|
||||
ZETA1I = ZCI*FNU
|
||||
ZETA2R = WR*FNU
|
||||
ZETA2I = WI*FNU
|
||||
AZTH = ZABS(ZTHR,ZTHI)
|
||||
ANG = THPI
|
||||
IF (ZTHR.GE.0.0D0 .AND. ZTHI.LT.0.0D0) GO TO 140
|
||||
ANG = HPI
|
||||
IF (ZTHR.EQ.0.0D0) GO TO 140
|
||||
ANG = DATAN(ZTHI/ZTHR)
|
||||
IF (ZTHR.LT.0.0D0) ANG = ANG + GPI
|
||||
140 CONTINUE
|
||||
PP = AZTH**EX2
|
||||
ANG = ANG*EX2
|
||||
ZETAR = PP*DCOS(ANG)
|
||||
ZETAI = PP*DSIN(ANG)
|
||||
IF (ZETAI.LT.0.0D0) ZETAI = 0.0D0
|
||||
ARGR = ZETAR*FN23
|
||||
ARGI = ZETAI*FN23
|
||||
CALL ZDIV(ZTHR, ZTHI, ZETAR, ZETAI, RTZTR, RTZTI)
|
||||
CALL ZDIV(RTZTR, RTZTI, WR, WI, ZAR, ZAI)
|
||||
TZAR = ZAR + ZAR
|
||||
TZAI = ZAI + ZAI
|
||||
CALL ZSQRT(TZAR, TZAI, STR, STI)
|
||||
PHIR = STR*RFN13
|
||||
PHII = STI*RFN13
|
||||
IF (IPMTR.EQ.1) GO TO 120
|
||||
RAW = 1.0D0/DSQRT(AW2)
|
||||
STR = WR*RAW
|
||||
STI = -WI*RAW
|
||||
TFNR = STR*RFNU*RAW
|
||||
TFNI = STI*RFNU*RAW
|
||||
RAZTH = 1.0D0/AZTH
|
||||
STR = ZTHR*RAZTH
|
||||
STI = -ZTHI*RAZTH
|
||||
RZTHR = STR*RAZTH*RFNU
|
||||
RZTHI = STI*RAZTH*RFNU
|
||||
ZCR = RZTHR*AR(2)
|
||||
ZCI = RZTHI*AR(2)
|
||||
RAW2 = 1.0D0/AW2
|
||||
STR = W2R*RAW2
|
||||
STI = -W2I*RAW2
|
||||
T2R = STR*RAW2
|
||||
T2I = STI*RAW2
|
||||
STR = T2R*C(2) + C(3)
|
||||
STI = T2I*C(2)
|
||||
UPR(2) = STR*TFNR - STI*TFNI
|
||||
UPI(2) = STR*TFNI + STI*TFNR
|
||||
BSUMR = UPR(2) + ZCR
|
||||
BSUMI = UPI(2) + ZCI
|
||||
ASUMR = ZEROR
|
||||
ASUMI = ZEROI
|
||||
IF (RFNU.LT.TOL) GO TO 220
|
||||
PRZTHR = RZTHR
|
||||
PRZTHI = RZTHI
|
||||
PTFNR = TFNR
|
||||
PTFNI = TFNI
|
||||
UPR(1) = CONER
|
||||
UPI(1) = CONEI
|
||||
PP = 1.0D0
|
||||
BTOL = TOL*(DABS(BSUMR)+DABS(BSUMI))
|
||||
KS = 0
|
||||
KP1 = 2
|
||||
L = 3
|
||||
IAS = 0
|
||||
IBS = 0
|
||||
DO 210 LR=2,12,2
|
||||
LRP1 = LR + 1
|
||||
C-----------------------------------------------------------------------
|
||||
C COMPUTE TWO ADDITIONAL CR, DR, AND UP FOR TWO MORE TERMS IN
|
||||
C NEXT SUMA AND SUMB
|
||||
C-----------------------------------------------------------------------
|
||||
DO 160 K=LR,LRP1
|
||||
KS = KS + 1
|
||||
KP1 = KP1 + 1
|
||||
L = L + 1
|
||||
ZAR = C(L)
|
||||
ZAI = ZEROI
|
||||
DO 150 J=2,KP1
|
||||
L = L + 1
|
||||
STR = ZAR*T2R - T2I*ZAI + C(L)
|
||||
ZAI = ZAR*T2I + ZAI*T2R
|
||||
ZAR = STR
|
||||
150 CONTINUE
|
||||
STR = PTFNR*TFNR - PTFNI*TFNI
|
||||
PTFNI = PTFNR*TFNI + PTFNI*TFNR
|
||||
PTFNR = STR
|
||||
UPR(KP1) = PTFNR*ZAR - PTFNI*ZAI
|
||||
UPI(KP1) = PTFNI*ZAR + PTFNR*ZAI
|
||||
CRR(KS) = PRZTHR*BR(KS+1)
|
||||
CRI(KS) = PRZTHI*BR(KS+1)
|
||||
STR = PRZTHR*RZTHR - PRZTHI*RZTHI
|
||||
PRZTHI = PRZTHR*RZTHI + PRZTHI*RZTHR
|
||||
PRZTHR = STR
|
||||
DRR(KS) = PRZTHR*AR(KS+2)
|
||||
DRI(KS) = PRZTHI*AR(KS+2)
|
||||
160 CONTINUE
|
||||
PP = PP*RFNU2
|
||||
IF (IAS.EQ.1) GO TO 180
|
||||
SUMAR = UPR(LRP1)
|
||||
SUMAI = UPI(LRP1)
|
||||
JU = LRP1
|
||||
DO 170 JR=1,LR
|
||||
JU = JU - 1
|
||||
SUMAR = SUMAR + CRR(JR)*UPR(JU) - CRI(JR)*UPI(JU)
|
||||
SUMAI = SUMAI + CRR(JR)*UPI(JU) + CRI(JR)*UPR(JU)
|
||||
170 CONTINUE
|
||||
ASUMR = ASUMR + SUMAR
|
||||
ASUMI = ASUMI + SUMAI
|
||||
TEST = DABS(SUMAR) + DABS(SUMAI)
|
||||
IF (PP.LT.TOL .AND. TEST.LT.TOL) IAS = 1
|
||||
180 CONTINUE
|
||||
IF (IBS.EQ.1) GO TO 200
|
||||
SUMBR = UPR(LR+2) + UPR(LRP1)*ZCR - UPI(LRP1)*ZCI
|
||||
SUMBI = UPI(LR+2) + UPR(LRP1)*ZCI + UPI(LRP1)*ZCR
|
||||
JU = LRP1
|
||||
DO 190 JR=1,LR
|
||||
JU = JU - 1
|
||||
SUMBR = SUMBR + DRR(JR)*UPR(JU) - DRI(JR)*UPI(JU)
|
||||
SUMBI = SUMBI + DRR(JR)*UPI(JU) + DRI(JR)*UPR(JU)
|
||||
190 CONTINUE
|
||||
BSUMR = BSUMR + SUMBR
|
||||
BSUMI = BSUMI + SUMBI
|
||||
TEST = DABS(SUMBR) + DABS(SUMBI)
|
||||
IF (PP.LT.BTOL .AND. TEST.LT.BTOL) IBS = 1
|
||||
200 CONTINUE
|
||||
IF (IAS.EQ.1 .AND. IBS.EQ.1) GO TO 220
|
||||
210 CONTINUE
|
||||
220 CONTINUE
|
||||
ASUMR = ASUMR + CONER
|
||||
STR = -BSUMR*RFN13
|
||||
STI = -BSUMI*RFN13
|
||||
CALL ZDIV(STR, STI, RTZTR, RTZTI, BSUMR, BSUMI)
|
||||
GO TO 120
|
||||
END
|
||||
|
|
@ -0,0 +1,204 @@
|
|||
SUBROUTINE ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL,
|
||||
* TOL, ELIM, ALIM)
|
||||
C***BEGIN PROLOGUE ZUNI1
|
||||
C***REFER TO ZBESI,ZBESK
|
||||
C
|
||||
C ZUNI1 COMPUTES I(FNU,Z) BY MEANS OF THE UNIFORM ASYMPTOTIC
|
||||
C EXPANSION FOR I(FNU,Z) IN -PI/3.LE.ARG Z.LE.PI/3.
|
||||
C
|
||||
C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC
|
||||
C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET.
|
||||
C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER
|
||||
C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL.
|
||||
C Y(I)=CZERO FOR I=NLAST+1,N
|
||||
C
|
||||
C***ROUTINES CALLED ZUCHK,ZUNIK,ZUOIK,D1MACH,ZABS
|
||||
C***END PROLOGUE ZUNI1
|
||||
C COMPLEX CFN,CONE,CRSC,CSCL,CSR,CSS,CWRK,CZERO,C1,C2,PHI,RZ,SUM,S1,
|
||||
C *S2,Y,Z,ZETA1,ZETA2
|
||||
DOUBLE PRECISION ALIM, APHI, ASCLE, BRY, CONER, CRSC,
|
||||
* CSCL, CSRR, CSSR, CWRKI, CWRKR, C1R, C2I, C2M, C2R, ELIM, FN,
|
||||
* FNU, FNUL, PHII, PHIR, RAST, RS1, RZI, RZR, STI, STR, SUMI,
|
||||
* SUMR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I,
|
||||
* ZETA1R, ZETA2I, ZETA2R, ZI, ZR, CYR, CYI, D1MACH, ZABS
|
||||
INTEGER I, IFLAG, INIT, K, KODE, M, N, ND, NLAST, NN, NUF, NW, NZ
|
||||
DIMENSION BRY(3), YR(N), YI(N), CWRKR(16), CWRKI(16), CSSR(3),
|
||||
* CSRR(3), CYR(2), CYI(2)
|
||||
DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 /
|
||||
C
|
||||
NZ = 0
|
||||
ND = N
|
||||
NLAST = 0
|
||||
C-----------------------------------------------------------------------
|
||||
C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG-
|
||||
C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE,
|
||||
C EXP(ALIM)=EXP(ELIM)*TOL
|
||||
C-----------------------------------------------------------------------
|
||||
CSCL = 1.0D0/TOL
|
||||
CRSC = TOL
|
||||
CSSR(1) = CSCL
|
||||
CSSR(2) = CONER
|
||||
CSSR(3) = CRSC
|
||||
CSRR(1) = CRSC
|
||||
CSRR(2) = CONER
|
||||
CSRR(3) = CSCL
|
||||
BRY(1) = 1.0D+3*D1MACH(1)/TOL
|
||||
C-----------------------------------------------------------------------
|
||||
C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER
|
||||
C-----------------------------------------------------------------------
|
||||
FN = DMAX1(FNU,1.0D0)
|
||||
INIT = 0
|
||||
CALL ZUNIK(ZR, ZI, FN, 1, 1, TOL, INIT, PHIR, PHII, ZETA1R,
|
||||
* ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI)
|
||||
IF (KODE.EQ.1) GO TO 10
|
||||
STR = ZR + ZETA2R
|
||||
STI = ZI + ZETA2I
|
||||
RAST = FN/ZABS(STR,STI)
|
||||
STR = STR*RAST*RAST
|
||||
STI = -STI*RAST*RAST
|
||||
S1R = -ZETA1R + STR
|
||||
S1I = -ZETA1I + STI
|
||||
GO TO 20
|
||||
10 CONTINUE
|
||||
S1R = -ZETA1R + ZETA2R
|
||||
S1I = -ZETA1I + ZETA2I
|
||||
20 CONTINUE
|
||||
RS1 = S1R
|
||||
IF (DABS(RS1).GT.ELIM) GO TO 130
|
||||
30 CONTINUE
|
||||
NN = MIN0(2,ND)
|
||||
DO 80 I=1,NN
|
||||
FN = FNU + DBLE(FLOAT(ND-I))
|
||||
INIT = 0
|
||||
CALL ZUNIK(ZR, ZI, FN, 1, 0, TOL, INIT, PHIR, PHII, ZETA1R,
|
||||
* ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI)
|
||||
IF (KODE.EQ.1) GO TO 40
|
||||
STR = ZR + ZETA2R
|
||||
STI = ZI + ZETA2I
|
||||
RAST = FN/ZABS(STR,STI)
|
||||
STR = STR*RAST*RAST
|
||||
STI = -STI*RAST*RAST
|
||||
S1R = -ZETA1R + STR
|
||||
S1I = -ZETA1I + STI + ZI
|
||||
GO TO 50
|
||||
40 CONTINUE
|
||||
S1R = -ZETA1R + ZETA2R
|
||||
S1I = -ZETA1I + ZETA2I
|
||||
50 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C TEST FOR UNDERFLOW AND OVERFLOW
|
||||
C-----------------------------------------------------------------------
|
||||
RS1 = S1R
|
||||
IF (DABS(RS1).GT.ELIM) GO TO 110
|
||||
IF (I.EQ.1) IFLAG = 2
|
||||
IF (DABS(RS1).LT.ALIM) GO TO 60
|
||||
C-----------------------------------------------------------------------
|
||||
C REFINE TEST AND SCALE
|
||||
C-----------------------------------------------------------------------
|
||||
APHI = ZABS(PHIR,PHII)
|
||||
RS1 = RS1 + DLOG(APHI)
|
||||
IF (DABS(RS1).GT.ELIM) GO TO 110
|
||||
IF (I.EQ.1) IFLAG = 1
|
||||
IF (RS1.LT.0.0D0) GO TO 60
|
||||
IF (I.EQ.1) IFLAG = 3
|
||||
60 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C SCALE S1 IF CABS(S1).LT.ASCLE
|
||||
C-----------------------------------------------------------------------
|
||||
S2R = PHIR*SUMR - PHII*SUMI
|
||||
S2I = PHIR*SUMI + PHII*SUMR
|
||||
STR = DEXP(S1R)*CSSR(IFLAG)
|
||||
S1R = STR*DCOS(S1I)
|
||||
S1I = STR*DSIN(S1I)
|
||||
STR = S2R*S1R - S2I*S1I
|
||||
S2I = S2R*S1I + S2I*S1R
|
||||
S2R = STR
|
||||
IF (IFLAG.NE.1) GO TO 70
|
||||
CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL)
|
||||
IF (NW.NE.0) GO TO 110
|
||||
70 CONTINUE
|
||||
CYR(I) = S2R
|
||||
CYI(I) = S2I
|
||||
M = ND - I + 1
|
||||
YR(M) = S2R*CSRR(IFLAG)
|
||||
YI(M) = S2I*CSRR(IFLAG)
|
||||
80 CONTINUE
|
||||
IF (ND.LE.2) GO TO 100
|
||||
RAST = 1.0D0/ZABS(ZR,ZI)
|
||||
STR = ZR*RAST
|
||||
STI = -ZI*RAST
|
||||
RZR = (STR+STR)*RAST
|
||||
RZI = (STI+STI)*RAST
|
||||
BRY(2) = 1.0D0/BRY(1)
|
||||
BRY(3) = D1MACH(2)
|
||||
S1R = CYR(1)
|
||||
S1I = CYI(1)
|
||||
S2R = CYR(2)
|
||||
S2I = CYI(2)
|
||||
C1R = CSRR(IFLAG)
|
||||
ASCLE = BRY(IFLAG)
|
||||
K = ND - 2
|
||||
FN = DBLE(FLOAT(K))
|
||||
DO 90 I=3,ND
|
||||
C2R = S2R
|
||||
C2I = S2I
|
||||
S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I)
|
||||
S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R)
|
||||
S1R = C2R
|
||||
S1I = C2I
|
||||
C2R = S2R*C1R
|
||||
C2I = S2I*C1R
|
||||
YR(K) = C2R
|
||||
YI(K) = C2I
|
||||
K = K - 1
|
||||
FN = FN - 1.0D0
|
||||
IF (IFLAG.GE.3) GO TO 90
|
||||
STR = DABS(C2R)
|
||||
STI = DABS(C2I)
|
||||
C2M = DMAX1(STR,STI)
|
||||
IF (C2M.LE.ASCLE) GO TO 90
|
||||
IFLAG = IFLAG + 1
|
||||
ASCLE = BRY(IFLAG)
|
||||
S1R = S1R*C1R
|
||||
S1I = S1I*C1R
|
||||
S2R = C2R
|
||||
S2I = C2I
|
||||
S1R = S1R*CSSR(IFLAG)
|
||||
S1I = S1I*CSSR(IFLAG)
|
||||
S2R = S2R*CSSR(IFLAG)
|
||||
S2I = S2I*CSSR(IFLAG)
|
||||
C1R = CSRR(IFLAG)
|
||||
90 CONTINUE
|
||||
100 CONTINUE
|
||||
RETURN
|
||||
C-----------------------------------------------------------------------
|
||||
C SET UNDERFLOW AND UPDATE PARAMETERS
|
||||
C-----------------------------------------------------------------------
|
||||
110 CONTINUE
|
||||
IF (RS1.GT.0.0D0) GO TO 120
|
||||
YR(ND) = ZEROR
|
||||
YI(ND) = ZEROI
|
||||
NZ = NZ + 1
|
||||
ND = ND - 1
|
||||
IF (ND.EQ.0) GO TO 100
|
||||
CALL ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM)
|
||||
IF (NUF.LT.0) GO TO 120
|
||||
ND = ND - NUF
|
||||
NZ = NZ + NUF
|
||||
IF (ND.EQ.0) GO TO 100
|
||||
FN = FNU + DBLE(FLOAT(ND-1))
|
||||
IF (FN.GE.FNUL) GO TO 30
|
||||
NLAST = ND
|
||||
RETURN
|
||||
120 CONTINUE
|
||||
NZ = -1
|
||||
RETURN
|
||||
130 CONTINUE
|
||||
IF (RS1.GT.0.0D0) GO TO 120
|
||||
NZ = N
|
||||
DO 140 I=1,N
|
||||
YR(I) = ZEROR
|
||||
YI(I) = ZEROI
|
||||
140 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,267 @@
|
|||
SUBROUTINE ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL,
|
||||
* TOL, ELIM, ALIM)
|
||||
C***BEGIN PROLOGUE ZUNI2
|
||||
C***REFER TO ZBESI,ZBESK
|
||||
C
|
||||
C ZUNI2 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF
|
||||
C UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I
|
||||
C OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO.
|
||||
C
|
||||
C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC
|
||||
C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET.
|
||||
C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER
|
||||
C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL.
|
||||
C Y(I)=CZERO FOR I=NLAST+1,N
|
||||
C
|
||||
C***ROUTINES CALLED ZAIRY,ZUCHK,ZUNHJ,ZUOIK,D1MACH,ZABS
|
||||
C***END PROLOGUE ZUNI2
|
||||
C COMPLEX AI,ARG,ASUM,BSUM,CFN,CI,CID,CIP,CONE,CRSC,CSCL,CSR,CSS,
|
||||
C *CZERO,C1,C2,DAI,PHI,RZ,S1,S2,Y,Z,ZB,ZETA1,ZETA2,ZN
|
||||
DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGI,
|
||||
* ARGR, ASCLE, ASUMI, ASUMR, BRY, BSUMI, BSUMR, CIDI, CIPI, CIPR,
|
||||
* CONER, CRSC, CSCL, CSRR, CSSR, C1R, C2I, C2M, C2R, DAII,
|
||||
* DAIR, ELIM, FN, FNU, FNUL, HPI, PHII, PHIR, RAST, RAZ, RS1, RZI,
|
||||
* RZR, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZBI, ZBR, ZEROI,
|
||||
* ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, ZNI, ZNR, ZR, CYR,
|
||||
* CYI, D1MACH, ZABS, CAR, SAR
|
||||
INTEGER I, IFLAG, IN, INU, J, K, KODE, N, NAI, ND, NDAI, NLAST,
|
||||
* NN, NUF, NW, NZ, IDUM
|
||||
DIMENSION BRY(3), YR(N), YI(N), CIPR(4), CIPI(4), CSSR(3),
|
||||
* CSRR(3), CYR(2), CYI(2)
|
||||
DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 /
|
||||
DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4),
|
||||
* CIPI(4)/ 1.0D0,0.0D0, 0.0D0,1.0D0, -1.0D0,0.0D0, 0.0D0,-1.0D0/
|
||||
DATA HPI, AIC /
|
||||
1 1.57079632679489662D+00, 1.265512123484645396D+00/
|
||||
C
|
||||
NZ = 0
|
||||
ND = N
|
||||
NLAST = 0
|
||||
C-----------------------------------------------------------------------
|
||||
C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG-
|
||||
C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE,
|
||||
C EXP(ALIM)=EXP(ELIM)*TOL
|
||||
C-----------------------------------------------------------------------
|
||||
CSCL = 1.0D0/TOL
|
||||
CRSC = TOL
|
||||
CSSR(1) = CSCL
|
||||
CSSR(2) = CONER
|
||||
CSSR(3) = CRSC
|
||||
CSRR(1) = CRSC
|
||||
CSRR(2) = CONER
|
||||
CSRR(3) = CSCL
|
||||
BRY(1) = 1.0D+3*D1MACH(1)/TOL
|
||||
C-----------------------------------------------------------------------
|
||||
C ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI
|
||||
C-----------------------------------------------------------------------
|
||||
ZNR = ZI
|
||||
ZNI = -ZR
|
||||
ZBR = ZR
|
||||
ZBI = ZI
|
||||
CIDI = -CONER
|
||||
INU = INT(SNGL(FNU))
|
||||
ANG = HPI*(FNU-DBLE(FLOAT(INU)))
|
||||
C2R = DCOS(ANG)
|
||||
C2I = DSIN(ANG)
|
||||
CAR = C2R
|
||||
SAR = C2I
|
||||
IN = INU + N - 1
|
||||
IN = MOD(IN,4) + 1
|
||||
STR = C2R*CIPR(IN) - C2I*CIPI(IN)
|
||||
C2I = C2R*CIPI(IN) + C2I*CIPR(IN)
|
||||
C2R = STR
|
||||
IF (ZI.GT.0.0D0) GO TO 10
|
||||
ZNR = -ZNR
|
||||
ZBI = -ZBI
|
||||
CIDI = -CIDI
|
||||
C2I = -C2I
|
||||
10 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER
|
||||
C-----------------------------------------------------------------------
|
||||
FN = DMAX1(FNU,1.0D0)
|
||||
CALL ZUNHJ(ZNR, ZNI, FN, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R,
|
||||
* ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI)
|
||||
IF (KODE.EQ.1) GO TO 20
|
||||
STR = ZBR + ZETA2R
|
||||
STI = ZBI + ZETA2I
|
||||
RAST = FN/ZABS(STR,STI)
|
||||
STR = STR*RAST*RAST
|
||||
STI = -STI*RAST*RAST
|
||||
S1R = -ZETA1R + STR
|
||||
S1I = -ZETA1I + STI
|
||||
GO TO 30
|
||||
20 CONTINUE
|
||||
S1R = -ZETA1R + ZETA2R
|
||||
S1I = -ZETA1I + ZETA2I
|
||||
30 CONTINUE
|
||||
RS1 = S1R
|
||||
IF (DABS(RS1).GT.ELIM) GO TO 150
|
||||
40 CONTINUE
|
||||
NN = MIN0(2,ND)
|
||||
DO 90 I=1,NN
|
||||
FN = FNU + DBLE(FLOAT(ND-I))
|
||||
CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR, PHII, ARGR, ARGI,
|
||||
* ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI)
|
||||
IF (KODE.EQ.1) GO TO 50
|
||||
STR = ZBR + ZETA2R
|
||||
STI = ZBI + ZETA2I
|
||||
RAST = FN/ZABS(STR,STI)
|
||||
STR = STR*RAST*RAST
|
||||
STI = -STI*RAST*RAST
|
||||
S1R = -ZETA1R + STR
|
||||
S1I = -ZETA1I + STI + DABS(ZI)
|
||||
GO TO 60
|
||||
50 CONTINUE
|
||||
S1R = -ZETA1R + ZETA2R
|
||||
S1I = -ZETA1I + ZETA2I
|
||||
60 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C TEST FOR UNDERFLOW AND OVERFLOW
|
||||
C-----------------------------------------------------------------------
|
||||
RS1 = S1R
|
||||
IF (DABS(RS1).GT.ELIM) GO TO 120
|
||||
IF (I.EQ.1) IFLAG = 2
|
||||
IF (DABS(RS1).LT.ALIM) GO TO 70
|
||||
C-----------------------------------------------------------------------
|
||||
C REFINE TEST AND SCALE
|
||||
C-----------------------------------------------------------------------
|
||||
C-----------------------------------------------------------------------
|
||||
APHI = ZABS(PHIR,PHII)
|
||||
AARG = ZABS(ARGR,ARGI)
|
||||
RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC
|
||||
IF (DABS(RS1).GT.ELIM) GO TO 120
|
||||
IF (I.EQ.1) IFLAG = 1
|
||||
IF (RS1.LT.0.0D0) GO TO 70
|
||||
IF (I.EQ.1) IFLAG = 3
|
||||
70 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR
|
||||
C EXPONENT EXTREMES
|
||||
C-----------------------------------------------------------------------
|
||||
CALL ZAIRY(ARGR, ARGI, 0, 2, AIR, AII, NAI, IDUM)
|
||||
CALL ZAIRY(ARGR, ARGI, 1, 2, DAIR, DAII, NDAI, IDUM)
|
||||
STR = DAIR*BSUMR - DAII*BSUMI
|
||||
STI = DAIR*BSUMI + DAII*BSUMR
|
||||
STR = STR + (AIR*ASUMR-AII*ASUMI)
|
||||
STI = STI + (AIR*ASUMI+AII*ASUMR)
|
||||
S2R = PHIR*STR - PHII*STI
|
||||
S2I = PHIR*STI + PHII*STR
|
||||
STR = DEXP(S1R)*CSSR(IFLAG)
|
||||
S1R = STR*DCOS(S1I)
|
||||
S1I = STR*DSIN(S1I)
|
||||
STR = S2R*S1R - S2I*S1I
|
||||
S2I = S2R*S1I + S2I*S1R
|
||||
S2R = STR
|
||||
IF (IFLAG.NE.1) GO TO 80
|
||||
CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL)
|
||||
IF (NW.NE.0) GO TO 120
|
||||
80 CONTINUE
|
||||
IF (ZI.LE.0.0D0) S2I = -S2I
|
||||
STR = S2R*C2R - S2I*C2I
|
||||
S2I = S2R*C2I + S2I*C2R
|
||||
S2R = STR
|
||||
CYR(I) = S2R
|
||||
CYI(I) = S2I
|
||||
J = ND - I + 1
|
||||
YR(J) = S2R*CSRR(IFLAG)
|
||||
YI(J) = S2I*CSRR(IFLAG)
|
||||
STR = -C2I*CIDI
|
||||
C2I = C2R*CIDI
|
||||
C2R = STR
|
||||
90 CONTINUE
|
||||
IF (ND.LE.2) GO TO 110
|
||||
RAZ = 1.0D0/ZABS(ZR,ZI)
|
||||
STR = ZR*RAZ
|
||||
STI = -ZI*RAZ
|
||||
RZR = (STR+STR)*RAZ
|
||||
RZI = (STI+STI)*RAZ
|
||||
BRY(2) = 1.0D0/BRY(1)
|
||||
BRY(3) = D1MACH(2)
|
||||
S1R = CYR(1)
|
||||
S1I = CYI(1)
|
||||
S2R = CYR(2)
|
||||
S2I = CYI(2)
|
||||
C1R = CSRR(IFLAG)
|
||||
ASCLE = BRY(IFLAG)
|
||||
K = ND - 2
|
||||
FN = DBLE(FLOAT(K))
|
||||
DO 100 I=3,ND
|
||||
C2R = S2R
|
||||
C2I = S2I
|
||||
S2R = S1R + (FNU+FN)*(RZR*C2R-RZI*C2I)
|
||||
S2I = S1I + (FNU+FN)*(RZR*C2I+RZI*C2R)
|
||||
S1R = C2R
|
||||
S1I = C2I
|
||||
C2R = S2R*C1R
|
||||
C2I = S2I*C1R
|
||||
YR(K) = C2R
|
||||
YI(K) = C2I
|
||||
K = K - 1
|
||||
FN = FN - 1.0D0
|
||||
IF (IFLAG.GE.3) GO TO 100
|
||||
STR = DABS(C2R)
|
||||
STI = DABS(C2I)
|
||||
C2M = DMAX1(STR,STI)
|
||||
IF (C2M.LE.ASCLE) GO TO 100
|
||||
IFLAG = IFLAG + 1
|
||||
ASCLE = BRY(IFLAG)
|
||||
S1R = S1R*C1R
|
||||
S1I = S1I*C1R
|
||||
S2R = C2R
|
||||
S2I = C2I
|
||||
S1R = S1R*CSSR(IFLAG)
|
||||
S1I = S1I*CSSR(IFLAG)
|
||||
S2R = S2R*CSSR(IFLAG)
|
||||
S2I = S2I*CSSR(IFLAG)
|
||||
C1R = CSRR(IFLAG)
|
||||
100 CONTINUE
|
||||
110 CONTINUE
|
||||
RETURN
|
||||
120 CONTINUE
|
||||
IF (RS1.GT.0.0D0) GO TO 140
|
||||
C-----------------------------------------------------------------------
|
||||
C SET UNDERFLOW AND UPDATE PARAMETERS
|
||||
C-----------------------------------------------------------------------
|
||||
YR(ND) = ZEROR
|
||||
YI(ND) = ZEROI
|
||||
NZ = NZ + 1
|
||||
ND = ND - 1
|
||||
IF (ND.EQ.0) GO TO 110
|
||||
CALL ZUOIK(ZR, ZI, FNU, KODE, 1, ND, YR, YI, NUF, TOL, ELIM, ALIM)
|
||||
IF (NUF.LT.0) GO TO 140
|
||||
ND = ND - NUF
|
||||
NZ = NZ + NUF
|
||||
IF (ND.EQ.0) GO TO 110
|
||||
FN = FNU + DBLE(FLOAT(ND-1))
|
||||
IF (FN.LT.FNUL) GO TO 130
|
||||
C FN = CIDI
|
||||
C J = NUF + 1
|
||||
C K = MOD(J,4) + 1
|
||||
C S1R = CIPR(K)
|
||||
C S1I = CIPI(K)
|
||||
C IF (FN.LT.0.0D0) S1I = -S1I
|
||||
C STR = C2R*S1R - C2I*S1I
|
||||
C C2I = C2R*S1I + C2I*S1R
|
||||
C C2R = STR
|
||||
IN = INU + ND - 1
|
||||
IN = MOD(IN,4) + 1
|
||||
C2R = CAR*CIPR(IN) - SAR*CIPI(IN)
|
||||
C2I = CAR*CIPI(IN) + SAR*CIPR(IN)
|
||||
IF (ZI.LE.0.0D0) C2I = -C2I
|
||||
GO TO 40
|
||||
130 CONTINUE
|
||||
NLAST = ND
|
||||
RETURN
|
||||
140 CONTINUE
|
||||
NZ = -1
|
||||
RETURN
|
||||
150 CONTINUE
|
||||
IF (RS1.GT.0.0D0) GO TO 140
|
||||
NZ = N
|
||||
DO 160 I=1,N
|
||||
YR(I) = ZEROR
|
||||
YI(I) = ZEROI
|
||||
160 CONTINUE
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,211 @@
|
|||
SUBROUTINE ZUNIK(ZRR, ZRI, FNU, IKFLG, IPMTR, TOL, INIT, PHIR,
|
||||
* PHII, ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI)
|
||||
C***BEGIN PROLOGUE ZUNIK
|
||||
C***REFER TO ZBESI,ZBESK
|
||||
C
|
||||
C ZUNIK COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC
|
||||
C EXPANSIONS OF THE I AND K FUNCTIONS ON IKFLG= 1 OR 2
|
||||
C RESPECTIVELY BY
|
||||
C
|
||||
C W(FNU,ZR) = PHI*EXP(ZETA)*SUM
|
||||
C
|
||||
C WHERE ZETA=-ZETA1 + ZETA2 OR
|
||||
C ZETA1 - ZETA2
|
||||
C
|
||||
C THE FIRST CALL MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE
|
||||
C SAME ZR AND FNU WILL RETURN THE I OR K FUNCTION ON IKFLG=
|
||||
C 1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK
|
||||
C ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI,
|
||||
C ZETA1,ZETA2.
|
||||
C
|
||||
C***ROUTINES CALLED ZDIV,ZLOG,ZSQRT,D1MACH
|
||||
C***END PROLOGUE ZUNIK
|
||||
C COMPLEX CFN,CON,CONE,CRFN,CWRK,CZERO,PHI,S,SR,SUM,T,T2,ZETA1,
|
||||
C *ZETA2,ZN,ZR
|
||||
DOUBLE PRECISION AC, C, CON, CONEI, CONER, CRFNI, CRFNR, CWRKI,
|
||||
* CWRKR, FNU, PHII, PHIR, RFN, SI, SR, SRI, SRR, STI, STR, SUMI,
|
||||
* SUMR, TEST, TI, TOL, TR, T2I, T2R, ZEROI, ZEROR, ZETA1I, ZETA1R,
|
||||
* ZETA2I, ZETA2R, ZNI, ZNR, ZRI, ZRR, D1MACH
|
||||
INTEGER I, IDUM, IKFLG, INIT, IPMTR, J, K, L
|
||||
DIMENSION C(120), CWRKR(16), CWRKI(16), CON(2)
|
||||
DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 /
|
||||
DATA CON(1), CON(2) /
|
||||
1 3.98942280401432678D-01, 1.25331413731550025D+00 /
|
||||
DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10),
|
||||
1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18),
|
||||
2 C(19), C(20), C(21), C(22), C(23), C(24)/
|
||||
3 1.00000000000000000D+00, -2.08333333333333333D-01,
|
||||
4 1.25000000000000000D-01, 3.34201388888888889D-01,
|
||||
5 -4.01041666666666667D-01, 7.03125000000000000D-02,
|
||||
6 -1.02581259645061728D+00, 1.84646267361111111D+00,
|
||||
7 -8.91210937500000000D-01, 7.32421875000000000D-02,
|
||||
8 4.66958442342624743D+00, -1.12070026162229938D+01,
|
||||
9 8.78912353515625000D+00, -2.36408691406250000D+00,
|
||||
A 1.12152099609375000D-01, -2.82120725582002449D+01,
|
||||
B 8.46362176746007346D+01, -9.18182415432400174D+01,
|
||||
C 4.25349987453884549D+01, -7.36879435947963170D+00,
|
||||
D 2.27108001708984375D-01, 2.12570130039217123D+02,
|
||||
E -7.65252468141181642D+02, 1.05999045252799988D+03/
|
||||
DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32),
|
||||
1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40),
|
||||
2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/
|
||||
3 -6.99579627376132541D+02, 2.18190511744211590D+02,
|
||||
4 -2.64914304869515555D+01, 5.72501420974731445D-01,
|
||||
5 -1.91945766231840700D+03, 8.06172218173730938D+03,
|
||||
6 -1.35865500064341374D+04, 1.16553933368645332D+04,
|
||||
7 -5.30564697861340311D+03, 1.20090291321635246D+03,
|
||||
8 -1.08090919788394656D+02, 1.72772750258445740D+00,
|
||||
9 2.02042913309661486D+04, -9.69805983886375135D+04,
|
||||
A 1.92547001232531532D+05, -2.03400177280415534D+05,
|
||||
B 1.22200464983017460D+05, -4.11926549688975513D+04,
|
||||
C 7.10951430248936372D+03, -4.93915304773088012D+02,
|
||||
D 6.07404200127348304D+00, -2.42919187900551333D+05,
|
||||
E 1.31176361466297720D+06, -2.99801591853810675D+06/
|
||||
DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56),
|
||||
1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64),
|
||||
2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/
|
||||
3 3.76327129765640400D+06, -2.81356322658653411D+06,
|
||||
4 1.26836527332162478D+06, -3.31645172484563578D+05,
|
||||
5 4.52187689813627263D+04, -2.49983048181120962D+03,
|
||||
6 2.43805296995560639D+01, 3.28446985307203782D+06,
|
||||
7 -1.97068191184322269D+07, 5.09526024926646422D+07,
|
||||
8 -7.41051482115326577D+07, 6.63445122747290267D+07,
|
||||
9 -3.75671766607633513D+07, 1.32887671664218183D+07,
|
||||
A -2.78561812808645469D+06, 3.08186404612662398D+05,
|
||||
B -1.38860897537170405D+04, 1.10017140269246738D+02,
|
||||
C -4.93292536645099620D+07, 3.25573074185765749D+08,
|
||||
D -9.39462359681578403D+08, 1.55359689957058006D+09,
|
||||
E -1.62108055210833708D+09, 1.10684281682301447D+09/
|
||||
DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80),
|
||||
1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88),
|
||||
2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/
|
||||
3 -4.95889784275030309D+08, 1.42062907797533095D+08,
|
||||
4 -2.44740627257387285D+07, 2.24376817792244943D+06,
|
||||
5 -8.40054336030240853D+04, 5.51335896122020586D+02,
|
||||
6 8.14789096118312115D+08, -5.86648149205184723D+09,
|
||||
7 1.86882075092958249D+10, -3.46320433881587779D+10,
|
||||
8 4.12801855797539740D+10, -3.30265997498007231D+10,
|
||||
9 1.79542137311556001D+10, -6.56329379261928433D+09,
|
||||
A 1.55927986487925751D+09, -2.25105661889415278D+08,
|
||||
B 1.73951075539781645D+07, -5.49842327572288687D+05,
|
||||
C 3.03809051092238427D+03, -1.46792612476956167D+10,
|
||||
D 1.14498237732025810D+11, -3.99096175224466498D+11,
|
||||
E 8.19218669548577329D+11, -1.09837515608122331D+12/
|
||||
DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104),
|
||||
1 C(105), C(106), C(107), C(108), C(109), C(110), C(111),
|
||||
2 C(112), C(113), C(114), C(115), C(116), C(117), C(118)/
|
||||
3 1.00815810686538209D+12, -6.45364869245376503D+11,
|
||||
4 2.87900649906150589D+11, -8.78670721780232657D+10,
|
||||
5 1.76347306068349694D+10, -2.16716498322379509D+09,
|
||||
6 1.43157876718888981D+08, -3.87183344257261262D+06,
|
||||
7 1.82577554742931747D+04, 2.86464035717679043D+11,
|
||||
8 -2.40629790002850396D+12, 9.10934118523989896D+12,
|
||||
9 -2.05168994109344374D+13, 3.05651255199353206D+13,
|
||||
A -3.16670885847851584D+13, 2.33483640445818409D+13,
|
||||
B -1.23204913055982872D+13, 4.61272578084913197D+12,
|
||||
C -1.19655288019618160D+12, 2.05914503232410016D+11,
|
||||
D -2.18229277575292237D+10, 1.24700929351271032D+09/
|
||||
DATA C(119), C(120)/
|
||||
1 -2.91883881222208134D+07, 1.18838426256783253D+05/
|
||||
C
|
||||
IF (INIT.NE.0) GO TO 40
|
||||
C-----------------------------------------------------------------------
|
||||
C INITIALIZE ALL VARIABLES
|
||||
C-----------------------------------------------------------------------
|
||||
RFN = 1.0D0/FNU
|
||||
C-----------------------------------------------------------------------
|
||||
C OVERFLOW TEST (ZR/FNU TOO SMALL)
|
||||
C-----------------------------------------------------------------------
|
||||
TEST = D1MACH(1)*1.0D+3
|
||||
AC = FNU*TEST
|
||||
IF (DABS(ZRR).GT.AC .OR. DABS(ZRI).GT.AC) GO TO 15
|
||||
ZETA1R = 2.0D0*DABS(DLOG(TEST))+FNU
|
||||
ZETA1I = 0.0D0
|
||||
ZETA2R = FNU
|
||||
ZETA2I = 0.0D0
|
||||
PHIR = 1.0D0
|
||||
PHII = 0.0D0
|
||||
RETURN
|
||||
15 CONTINUE
|
||||
TR = ZRR*RFN
|
||||
TI = ZRI*RFN
|
||||
SR = CONER + (TR*TR-TI*TI)
|
||||
SI = CONEI + (TR*TI+TI*TR)
|
||||
CALL ZSQRT(SR, SI, SRR, SRI)
|
||||
STR = CONER + SRR
|
||||
STI = CONEI + SRI
|
||||
CALL ZDIV(STR, STI, TR, TI, ZNR, ZNI)
|
||||
CALL ZLOG(ZNR, ZNI, STR, STI, IDUM)
|
||||
ZETA1R = FNU*STR
|
||||
ZETA1I = FNU*STI
|
||||
ZETA2R = FNU*SRR
|
||||
ZETA2I = FNU*SRI
|
||||
CALL ZDIV(CONER, CONEI, SRR, SRI, TR, TI)
|
||||
SRR = TR*RFN
|
||||
SRI = TI*RFN
|
||||
CALL ZSQRT(SRR, SRI, CWRKR(16), CWRKI(16))
|
||||
PHIR = CWRKR(16)*CON(IKFLG)
|
||||
PHII = CWRKI(16)*CON(IKFLG)
|
||||
IF (IPMTR.NE.0) RETURN
|
||||
CALL ZDIV(CONER, CONEI, SR, SI, T2R, T2I)
|
||||
CWRKR(1) = CONER
|
||||
CWRKI(1) = CONEI
|
||||
CRFNR = CONER
|
||||
CRFNI = CONEI
|
||||
AC = 1.0D0
|
||||
L = 1
|
||||
DO 20 K=2,15
|
||||
SR = ZEROR
|
||||
SI = ZEROI
|
||||
DO 10 J=1,K
|
||||
L = L + 1
|
||||
STR = SR*T2R - SI*T2I + C(L)
|
||||
SI = SR*T2I + SI*T2R
|
||||
SR = STR
|
||||
10 CONTINUE
|
||||
STR = CRFNR*SRR - CRFNI*SRI
|
||||
CRFNI = CRFNR*SRI + CRFNI*SRR
|
||||
CRFNR = STR
|
||||
CWRKR(K) = CRFNR*SR - CRFNI*SI
|
||||
CWRKI(K) = CRFNR*SI + CRFNI*SR
|
||||
AC = AC*RFN
|
||||
TEST = DABS(CWRKR(K)) + DABS(CWRKI(K))
|
||||
IF (AC.LT.TOL .AND. TEST.LT.TOL) GO TO 30
|
||||
20 CONTINUE
|
||||
K = 15
|
||||
30 CONTINUE
|
||||
INIT = K
|
||||
40 CONTINUE
|
||||
IF (IKFLG.EQ.2) GO TO 60
|
||||
C-----------------------------------------------------------------------
|
||||
C COMPUTE SUM FOR THE I FUNCTION
|
||||
C-----------------------------------------------------------------------
|
||||
SR = ZEROR
|
||||
SI = ZEROI
|
||||
DO 50 I=1,INIT
|
||||
SR = SR + CWRKR(I)
|
||||
SI = SI + CWRKI(I)
|
||||
50 CONTINUE
|
||||
SUMR = SR
|
||||
SUMI = SI
|
||||
PHIR = CWRKR(16)*CON(1)
|
||||
PHII = CWRKI(16)*CON(1)
|
||||
RETURN
|
||||
60 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C COMPUTE SUM FOR THE K FUNCTION
|
||||
C-----------------------------------------------------------------------
|
||||
SR = ZEROR
|
||||
SI = ZEROI
|
||||
TR = CONER
|
||||
DO 70 I=1,INIT
|
||||
SR = SR + TR*CWRKR(I)
|
||||
SI = SI + TR*CWRKI(I)
|
||||
TR = -TR
|
||||
70 CONTINUE
|
||||
SUMR = SR
|
||||
SUMI = SI
|
||||
PHIR = CWRKR(16)*CON(2)
|
||||
PHII = CWRKI(16)*CON(2)
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,426 @@
|
|||
SUBROUTINE ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM,
|
||||
* ALIM)
|
||||
C***BEGIN PROLOGUE ZUNK1
|
||||
C***REFER TO ZBESK
|
||||
C
|
||||
C ZUNK1 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE
|
||||
C RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE
|
||||
C UNIFORM ASYMPTOTIC EXPANSION.
|
||||
C MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION.
|
||||
C NZ=-1 MEANS AN OVERFLOW WILL OCCUR
|
||||
C
|
||||
C***ROUTINES CALLED ZKSCL,ZS1S2,ZUCHK,ZUNIK,D1MACH,ZABS
|
||||
C***END PROLOGUE ZUNK1
|
||||
C COMPLEX CFN,CK,CONE,CRSC,CS,CSCL,CSGN,CSPN,CSR,CSS,CWRK,CY,CZERO,
|
||||
C *C1,C2,PHI,PHID,RZ,SUM,SUMD,S1,S2,Y,Z,ZETA1,ZETA1D,ZETA2,ZETA2D,ZR
|
||||
DOUBLE PRECISION ALIM, ANG, APHI, ASC, ASCLE, BRY, CKI, CKR,
|
||||
* CONER, CRSC, CSCL, CSGNI, CSPNI, CSPNR, CSR, CSRR, CSSR,
|
||||
* CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2M, C2R, ELIM, FMR, FN,
|
||||
* FNF, FNU, PHIDI, PHIDR, PHII, PHIR, PI, RAST, RAZR, RS1, RZI,
|
||||
* RZR, SGN, STI, STR, SUMDI, SUMDR, SUMI, SUMR, S1I, S1R, S2I,
|
||||
* S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R,
|
||||
* ZET1DI, ZET1DR, ZET2DI, ZET2DR, ZI, ZR, ZRI, ZRR, D1MACH, ZABS
|
||||
INTEGER I, IB, IFLAG, IFN, IL, INIT, INU, IUF, K, KDFLG, KFLAG,
|
||||
* KK, KODE, MR, N, NW, NZ, INITD, IC, IPARD, J
|
||||
DIMENSION BRY(3), INIT(2), YR(N), YI(N), SUMR(2), SUMI(2),
|
||||
* ZETA1R(2), ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2),
|
||||
* CWRKR(16,3), CWRKI(16,3), CSSR(3), CSRR(3), PHIR(2), PHII(2)
|
||||
DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 /
|
||||
DATA PI / 3.14159265358979324D0 /
|
||||
C
|
||||
KDFLG = 1
|
||||
NZ = 0
|
||||
C-----------------------------------------------------------------------
|
||||
C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN
|
||||
C THE UNDERFLOW LIMIT
|
||||
C-----------------------------------------------------------------------
|
||||
CSCL = 1.0D0/TOL
|
||||
CRSC = TOL
|
||||
CSSR(1) = CSCL
|
||||
CSSR(2) = CONER
|
||||
CSSR(3) = CRSC
|
||||
CSRR(1) = CRSC
|
||||
CSRR(2) = CONER
|
||||
CSRR(3) = CSCL
|
||||
BRY(1) = 1.0D+3*D1MACH(1)/TOL
|
||||
BRY(2) = 1.0D0/BRY(1)
|
||||
BRY(3) = D1MACH(2)
|
||||
ZRR = ZR
|
||||
ZRI = ZI
|
||||
IF (ZR.GE.0.0D0) GO TO 10
|
||||
ZRR = -ZR
|
||||
ZRI = -ZI
|
||||
10 CONTINUE
|
||||
J = 2
|
||||
DO 70 I=1,N
|
||||
C-----------------------------------------------------------------------
|
||||
C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J
|
||||
C-----------------------------------------------------------------------
|
||||
J = 3 - J
|
||||
FN = FNU + DBLE(FLOAT(I-1))
|
||||
INIT(J) = 0
|
||||
CALL ZUNIK(ZRR, ZRI, FN, 2, 0, TOL, INIT(J), PHIR(J), PHII(J),
|
||||
* ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), SUMR(J), SUMI(J),
|
||||
* CWRKR(1,J), CWRKI(1,J))
|
||||
IF (KODE.EQ.1) GO TO 20
|
||||
STR = ZRR + ZETA2R(J)
|
||||
STI = ZRI + ZETA2I(J)
|
||||
RAST = FN/ZABS(STR,STI)
|
||||
STR = STR*RAST*RAST
|
||||
STI = -STI*RAST*RAST
|
||||
S1R = ZETA1R(J) - STR
|
||||
S1I = ZETA1I(J) - STI
|
||||
GO TO 30
|
||||
20 CONTINUE
|
||||
S1R = ZETA1R(J) - ZETA2R(J)
|
||||
S1I = ZETA1I(J) - ZETA2I(J)
|
||||
30 CONTINUE
|
||||
RS1 = S1R
|
||||
C-----------------------------------------------------------------------
|
||||
C TEST FOR UNDERFLOW AND OVERFLOW
|
||||
C-----------------------------------------------------------------------
|
||||
IF (DABS(RS1).GT.ELIM) GO TO 60
|
||||
IF (KDFLG.EQ.1) KFLAG = 2
|
||||
IF (DABS(RS1).LT.ALIM) GO TO 40
|
||||
C-----------------------------------------------------------------------
|
||||
C REFINE TEST AND SCALE
|
||||
C-----------------------------------------------------------------------
|
||||
APHI = ZABS(PHIR(J),PHII(J))
|
||||
RS1 = RS1 + DLOG(APHI)
|
||||
IF (DABS(RS1).GT.ELIM) GO TO 60
|
||||
IF (KDFLG.EQ.1) KFLAG = 1
|
||||
IF (RS1.LT.0.0D0) GO TO 40
|
||||
IF (KDFLG.EQ.1) KFLAG = 3
|
||||
40 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR
|
||||
C EXPONENT EXTREMES
|
||||
C-----------------------------------------------------------------------
|
||||
S2R = PHIR(J)*SUMR(J) - PHII(J)*SUMI(J)
|
||||
S2I = PHIR(J)*SUMI(J) + PHII(J)*SUMR(J)
|
||||
STR = DEXP(S1R)*CSSR(KFLAG)
|
||||
S1R = STR*DCOS(S1I)
|
||||
S1I = STR*DSIN(S1I)
|
||||
STR = S2R*S1R - S2I*S1I
|
||||
S2I = S1R*S2I + S2R*S1I
|
||||
S2R = STR
|
||||
IF (KFLAG.NE.1) GO TO 50
|
||||
CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL)
|
||||
IF (NW.NE.0) GO TO 60
|
||||
50 CONTINUE
|
||||
CYR(KDFLG) = S2R
|
||||
CYI(KDFLG) = S2I
|
||||
YR(I) = S2R*CSRR(KFLAG)
|
||||
YI(I) = S2I*CSRR(KFLAG)
|
||||
IF (KDFLG.EQ.2) GO TO 75
|
||||
KDFLG = 2
|
||||
GO TO 70
|
||||
60 CONTINUE
|
||||
IF (RS1.GT.0.0D0) GO TO 300
|
||||
C-----------------------------------------------------------------------
|
||||
C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW
|
||||
C-----------------------------------------------------------------------
|
||||
IF (ZR.LT.0.0D0) GO TO 300
|
||||
KDFLG = 1
|
||||
YR(I)=ZEROR
|
||||
YI(I)=ZEROI
|
||||
NZ=NZ+1
|
||||
IF (I.EQ.1) GO TO 70
|
||||
IF ((YR(I-1).EQ.ZEROR).AND.(YI(I-1).EQ.ZEROI)) GO TO 70
|
||||
YR(I-1)=ZEROR
|
||||
YI(I-1)=ZEROI
|
||||
NZ=NZ+1
|
||||
70 CONTINUE
|
||||
I = N
|
||||
75 CONTINUE
|
||||
RAZR = 1.0D0/ZABS(ZRR,ZRI)
|
||||
STR = ZRR*RAZR
|
||||
STI = -ZRI*RAZR
|
||||
RZR = (STR+STR)*RAZR
|
||||
RZI = (STI+STI)*RAZR
|
||||
CKR = FN*RZR
|
||||
CKI = FN*RZI
|
||||
IB = I + 1
|
||||
IF (N.LT.IB) GO TO 160
|
||||
C-----------------------------------------------------------------------
|
||||
C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO
|
||||
C ON UNDERFLOW.
|
||||
C-----------------------------------------------------------------------
|
||||
FN = FNU + DBLE(FLOAT(N-1))
|
||||
IPARD = 1
|
||||
IF (MR.NE.0) IPARD = 0
|
||||
INITD = 0
|
||||
CALL ZUNIK(ZRR, ZRI, FN, 2, IPARD, TOL, INITD, PHIDR, PHIDI,
|
||||
* ZET1DR, ZET1DI, ZET2DR, ZET2DI, SUMDR, SUMDI, CWRKR(1,3),
|
||||
* CWRKI(1,3))
|
||||
IF (KODE.EQ.1) GO TO 80
|
||||
STR = ZRR + ZET2DR
|
||||
STI = ZRI + ZET2DI
|
||||
RAST = FN/ZABS(STR,STI)
|
||||
STR = STR*RAST*RAST
|
||||
STI = -STI*RAST*RAST
|
||||
S1R = ZET1DR - STR
|
||||
S1I = ZET1DI - STI
|
||||
GO TO 90
|
||||
80 CONTINUE
|
||||
S1R = ZET1DR - ZET2DR
|
||||
S1I = ZET1DI - ZET2DI
|
||||
90 CONTINUE
|
||||
RS1 = S1R
|
||||
IF (DABS(RS1).GT.ELIM) GO TO 95
|
||||
IF (DABS(RS1).LT.ALIM) GO TO 100
|
||||
C----------------------------------------------------------------------------
|
||||
C REFINE ESTIMATE AND TEST
|
||||
C-------------------------------------------------------------------------
|
||||
APHI = ZABS(PHIDR,PHIDI)
|
||||
RS1 = RS1+DLOG(APHI)
|
||||
IF (DABS(RS1).LT.ELIM) GO TO 100
|
||||
95 CONTINUE
|
||||
IF (DABS(RS1).GT.0.0D0) GO TO 300
|
||||
C-----------------------------------------------------------------------
|
||||
C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW
|
||||
C-----------------------------------------------------------------------
|
||||
IF (ZR.LT.0.0D0) GO TO 300
|
||||
NZ = N
|
||||
DO 96 I=1,N
|
||||
YR(I) = ZEROR
|
||||
YI(I) = ZEROI
|
||||
96 CONTINUE
|
||||
RETURN
|
||||
C---------------------------------------------------------------------------
|
||||
C FORWARD RECUR FOR REMAINDER OF THE SEQUENCE
|
||||
C----------------------------------------------------------------------------
|
||||
100 CONTINUE
|
||||
S1R = CYR(1)
|
||||
S1I = CYI(1)
|
||||
S2R = CYR(2)
|
||||
S2I = CYI(2)
|
||||
C1R = CSRR(KFLAG)
|
||||
ASCLE = BRY(KFLAG)
|
||||
DO 120 I=IB,N
|
||||
C2R = S2R
|
||||
C2I = S2I
|
||||
S2R = CKR*C2R - CKI*C2I + S1R
|
||||
S2I = CKR*C2I + CKI*C2R + S1I
|
||||
S1R = C2R
|
||||
S1I = C2I
|
||||
CKR = CKR + RZR
|
||||
CKI = CKI + RZI
|
||||
C2R = S2R*C1R
|
||||
C2I = S2I*C1R
|
||||
YR(I) = C2R
|
||||
YI(I) = C2I
|
||||
IF (KFLAG.GE.3) GO TO 120
|
||||
STR = DABS(C2R)
|
||||
STI = DABS(C2I)
|
||||
C2M = DMAX1(STR,STI)
|
||||
IF (C2M.LE.ASCLE) GO TO 120
|
||||
KFLAG = KFLAG + 1
|
||||
ASCLE = BRY(KFLAG)
|
||||
S1R = S1R*C1R
|
||||
S1I = S1I*C1R
|
||||
S2R = C2R
|
||||
S2I = C2I
|
||||
S1R = S1R*CSSR(KFLAG)
|
||||
S1I = S1I*CSSR(KFLAG)
|
||||
S2R = S2R*CSSR(KFLAG)
|
||||
S2I = S2I*CSSR(KFLAG)
|
||||
C1R = CSRR(KFLAG)
|
||||
120 CONTINUE
|
||||
160 CONTINUE
|
||||
IF (MR.EQ.0) RETURN
|
||||
C-----------------------------------------------------------------------
|
||||
C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0
|
||||
C-----------------------------------------------------------------------
|
||||
NZ = 0
|
||||
FMR = DBLE(FLOAT(MR))
|
||||
SGN = -DSIGN(PI,FMR)
|
||||
C-----------------------------------------------------------------------
|
||||
C CSPN AND CSGN ARE COEFF OF K AND I FUNCTIONS RESP.
|
||||
C-----------------------------------------------------------------------
|
||||
CSGNI = SGN
|
||||
INU = INT(SNGL(FNU))
|
||||
FNF = FNU - DBLE(FLOAT(INU))
|
||||
IFN = INU + N - 1
|
||||
ANG = FNF*SGN
|
||||
CSPNR = DCOS(ANG)
|
||||
CSPNI = DSIN(ANG)
|
||||
IF (MOD(IFN,2).EQ.0) GO TO 170
|
||||
CSPNR = -CSPNR
|
||||
CSPNI = -CSPNI
|
||||
170 CONTINUE
|
||||
ASC = BRY(1)
|
||||
IUF = 0
|
||||
KK = N
|
||||
KDFLG = 1
|
||||
IB = IB - 1
|
||||
IC = IB - 1
|
||||
DO 270 K=1,N
|
||||
FN = FNU + DBLE(FLOAT(KK-1))
|
||||
C-----------------------------------------------------------------------
|
||||
C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K
|
||||
C FUNCTION ABOVE
|
||||
C-----------------------------------------------------------------------
|
||||
M=3
|
||||
IF (N.GT.2) GO TO 175
|
||||
172 CONTINUE
|
||||
INITD = INIT(J)
|
||||
PHIDR = PHIR(J)
|
||||
PHIDI = PHII(J)
|
||||
ZET1DR = ZETA1R(J)
|
||||
ZET1DI = ZETA1I(J)
|
||||
ZET2DR = ZETA2R(J)
|
||||
ZET2DI = ZETA2I(J)
|
||||
SUMDR = SUMR(J)
|
||||
SUMDI = SUMI(J)
|
||||
M = J
|
||||
J = 3 - J
|
||||
GO TO 180
|
||||
175 CONTINUE
|
||||
IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 180
|
||||
IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 172
|
||||
INITD = 0
|
||||
180 CONTINUE
|
||||
CALL ZUNIK(ZRR, ZRI, FN, 1, 0, TOL, INITD, PHIDR, PHIDI,
|
||||
* ZET1DR, ZET1DI, ZET2DR, ZET2DI, SUMDR, SUMDI,
|
||||
* CWRKR(1,M), CWRKI(1,M))
|
||||
IF (KODE.EQ.1) GO TO 200
|
||||
STR = ZRR + ZET2DR
|
||||
STI = ZRI + ZET2DI
|
||||
RAST = FN/ZABS(STR,STI)
|
||||
STR = STR*RAST*RAST
|
||||
STI = -STI*RAST*RAST
|
||||
S1R = -ZET1DR + STR
|
||||
S1I = -ZET1DI + STI
|
||||
GO TO 210
|
||||
200 CONTINUE
|
||||
S1R = -ZET1DR + ZET2DR
|
||||
S1I = -ZET1DI + ZET2DI
|
||||
210 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C TEST FOR UNDERFLOW AND OVERFLOW
|
||||
C-----------------------------------------------------------------------
|
||||
RS1 = S1R
|
||||
IF (DABS(RS1).GT.ELIM) GO TO 260
|
||||
IF (KDFLG.EQ.1) IFLAG = 2
|
||||
IF (DABS(RS1).LT.ALIM) GO TO 220
|
||||
C-----------------------------------------------------------------------
|
||||
C REFINE TEST AND SCALE
|
||||
C-----------------------------------------------------------------------
|
||||
APHI = ZABS(PHIDR,PHIDI)
|
||||
RS1 = RS1 + DLOG(APHI)
|
||||
IF (DABS(RS1).GT.ELIM) GO TO 260
|
||||
IF (KDFLG.EQ.1) IFLAG = 1
|
||||
IF (RS1.LT.0.0D0) GO TO 220
|
||||
IF (KDFLG.EQ.1) IFLAG = 3
|
||||
220 CONTINUE
|
||||
STR = PHIDR*SUMDR - PHIDI*SUMDI
|
||||
STI = PHIDR*SUMDI + PHIDI*SUMDR
|
||||
S2R = -CSGNI*STI
|
||||
S2I = CSGNI*STR
|
||||
STR = DEXP(S1R)*CSSR(IFLAG)
|
||||
S1R = STR*DCOS(S1I)
|
||||
S1I = STR*DSIN(S1I)
|
||||
STR = S2R*S1R - S2I*S1I
|
||||
S2I = S2R*S1I + S2I*S1R
|
||||
S2R = STR
|
||||
IF (IFLAG.NE.1) GO TO 230
|
||||
CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL)
|
||||
IF (NW.EQ.0) GO TO 230
|
||||
S2R = ZEROR
|
||||
S2I = ZEROI
|
||||
230 CONTINUE
|
||||
CYR(KDFLG) = S2R
|
||||
CYI(KDFLG) = S2I
|
||||
C2R = S2R
|
||||
C2I = S2I
|
||||
S2R = S2R*CSRR(IFLAG)
|
||||
S2I = S2I*CSRR(IFLAG)
|
||||
C-----------------------------------------------------------------------
|
||||
C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N
|
||||
C-----------------------------------------------------------------------
|
||||
S1R = YR(KK)
|
||||
S1I = YI(KK)
|
||||
IF (KODE.EQ.1) GO TO 250
|
||||
CALL ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NW, ASC, ALIM, IUF)
|
||||
NZ = NZ + NW
|
||||
250 CONTINUE
|
||||
YR(KK) = S1R*CSPNR - S1I*CSPNI + S2R
|
||||
YI(KK) = CSPNR*S1I + CSPNI*S1R + S2I
|
||||
KK = KK - 1
|
||||
CSPNR = -CSPNR
|
||||
CSPNI = -CSPNI
|
||||
IF (C2R.NE.0.0D0 .OR. C2I.NE.0.0D0) GO TO 255
|
||||
KDFLG = 1
|
||||
GO TO 270
|
||||
255 CONTINUE
|
||||
IF (KDFLG.EQ.2) GO TO 275
|
||||
KDFLG = 2
|
||||
GO TO 270
|
||||
260 CONTINUE
|
||||
IF (RS1.GT.0.0D0) GO TO 300
|
||||
S2R = ZEROR
|
||||
S2I = ZEROI
|
||||
GO TO 230
|
||||
270 CONTINUE
|
||||
K = N
|
||||
275 CONTINUE
|
||||
IL = N - K
|
||||
IF (IL.EQ.0) RETURN
|
||||
C-----------------------------------------------------------------------
|
||||
C RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE
|
||||
C K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP
|
||||
C INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES.
|
||||
C-----------------------------------------------------------------------
|
||||
S1R = CYR(1)
|
||||
S1I = CYI(1)
|
||||
S2R = CYR(2)
|
||||
S2I = CYI(2)
|
||||
CSR = CSRR(IFLAG)
|
||||
ASCLE = BRY(IFLAG)
|
||||
FN = DBLE(FLOAT(INU+IL))
|
||||
DO 290 I=1,IL
|
||||
C2R = S2R
|
||||
C2I = S2I
|
||||
S2R = S1R + (FN+FNF)*(RZR*C2R-RZI*C2I)
|
||||
S2I = S1I + (FN+FNF)*(RZR*C2I+RZI*C2R)
|
||||
S1R = C2R
|
||||
S1I = C2I
|
||||
FN = FN - 1.0D0
|
||||
C2R = S2R*CSR
|
||||
C2I = S2I*CSR
|
||||
CKR = C2R
|
||||
CKI = C2I
|
||||
C1R = YR(KK)
|
||||
C1I = YI(KK)
|
||||
IF (KODE.EQ.1) GO TO 280
|
||||
CALL ZS1S2(ZRR, ZRI, C1R, C1I, C2R, C2I, NW, ASC, ALIM, IUF)
|
||||
NZ = NZ + NW
|
||||
280 CONTINUE
|
||||
YR(KK) = C1R*CSPNR - C1I*CSPNI + C2R
|
||||
YI(KK) = C1R*CSPNI + C1I*CSPNR + C2I
|
||||
KK = KK - 1
|
||||
CSPNR = -CSPNR
|
||||
CSPNI = -CSPNI
|
||||
IF (IFLAG.GE.3) GO TO 290
|
||||
C2R = DABS(CKR)
|
||||
C2I = DABS(CKI)
|
||||
C2M = DMAX1(C2R,C2I)
|
||||
IF (C2M.LE.ASCLE) GO TO 290
|
||||
IFLAG = IFLAG + 1
|
||||
ASCLE = BRY(IFLAG)
|
||||
S1R = S1R*CSR
|
||||
S1I = S1I*CSR
|
||||
S2R = CKR
|
||||
S2I = CKI
|
||||
S1R = S1R*CSSR(IFLAG)
|
||||
S1I = S1I*CSSR(IFLAG)
|
||||
S2R = S2R*CSSR(IFLAG)
|
||||
S2I = S2I*CSSR(IFLAG)
|
||||
CSR = CSRR(IFLAG)
|
||||
290 CONTINUE
|
||||
RETURN
|
||||
300 CONTINUE
|
||||
NZ = -1
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,505 @@
|
|||
SUBROUTINE ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM,
|
||||
* ALIM)
|
||||
C***BEGIN PROLOGUE ZUNK2
|
||||
C***REFER TO ZBESK
|
||||
C
|
||||
C ZUNK2 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE
|
||||
C RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE
|
||||
C UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN)
|
||||
C WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR
|
||||
C -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z IF Z IS IN THE RIGHT
|
||||
C HALF PLANE OR ZR=-Z IF Z IS IN THE LEFT HALF PLANE. MR INDIC-
|
||||
C ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION.
|
||||
C NZ=-1 MEANS AN OVERFLOW WILL OCCUR
|
||||
C
|
||||
C***ROUTINES CALLED ZAIRY,ZKSCL,ZS1S2,ZUCHK,ZUNHJ,D1MACH,ZABS
|
||||
C***END PROLOGUE ZUNK2
|
||||
C COMPLEX AI,ARG,ARGD,ASUM,ASUMD,BSUM,BSUMD,CFN,CI,CIP,CK,CONE,CRSC,
|
||||
C *CR1,CR2,CS,CSCL,CSGN,CSPN,CSR,CSS,CY,CZERO,C1,C2,DAI,PHI,PHID,RZ,
|
||||
C *S1,S2,Y,Z,ZB,ZETA1,ZETA1D,ZETA2,ZETA2D,ZN,ZR
|
||||
DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGDI,
|
||||
* ARGDR, ARGI, ARGR, ASC, ASCLE, ASUMDI, ASUMDR, ASUMI, ASUMR,
|
||||
* BRY, BSUMDI, BSUMDR, BSUMI, BSUMR, CAR, CIPI, CIPR, CKI, CKR,
|
||||
* CONER, CRSC, CR1I, CR1R, CR2I, CR2R, CSCL, CSGNI, CSI,
|
||||
* CSPNI, CSPNR, CSR, CSRR, CSSR, CYI, CYR, C1I, C1R, C2I, C2M,
|
||||
* C2R, DAII, DAIR, ELIM, FMR, FN, FNF, FNU, HPI, PHIDI, PHIDR,
|
||||
* PHII, PHIR, PI, PTI, PTR, RAST, RAZR, RS1, RZI, RZR, SAR, SGN,
|
||||
* STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, YY, ZBI, ZBR, ZEROI,
|
||||
* ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZET1DI, ZET1DR, ZET2DI,
|
||||
* ZET2DR, ZI, ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS
|
||||
INTEGER I, IB, IFLAG, IFN, IL, IN, INU, IUF, K, KDFLG, KFLAG, KK,
|
||||
* KODE, MR, N, NAI, NDAI, NW, NZ, IDUM, J, IPARD, IC
|
||||
DIMENSION BRY(3), YR(N), YI(N), ASUMR(2), ASUMI(2), BSUMR(2),
|
||||
* BSUMI(2), PHIR(2), PHII(2), ARGR(2), ARGI(2), ZETA1R(2),
|
||||
* ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2), CIPR(4),
|
||||
* CIPI(4), CSSR(3), CSRR(3)
|
||||
DATA ZEROR,ZEROI,CONER,CR1R,CR1I,CR2R,CR2I /
|
||||
1 0.0D0, 0.0D0, 1.0D0,
|
||||
1 1.0D0,1.73205080756887729D0 , -0.5D0,-8.66025403784438647D-01 /
|
||||
DATA HPI, PI, AIC /
|
||||
1 1.57079632679489662D+00, 3.14159265358979324D+00,
|
||||
1 1.26551212348464539D+00/
|
||||
DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4),
|
||||
* CIPI(4) /
|
||||
1 1.0D0,0.0D0 , 0.0D0,-1.0D0 , -1.0D0,0.0D0 , 0.0D0,1.0D0 /
|
||||
C
|
||||
KDFLG = 1
|
||||
NZ = 0
|
||||
C-----------------------------------------------------------------------
|
||||
C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN
|
||||
C THE UNDERFLOW LIMIT
|
||||
C-----------------------------------------------------------------------
|
||||
CSCL = 1.0D0/TOL
|
||||
CRSC = TOL
|
||||
CSSR(1) = CSCL
|
||||
CSSR(2) = CONER
|
||||
CSSR(3) = CRSC
|
||||
CSRR(1) = CRSC
|
||||
CSRR(2) = CONER
|
||||
CSRR(3) = CSCL
|
||||
BRY(1) = 1.0D+3*D1MACH(1)/TOL
|
||||
BRY(2) = 1.0D0/BRY(1)
|
||||
BRY(3) = D1MACH(2)
|
||||
ZRR = ZR
|
||||
ZRI = ZI
|
||||
IF (ZR.GE.0.0D0) GO TO 10
|
||||
ZRR = -ZR
|
||||
ZRI = -ZI
|
||||
10 CONTINUE
|
||||
YY = ZRI
|
||||
ZNR = ZRI
|
||||
ZNI = -ZRR
|
||||
ZBR = ZRR
|
||||
ZBI = ZRI
|
||||
INU = INT(SNGL(FNU))
|
||||
FNF = FNU - DBLE(FLOAT(INU))
|
||||
ANG = -HPI*FNF
|
||||
CAR = DCOS(ANG)
|
||||
SAR = DSIN(ANG)
|
||||
C2R = HPI*SAR
|
||||
C2I = -HPI*CAR
|
||||
KK = MOD(INU,4) + 1
|
||||
STR = C2R*CIPR(KK) - C2I*CIPI(KK)
|
||||
STI = C2R*CIPI(KK) + C2I*CIPR(KK)
|
||||
CSR = CR1R*STR - CR1I*STI
|
||||
CSI = CR1R*STI + CR1I*STR
|
||||
IF (YY.GT.0.0D0) GO TO 20
|
||||
ZNR = -ZNR
|
||||
ZBI = -ZBI
|
||||
20 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST
|
||||
C QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY
|
||||
C CONJUGATION SINCE THE K FUNCTION IS REAL ON THE POSITIVE REAL AXIS
|
||||
C-----------------------------------------------------------------------
|
||||
J = 2
|
||||
DO 80 I=1,N
|
||||
C-----------------------------------------------------------------------
|
||||
C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J
|
||||
C-----------------------------------------------------------------------
|
||||
J = 3 - J
|
||||
FN = FNU + DBLE(FLOAT(I-1))
|
||||
CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR(J), PHII(J), ARGR(J),
|
||||
* ARGI(J), ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), ASUMR(J),
|
||||
* ASUMI(J), BSUMR(J), BSUMI(J))
|
||||
IF (KODE.EQ.1) GO TO 30
|
||||
STR = ZBR + ZETA2R(J)
|
||||
STI = ZBI + ZETA2I(J)
|
||||
RAST = FN/ZABS(STR,STI)
|
||||
STR = STR*RAST*RAST
|
||||
STI = -STI*RAST*RAST
|
||||
S1R = ZETA1R(J) - STR
|
||||
S1I = ZETA1I(J) - STI
|
||||
GO TO 40
|
||||
30 CONTINUE
|
||||
S1R = ZETA1R(J) - ZETA2R(J)
|
||||
S1I = ZETA1I(J) - ZETA2I(J)
|
||||
40 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C TEST FOR UNDERFLOW AND OVERFLOW
|
||||
C-----------------------------------------------------------------------
|
||||
RS1 = S1R
|
||||
IF (DABS(RS1).GT.ELIM) GO TO 70
|
||||
IF (KDFLG.EQ.1) KFLAG = 2
|
||||
IF (DABS(RS1).LT.ALIM) GO TO 50
|
||||
C-----------------------------------------------------------------------
|
||||
C REFINE TEST AND SCALE
|
||||
C-----------------------------------------------------------------------
|
||||
APHI = ZABS(PHIR(J),PHII(J))
|
||||
AARG = ZABS(ARGR(J),ARGI(J))
|
||||
RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC
|
||||
IF (DABS(RS1).GT.ELIM) GO TO 70
|
||||
IF (KDFLG.EQ.1) KFLAG = 1
|
||||
IF (RS1.LT.0.0D0) GO TO 50
|
||||
IF (KDFLG.EQ.1) KFLAG = 3
|
||||
50 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C SCALE S1 TO KEEP INTERMEDIATE ARITHMETIC ON SCALE NEAR
|
||||
C EXPONENT EXTREMES
|
||||
C-----------------------------------------------------------------------
|
||||
C2R = ARGR(J)*CR2R - ARGI(J)*CR2I
|
||||
C2I = ARGR(J)*CR2I + ARGI(J)*CR2R
|
||||
CALL ZAIRY(C2R, C2I, 0, 2, AIR, AII, NAI, IDUM)
|
||||
CALL ZAIRY(C2R, C2I, 1, 2, DAIR, DAII, NDAI, IDUM)
|
||||
STR = DAIR*BSUMR(J) - DAII*BSUMI(J)
|
||||
STI = DAIR*BSUMI(J) + DAII*BSUMR(J)
|
||||
PTR = STR*CR2R - STI*CR2I
|
||||
PTI = STR*CR2I + STI*CR2R
|
||||
STR = PTR + (AIR*ASUMR(J)-AII*ASUMI(J))
|
||||
STI = PTI + (AIR*ASUMI(J)+AII*ASUMR(J))
|
||||
PTR = STR*PHIR(J) - STI*PHII(J)
|
||||
PTI = STR*PHII(J) + STI*PHIR(J)
|
||||
S2R = PTR*CSR - PTI*CSI
|
||||
S2I = PTR*CSI + PTI*CSR
|
||||
STR = DEXP(S1R)*CSSR(KFLAG)
|
||||
S1R = STR*DCOS(S1I)
|
||||
S1I = STR*DSIN(S1I)
|
||||
STR = S2R*S1R - S2I*S1I
|
||||
S2I = S1R*S2I + S2R*S1I
|
||||
S2R = STR
|
||||
IF (KFLAG.NE.1) GO TO 60
|
||||
CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL)
|
||||
IF (NW.NE.0) GO TO 70
|
||||
60 CONTINUE
|
||||
IF (YY.LE.0.0D0) S2I = -S2I
|
||||
CYR(KDFLG) = S2R
|
||||
CYI(KDFLG) = S2I
|
||||
YR(I) = S2R*CSRR(KFLAG)
|
||||
YI(I) = S2I*CSRR(KFLAG)
|
||||
STR = CSI
|
||||
CSI = -CSR
|
||||
CSR = STR
|
||||
IF (KDFLG.EQ.2) GO TO 85
|
||||
KDFLG = 2
|
||||
GO TO 80
|
||||
70 CONTINUE
|
||||
IF (RS1.GT.0.0D0) GO TO 320
|
||||
C-----------------------------------------------------------------------
|
||||
C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW
|
||||
C-----------------------------------------------------------------------
|
||||
IF (ZR.LT.0.0D0) GO TO 320
|
||||
KDFLG = 1
|
||||
YR(I)=ZEROR
|
||||
YI(I)=ZEROI
|
||||
NZ=NZ+1
|
||||
STR = CSI
|
||||
CSI =-CSR
|
||||
CSR = STR
|
||||
IF (I.EQ.1) GO TO 80
|
||||
IF ((YR(I-1).EQ.ZEROR).AND.(YI(I-1).EQ.ZEROI)) GO TO 80
|
||||
YR(I-1)=ZEROR
|
||||
YI(I-1)=ZEROI
|
||||
NZ=NZ+1
|
||||
80 CONTINUE
|
||||
I = N
|
||||
85 CONTINUE
|
||||
RAZR = 1.0D0/ZABS(ZRR,ZRI)
|
||||
STR = ZRR*RAZR
|
||||
STI = -ZRI*RAZR
|
||||
RZR = (STR+STR)*RAZR
|
||||
RZI = (STI+STI)*RAZR
|
||||
CKR = FN*RZR
|
||||
CKI = FN*RZI
|
||||
IB = I + 1
|
||||
IF (N.LT.IB) GO TO 180
|
||||
C-----------------------------------------------------------------------
|
||||
C TEST LAST MEMBER FOR UNDERFLOW AND OVERFLOW. SET SEQUENCE TO ZERO
|
||||
C ON UNDERFLOW.
|
||||
C-----------------------------------------------------------------------
|
||||
FN = FNU + DBLE(FLOAT(N-1))
|
||||
IPARD = 1
|
||||
IF (MR.NE.0) IPARD = 0
|
||||
CALL ZUNHJ(ZNR, ZNI, FN, IPARD, TOL, PHIDR, PHIDI, ARGDR, ARGDI,
|
||||
* ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR, ASUMDI, BSUMDR, BSUMDI)
|
||||
IF (KODE.EQ.1) GO TO 90
|
||||
STR = ZBR + ZET2DR
|
||||
STI = ZBI + ZET2DI
|
||||
RAST = FN/ZABS(STR,STI)
|
||||
STR = STR*RAST*RAST
|
||||
STI = -STI*RAST*RAST
|
||||
S1R = ZET1DR - STR
|
||||
S1I = ZET1DI - STI
|
||||
GO TO 100
|
||||
90 CONTINUE
|
||||
S1R = ZET1DR - ZET2DR
|
||||
S1I = ZET1DI - ZET2DI
|
||||
100 CONTINUE
|
||||
RS1 = S1R
|
||||
IF (DABS(RS1).GT.ELIM) GO TO 105
|
||||
IF (DABS(RS1).LT.ALIM) GO TO 120
|
||||
C----------------------------------------------------------------------------
|
||||
C REFINE ESTIMATE AND TEST
|
||||
C-------------------------------------------------------------------------
|
||||
APHI = ZABS(PHIDR,PHIDI)
|
||||
RS1 = RS1+DLOG(APHI)
|
||||
IF (DABS(RS1).LT.ELIM) GO TO 120
|
||||
105 CONTINUE
|
||||
IF (RS1.GT.0.0D0) GO TO 320
|
||||
C-----------------------------------------------------------------------
|
||||
C FOR ZR.LT.0.0, THE I FUNCTION TO BE ADDED WILL OVERFLOW
|
||||
C-----------------------------------------------------------------------
|
||||
IF (ZR.LT.0.0D0) GO TO 320
|
||||
NZ = N
|
||||
DO 106 I=1,N
|
||||
YR(I) = ZEROR
|
||||
YI(I) = ZEROI
|
||||
106 CONTINUE
|
||||
RETURN
|
||||
120 CONTINUE
|
||||
S1R = CYR(1)
|
||||
S1I = CYI(1)
|
||||
S2R = CYR(2)
|
||||
S2I = CYI(2)
|
||||
C1R = CSRR(KFLAG)
|
||||
ASCLE = BRY(KFLAG)
|
||||
DO 130 I=IB,N
|
||||
C2R = S2R
|
||||
C2I = S2I
|
||||
S2R = CKR*C2R - CKI*C2I + S1R
|
||||
S2I = CKR*C2I + CKI*C2R + S1I
|
||||
S1R = C2R
|
||||
S1I = C2I
|
||||
CKR = CKR + RZR
|
||||
CKI = CKI + RZI
|
||||
C2R = S2R*C1R
|
||||
C2I = S2I*C1R
|
||||
YR(I) = C2R
|
||||
YI(I) = C2I
|
||||
IF (KFLAG.GE.3) GO TO 130
|
||||
STR = DABS(C2R)
|
||||
STI = DABS(C2I)
|
||||
C2M = DMAX1(STR,STI)
|
||||
IF (C2M.LE.ASCLE) GO TO 130
|
||||
KFLAG = KFLAG + 1
|
||||
ASCLE = BRY(KFLAG)
|
||||
S1R = S1R*C1R
|
||||
S1I = S1I*C1R
|
||||
S2R = C2R
|
||||
S2I = C2I
|
||||
S1R = S1R*CSSR(KFLAG)
|
||||
S1I = S1I*CSSR(KFLAG)
|
||||
S2R = S2R*CSSR(KFLAG)
|
||||
S2I = S2I*CSSR(KFLAG)
|
||||
C1R = CSRR(KFLAG)
|
||||
130 CONTINUE
|
||||
180 CONTINUE
|
||||
IF (MR.EQ.0) RETURN
|
||||
C-----------------------------------------------------------------------
|
||||
C ANALYTIC CONTINUATION FOR RE(Z).LT.0.0D0
|
||||
C-----------------------------------------------------------------------
|
||||
NZ = 0
|
||||
FMR = DBLE(FLOAT(MR))
|
||||
SGN = -DSIGN(PI,FMR)
|
||||
C-----------------------------------------------------------------------
|
||||
C CSPN AND CSGN ARE COEFF OF K AND I FUNCIONS RESP.
|
||||
C-----------------------------------------------------------------------
|
||||
CSGNI = SGN
|
||||
IF (YY.LE.0.0D0) CSGNI = -CSGNI
|
||||
IFN = INU + N - 1
|
||||
ANG = FNF*SGN
|
||||
CSPNR = DCOS(ANG)
|
||||
CSPNI = DSIN(ANG)
|
||||
IF (MOD(IFN,2).EQ.0) GO TO 190
|
||||
CSPNR = -CSPNR
|
||||
CSPNI = -CSPNI
|
||||
190 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C CS=COEFF OF THE J FUNCTION TO GET THE I FUNCTION. I(FNU,Z) IS
|
||||
C COMPUTED FROM EXP(I*FNU*HPI)*J(FNU,-I*Z) WHERE Z IS IN THE FIRST
|
||||
C QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY
|
||||
C CONJUGATION SINCE THE I FUNCTION IS REAL ON THE POSITIVE REAL AXIS
|
||||
C-----------------------------------------------------------------------
|
||||
CSR = SAR*CSGNI
|
||||
CSI = CAR*CSGNI
|
||||
IN = MOD(IFN,4) + 1
|
||||
C2R = CIPR(IN)
|
||||
C2I = CIPI(IN)
|
||||
STR = CSR*C2R + CSI*C2I
|
||||
CSI = -CSR*C2I + CSI*C2R
|
||||
CSR = STR
|
||||
ASC = BRY(1)
|
||||
IUF = 0
|
||||
KK = N
|
||||
KDFLG = 1
|
||||
IB = IB - 1
|
||||
IC = IB - 1
|
||||
DO 290 K=1,N
|
||||
FN = FNU + DBLE(FLOAT(KK-1))
|
||||
C-----------------------------------------------------------------------
|
||||
C LOGIC TO SORT OUT CASES WHOSE PARAMETERS WERE SET FOR THE K
|
||||
C FUNCTION ABOVE
|
||||
C-----------------------------------------------------------------------
|
||||
IF (N.GT.2) GO TO 175
|
||||
172 CONTINUE
|
||||
PHIDR = PHIR(J)
|
||||
PHIDI = PHII(J)
|
||||
ARGDR = ARGR(J)
|
||||
ARGDI = ARGI(J)
|
||||
ZET1DR = ZETA1R(J)
|
||||
ZET1DI = ZETA1I(J)
|
||||
ZET2DR = ZETA2R(J)
|
||||
ZET2DI = ZETA2I(J)
|
||||
ASUMDR = ASUMR(J)
|
||||
ASUMDI = ASUMI(J)
|
||||
BSUMDR = BSUMR(J)
|
||||
BSUMDI = BSUMI(J)
|
||||
J = 3 - J
|
||||
GO TO 210
|
||||
175 CONTINUE
|
||||
IF ((KK.EQ.N).AND.(IB.LT.N)) GO TO 210
|
||||
IF ((KK.EQ.IB).OR.(KK.EQ.IC)) GO TO 172
|
||||
CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIDR, PHIDI, ARGDR,
|
||||
* ARGDI, ZET1DR, ZET1DI, ZET2DR, ZET2DI, ASUMDR,
|
||||
* ASUMDI, BSUMDR, BSUMDI)
|
||||
210 CONTINUE
|
||||
IF (KODE.EQ.1) GO TO 220
|
||||
STR = ZBR + ZET2DR
|
||||
STI = ZBI + ZET2DI
|
||||
RAST = FN/ZABS(STR,STI)
|
||||
STR = STR*RAST*RAST
|
||||
STI = -STI*RAST*RAST
|
||||
S1R = -ZET1DR + STR
|
||||
S1I = -ZET1DI + STI
|
||||
GO TO 230
|
||||
220 CONTINUE
|
||||
S1R = -ZET1DR + ZET2DR
|
||||
S1I = -ZET1DI + ZET2DI
|
||||
230 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C TEST FOR UNDERFLOW AND OVERFLOW
|
||||
C-----------------------------------------------------------------------
|
||||
RS1 = S1R
|
||||
IF (DABS(RS1).GT.ELIM) GO TO 280
|
||||
IF (KDFLG.EQ.1) IFLAG = 2
|
||||
IF (DABS(RS1).LT.ALIM) GO TO 240
|
||||
C-----------------------------------------------------------------------
|
||||
C REFINE TEST AND SCALE
|
||||
C-----------------------------------------------------------------------
|
||||
APHI = ZABS(PHIDR,PHIDI)
|
||||
AARG = ZABS(ARGDR,ARGDI)
|
||||
RS1 = RS1 + DLOG(APHI) - 0.25D0*DLOG(AARG) - AIC
|
||||
IF (DABS(RS1).GT.ELIM) GO TO 280
|
||||
IF (KDFLG.EQ.1) IFLAG = 1
|
||||
IF (RS1.LT.0.0D0) GO TO 240
|
||||
IF (KDFLG.EQ.1) IFLAG = 3
|
||||
240 CONTINUE
|
||||
CALL ZAIRY(ARGDR, ARGDI, 0, 2, AIR, AII, NAI, IDUM)
|
||||
CALL ZAIRY(ARGDR, ARGDI, 1, 2, DAIR, DAII, NDAI, IDUM)
|
||||
STR = DAIR*BSUMDR - DAII*BSUMDI
|
||||
STI = DAIR*BSUMDI + DAII*BSUMDR
|
||||
STR = STR + (AIR*ASUMDR-AII*ASUMDI)
|
||||
STI = STI + (AIR*ASUMDI+AII*ASUMDR)
|
||||
PTR = STR*PHIDR - STI*PHIDI
|
||||
PTI = STR*PHIDI + STI*PHIDR
|
||||
S2R = PTR*CSR - PTI*CSI
|
||||
S2I = PTR*CSI + PTI*CSR
|
||||
STR = DEXP(S1R)*CSSR(IFLAG)
|
||||
S1R = STR*DCOS(S1I)
|
||||
S1I = STR*DSIN(S1I)
|
||||
STR = S2R*S1R - S2I*S1I
|
||||
S2I = S2R*S1I + S2I*S1R
|
||||
S2R = STR
|
||||
IF (IFLAG.NE.1) GO TO 250
|
||||
CALL ZUCHK(S2R, S2I, NW, BRY(1), TOL)
|
||||
IF (NW.EQ.0) GO TO 250
|
||||
S2R = ZEROR
|
||||
S2I = ZEROI
|
||||
250 CONTINUE
|
||||
IF (YY.LE.0.0D0) S2I = -S2I
|
||||
CYR(KDFLG) = S2R
|
||||
CYI(KDFLG) = S2I
|
||||
C2R = S2R
|
||||
C2I = S2I
|
||||
S2R = S2R*CSRR(IFLAG)
|
||||
S2I = S2I*CSRR(IFLAG)
|
||||
C-----------------------------------------------------------------------
|
||||
C ADD I AND K FUNCTIONS, K SEQUENCE IN Y(I), I=1,N
|
||||
C-----------------------------------------------------------------------
|
||||
S1R = YR(KK)
|
||||
S1I = YI(KK)
|
||||
IF (KODE.EQ.1) GO TO 270
|
||||
CALL ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NW, ASC, ALIM, IUF)
|
||||
NZ = NZ + NW
|
||||
270 CONTINUE
|
||||
YR(KK) = S1R*CSPNR - S1I*CSPNI + S2R
|
||||
YI(KK) = S1R*CSPNI + S1I*CSPNR + S2I
|
||||
KK = KK - 1
|
||||
CSPNR = -CSPNR
|
||||
CSPNI = -CSPNI
|
||||
STR = CSI
|
||||
CSI = -CSR
|
||||
CSR = STR
|
||||
IF (C2R.NE.0.0D0 .OR. C2I.NE.0.0D0) GO TO 255
|
||||
KDFLG = 1
|
||||
GO TO 290
|
||||
255 CONTINUE
|
||||
IF (KDFLG.EQ.2) GO TO 295
|
||||
KDFLG = 2
|
||||
GO TO 290
|
||||
280 CONTINUE
|
||||
IF (RS1.GT.0.0D0) GO TO 320
|
||||
S2R = ZEROR
|
||||
S2I = ZEROI
|
||||
GO TO 250
|
||||
290 CONTINUE
|
||||
K = N
|
||||
295 CONTINUE
|
||||
IL = N - K
|
||||
IF (IL.EQ.0) RETURN
|
||||
C-----------------------------------------------------------------------
|
||||
C RECUR BACKWARD FOR REMAINDER OF I SEQUENCE AND ADD IN THE
|
||||
C K FUNCTIONS, SCALING THE I SEQUENCE DURING RECURRENCE TO KEEP
|
||||
C INTERMEDIATE ARITHMETIC ON SCALE NEAR EXPONENT EXTREMES.
|
||||
C-----------------------------------------------------------------------
|
||||
S1R = CYR(1)
|
||||
S1I = CYI(1)
|
||||
S2R = CYR(2)
|
||||
S2I = CYI(2)
|
||||
CSR = CSRR(IFLAG)
|
||||
ASCLE = BRY(IFLAG)
|
||||
FN = DBLE(FLOAT(INU+IL))
|
||||
DO 310 I=1,IL
|
||||
C2R = S2R
|
||||
C2I = S2I
|
||||
S2R = S1R + (FN+FNF)*(RZR*C2R-RZI*C2I)
|
||||
S2I = S1I + (FN+FNF)*(RZR*C2I+RZI*C2R)
|
||||
S1R = C2R
|
||||
S1I = C2I
|
||||
FN = FN - 1.0D0
|
||||
C2R = S2R*CSR
|
||||
C2I = S2I*CSR
|
||||
CKR = C2R
|
||||
CKI = C2I
|
||||
C1R = YR(KK)
|
||||
C1I = YI(KK)
|
||||
IF (KODE.EQ.1) GO TO 300
|
||||
CALL ZS1S2(ZRR, ZRI, C1R, C1I, C2R, C2I, NW, ASC, ALIM, IUF)
|
||||
NZ = NZ + NW
|
||||
300 CONTINUE
|
||||
YR(KK) = C1R*CSPNR - C1I*CSPNI + C2R
|
||||
YI(KK) = C1R*CSPNI + C1I*CSPNR + C2I
|
||||
KK = KK - 1
|
||||
CSPNR = -CSPNR
|
||||
CSPNI = -CSPNI
|
||||
IF (IFLAG.GE.3) GO TO 310
|
||||
C2R = DABS(CKR)
|
||||
C2I = DABS(CKI)
|
||||
C2M = DMAX1(C2R,C2I)
|
||||
IF (C2M.LE.ASCLE) GO TO 310
|
||||
IFLAG = IFLAG + 1
|
||||
ASCLE = BRY(IFLAG)
|
||||
S1R = S1R*CSR
|
||||
S1I = S1I*CSR
|
||||
S2R = CKR
|
||||
S2I = CKI
|
||||
S1R = S1R*CSSR(IFLAG)
|
||||
S1I = S1I*CSSR(IFLAG)
|
||||
S2R = S2R*CSSR(IFLAG)
|
||||
S2I = S2I*CSSR(IFLAG)
|
||||
CSR = CSRR(IFLAG)
|
||||
310 CONTINUE
|
||||
RETURN
|
||||
320 CONTINUE
|
||||
NZ = -1
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,194 @@
|
|||
SUBROUTINE ZUOIK(ZR, ZI, FNU, KODE, IKFLG, N, YR, YI, NUF, TOL,
|
||||
* ELIM, ALIM)
|
||||
C***BEGIN PROLOGUE ZUOIK
|
||||
C***REFER TO ZBESI,ZBESK,ZBESH
|
||||
C
|
||||
C ZUOIK COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC
|
||||
C EXPANSIONS FOR THE I AND K FUNCTIONS AND COMPARES THEM
|
||||
C (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW
|
||||
C WHERE ALIM.LT.ELIM. IF THE MAGNITUDE, BASED ON THE LEADING
|
||||
C EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN
|
||||
C THE RESULT IS ON SCALE. IF NOT, THEN A REFINED TEST USING OTHER
|
||||
C MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE
|
||||
C EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)=
|
||||
C EXP(-ELIM)/TOL
|
||||
C
|
||||
C IKFLG=1 MEANS THE I SEQUENCE IS TESTED
|
||||
C =2 MEANS THE K SEQUENCE IS TESTED
|
||||
C NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE
|
||||
C =-1 MEANS AN OVERFLOW WOULD OCCUR
|
||||
C IKFLG=1 AND NUF.GT.0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO
|
||||
C THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE
|
||||
C IKFLG=2 AND NUF.EQ.N MEANS ALL Y VALUES WERE SET TO ZERO
|
||||
C IKFLG=2 AND 0.LT.NUF.LT.N NOT CONSIDERED. Y MUST BE SET BY
|
||||
C ANOTHER ROUTINE
|
||||
C
|
||||
C***ROUTINES CALLED ZUCHK,ZUNHJ,ZUNIK,D1MACH,ZABS,ZLOG
|
||||
C***END PROLOGUE ZUOIK
|
||||
C COMPLEX ARG,ASUM,BSUM,CWRK,CZ,CZERO,PHI,SUM,Y,Z,ZB,ZETA1,ZETA2,ZN,
|
||||
C *ZR
|
||||
DOUBLE PRECISION AARG, AIC, ALIM, APHI, ARGI, ARGR, ASUMI, ASUMR,
|
||||
* ASCLE, AX, AY, BSUMI, BSUMR, CWRKI, CWRKR, CZI, CZR, ELIM, FNN,
|
||||
* FNU, GNN, GNU, PHII, PHIR, RCZ, STR, STI, SUMI, SUMR, TOL, YI,
|
||||
* YR, ZBI, ZBR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI,
|
||||
* ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS
|
||||
INTEGER I, IDUM, IFORM, IKFLG, INIT, KODE, N, NN, NUF, NW
|
||||
DIMENSION YR(N), YI(N), CWRKR(16), CWRKI(16)
|
||||
DATA ZEROR,ZEROI / 0.0D0, 0.0D0 /
|
||||
DATA AIC / 1.265512123484645396D+00 /
|
||||
NUF = 0
|
||||
NN = N
|
||||
ZRR = ZR
|
||||
ZRI = ZI
|
||||
IF (ZR.GE.0.0D0) GO TO 10
|
||||
ZRR = -ZR
|
||||
ZRI = -ZI
|
||||
10 CONTINUE
|
||||
ZBR = ZRR
|
||||
ZBI = ZRI
|
||||
AX = DABS(ZR)*1.7321D0
|
||||
AY = DABS(ZI)
|
||||
IFORM = 1
|
||||
IF (AY.GT.AX) IFORM = 2
|
||||
GNU = DMAX1(FNU,1.0D0)
|
||||
IF (IKFLG.EQ.1) GO TO 20
|
||||
FNN = DBLE(FLOAT(NN))
|
||||
GNN = FNU + FNN - 1.0D0
|
||||
GNU = DMAX1(GNN,FNN)
|
||||
20 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE
|
||||
C REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET
|
||||
C THE SIGN OF THE IMAGINARY PART CORRECT.
|
||||
C-----------------------------------------------------------------------
|
||||
IF (IFORM.EQ.2) GO TO 30
|
||||
INIT = 0
|
||||
CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII,
|
||||
* ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI)
|
||||
CZR = -ZETA1R + ZETA2R
|
||||
CZI = -ZETA1I + ZETA2I
|
||||
GO TO 50
|
||||
30 CONTINUE
|
||||
ZNR = ZRI
|
||||
ZNI = -ZRR
|
||||
IF (ZI.GT.0.0D0) GO TO 40
|
||||
ZNR = -ZNR
|
||||
40 CONTINUE
|
||||
CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R,
|
||||
* ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI)
|
||||
CZR = -ZETA1R + ZETA2R
|
||||
CZI = -ZETA1I + ZETA2I
|
||||
AARG = ZABS(ARGR,ARGI)
|
||||
50 CONTINUE
|
||||
IF (KODE.EQ.1) GO TO 60
|
||||
CZR = CZR - ZBR
|
||||
CZI = CZI - ZBI
|
||||
60 CONTINUE
|
||||
IF (IKFLG.EQ.1) GO TO 70
|
||||
CZR = -CZR
|
||||
CZI = -CZI
|
||||
70 CONTINUE
|
||||
APHI = ZABS(PHIR,PHII)
|
||||
RCZ = CZR
|
||||
C-----------------------------------------------------------------------
|
||||
C OVERFLOW TEST
|
||||
C-----------------------------------------------------------------------
|
||||
IF (RCZ.GT.ELIM) GO TO 210
|
||||
IF (RCZ.LT.ALIM) GO TO 80
|
||||
RCZ = RCZ + DLOG(APHI)
|
||||
IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC
|
||||
IF (RCZ.GT.ELIM) GO TO 210
|
||||
GO TO 130
|
||||
80 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C UNDERFLOW TEST
|
||||
C-----------------------------------------------------------------------
|
||||
IF (RCZ.LT.(-ELIM)) GO TO 90
|
||||
IF (RCZ.GT.(-ALIM)) GO TO 130
|
||||
RCZ = RCZ + DLOG(APHI)
|
||||
IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC
|
||||
IF (RCZ.GT.(-ELIM)) GO TO 110
|
||||
90 CONTINUE
|
||||
DO 100 I=1,NN
|
||||
YR(I) = ZEROR
|
||||
YI(I) = ZEROI
|
||||
100 CONTINUE
|
||||
NUF = NN
|
||||
RETURN
|
||||
110 CONTINUE
|
||||
ASCLE = 1.0D+3*D1MACH(1)/TOL
|
||||
CALL ZLOG(PHIR, PHII, STR, STI, IDUM)
|
||||
CZR = CZR + STR
|
||||
CZI = CZI + STI
|
||||
IF (IFORM.EQ.1) GO TO 120
|
||||
CALL ZLOG(ARGR, ARGI, STR, STI, IDUM)
|
||||
CZR = CZR - 0.25D0*STR - AIC
|
||||
CZI = CZI - 0.25D0*STI
|
||||
120 CONTINUE
|
||||
AX = DEXP(RCZ)/TOL
|
||||
AY = CZI
|
||||
CZR = AX*DCOS(AY)
|
||||
CZI = AX*DSIN(AY)
|
||||
CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL)
|
||||
IF (NW.NE.0) GO TO 90
|
||||
130 CONTINUE
|
||||
IF (IKFLG.EQ.2) RETURN
|
||||
IF (N.EQ.1) RETURN
|
||||
C-----------------------------------------------------------------------
|
||||
C SET UNDERFLOWS ON I SEQUENCE
|
||||
C-----------------------------------------------------------------------
|
||||
140 CONTINUE
|
||||
GNU = FNU + DBLE(FLOAT(NN-1))
|
||||
IF (IFORM.EQ.2) GO TO 150
|
||||
INIT = 0
|
||||
CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII,
|
||||
* ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI)
|
||||
CZR = -ZETA1R + ZETA2R
|
||||
CZI = -ZETA1I + ZETA2I
|
||||
GO TO 160
|
||||
150 CONTINUE
|
||||
CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R,
|
||||
* ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI)
|
||||
CZR = -ZETA1R + ZETA2R
|
||||
CZI = -ZETA1I + ZETA2I
|
||||
AARG = ZABS(ARGR,ARGI)
|
||||
160 CONTINUE
|
||||
IF (KODE.EQ.1) GO TO 170
|
||||
CZR = CZR - ZBR
|
||||
CZI = CZI - ZBI
|
||||
170 CONTINUE
|
||||
APHI = ZABS(PHIR,PHII)
|
||||
RCZ = CZR
|
||||
IF (RCZ.LT.(-ELIM)) GO TO 180
|
||||
IF (RCZ.GT.(-ALIM)) RETURN
|
||||
RCZ = RCZ + DLOG(APHI)
|
||||
IF (IFORM.EQ.2) RCZ = RCZ - 0.25D0*DLOG(AARG) - AIC
|
||||
IF (RCZ.GT.(-ELIM)) GO TO 190
|
||||
180 CONTINUE
|
||||
YR(NN) = ZEROR
|
||||
YI(NN) = ZEROI
|
||||
NN = NN - 1
|
||||
NUF = NUF + 1
|
||||
IF (NN.EQ.0) RETURN
|
||||
GO TO 140
|
||||
190 CONTINUE
|
||||
ASCLE = 1.0D+3*D1MACH(1)/TOL
|
||||
CALL ZLOG(PHIR, PHII, STR, STI, IDUM)
|
||||
CZR = CZR + STR
|
||||
CZI = CZI + STI
|
||||
IF (IFORM.EQ.1) GO TO 200
|
||||
CALL ZLOG(ARGR, ARGI, STR, STI, IDUM)
|
||||
CZR = CZR - 0.25D0*STR - AIC
|
||||
CZI = CZI - 0.25D0*STI
|
||||
200 CONTINUE
|
||||
AX = DEXP(RCZ)/TOL
|
||||
AY = CZI
|
||||
CZR = AX*DCOS(AY)
|
||||
CZI = AX*DSIN(AY)
|
||||
CALL ZUCHK(CZR, CZI, NW, ASCLE, TOL)
|
||||
IF (NW.NE.0) GO TO 180
|
||||
RETURN
|
||||
210 CONTINUE
|
||||
NUF = -1
|
||||
RETURN
|
||||
END
|
||||
|
|
@ -0,0 +1,94 @@
|
|||
SUBROUTINE ZWRSK(ZRR, ZRI, FNU, KODE, N, YR, YI, NZ, CWR, CWI,
|
||||
* TOL, ELIM, ALIM)
|
||||
C***BEGIN PROLOGUE ZWRSK
|
||||
C***REFER TO ZBESI,ZBESK
|
||||
C
|
||||
C ZWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY
|
||||
C NORMALIZING THE I FUNCTION RATIOS FROM ZRATI BY THE WRONSKIAN
|
||||
C
|
||||
C***ROUTINES CALLED D1MACH,ZBKNU,ZRATI,ZABS
|
||||
C***END PROLOGUE ZWRSK
|
||||
C COMPLEX CINU,CSCL,CT,CW,C1,C2,RCT,ST,Y,ZR
|
||||
DOUBLE PRECISION ACT, ACW, ALIM, ASCLE, CINUI, CINUR, CSCLR, CTI,
|
||||
* CTR, CWI, CWR, C1I, C1R, C2I, C2R, ELIM, FNU, PTI, PTR, RACT,
|
||||
* STI, STR, TOL, YI, YR, ZRI, ZRR, ZABS, D1MACH
|
||||
INTEGER I, KODE, N, NW, NZ
|
||||
DIMENSION YR(N), YI(N), CWR(2), CWI(2)
|
||||
C-----------------------------------------------------------------------
|
||||
C I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS
|
||||
C Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM CRATI NORMALIZED BY THE
|
||||
C WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM CBKNU.
|
||||
C-----------------------------------------------------------------------
|
||||
NZ = 0
|
||||
CALL ZBKNU(ZRR, ZRI, FNU, KODE, 2, CWR, CWI, NW, TOL, ELIM, ALIM)
|
||||
IF (NW.NE.0) GO TO 50
|
||||
CALL ZRATI(ZRR, ZRI, FNU, N, YR, YI, TOL)
|
||||
C-----------------------------------------------------------------------
|
||||
C RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z),
|
||||
C R(FNU+J-1,Z)=Y(J), J=1,...,N
|
||||
C-----------------------------------------------------------------------
|
||||
CINUR = 1.0D0
|
||||
CINUI = 0.0D0
|
||||
IF (KODE.EQ.1) GO TO 10
|
||||
CINUR = DCOS(ZRI)
|
||||
CINUI = DSIN(ZRI)
|
||||
10 CONTINUE
|
||||
C-----------------------------------------------------------------------
|
||||
C ON LOW EXPONENT MACHINES THE K FUNCTIONS CAN BE CLOSE TO BOTH
|
||||
C THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE
|
||||
C SCALED TO PREVENT OVER OR UNDERFLOW. CUOIK HAS DETERMINED THAT
|
||||
C THE RESULT IS ON SCALE.
|
||||
C-----------------------------------------------------------------------
|
||||
ACW = ZABS(CWR(2),CWI(2))
|
||||
ASCLE = 1.0D+3*D1MACH(1)/TOL
|
||||
CSCLR = 1.0D0
|
||||
IF (ACW.GT.ASCLE) GO TO 20
|
||||
CSCLR = 1.0D0/TOL
|
||||
GO TO 30
|
||||
20 CONTINUE
|
||||
ASCLE = 1.0D0/ASCLE
|
||||
IF (ACW.LT.ASCLE) GO TO 30
|
||||
CSCLR = TOL
|
||||
30 CONTINUE
|
||||
C1R = CWR(1)*CSCLR
|
||||
C1I = CWI(1)*CSCLR
|
||||
C2R = CWR(2)*CSCLR
|
||||
C2I = CWI(2)*CSCLR
|
||||
STR = YR(1)
|
||||
STI = YI(1)
|
||||
C-----------------------------------------------------------------------
|
||||
C CINU=CINU*(CONJG(CT)/CABS(CT))*(1.0D0/CABS(CT) PREVENTS
|
||||
C UNDER- OR OVERFLOW PREMATURELY BY SQUARING CABS(CT)
|
||||
C-----------------------------------------------------------------------
|
||||
PTR = STR*C1R - STI*C1I
|
||||
PTI = STR*C1I + STI*C1R
|
||||
PTR = PTR + C2R
|
||||
PTI = PTI + C2I
|
||||
CTR = ZRR*PTR - ZRI*PTI
|
||||
CTI = ZRR*PTI + ZRI*PTR
|
||||
ACT = ZABS(CTR,CTI)
|
||||
RACT = 1.0D0/ACT
|
||||
CTR = CTR*RACT
|
||||
CTI = -CTI*RACT
|
||||
PTR = CINUR*RACT
|
||||
PTI = CINUI*RACT
|
||||
CINUR = PTR*CTR - PTI*CTI
|
||||
CINUI = PTR*CTI + PTI*CTR
|
||||
YR(1) = CINUR*CSCLR
|
||||
YI(1) = CINUI*CSCLR
|
||||
IF (N.EQ.1) RETURN
|
||||
DO 40 I=2,N
|
||||
PTR = STR*CINUR - STI*CINUI
|
||||
CINUI = STR*CINUI + STI*CINUR
|
||||
CINUR = PTR
|
||||
STR = YR(I)
|
||||
STI = YI(I)
|
||||
YR(I) = CINUR*CSCLR
|
||||
YI(I) = CINUI*CSCLR
|
||||
40 CONTINUE
|
||||
RETURN
|
||||
50 CONTINUE
|
||||
NZ = -1
|
||||
IF(NW.EQ.(-2)) NZ=-2
|
||||
RETURN
|
||||
END
|
||||
Loading…
Reference in New Issue