diff --git a/amos/d1mach.f b/amos/d1mach.f new file mode 100644 index 0000000..86f81d7 --- /dev/null +++ b/amos/d1mach.f @@ -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 diff --git a/amos/dgamln.f b/amos/dgamln.f new file mode 100644 index 0000000..792014b --- /dev/null +++ b/amos/dgamln.f @@ -0,0 +1,189 @@ + DOUBLE PRECISION FUNCTION DGAMLN(Z,IERR) +C***BEGIN PROLOGUE DGAMLN +C***DATE WRITTEN 830501 (YYMMDD) +C***REVISION DATE 830501 (YYMMDD) +C***CATEGORY NO. B5F +C***KEYWORDS GAMMA FUNCTION,LOGARITHM OF GAMMA FUNCTION +C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES +C***PURPOSE TO COMPUTE THE LOGARITHM OF THE GAMMA FUNCTION +C***DESCRIPTION +C +C **** A DOUBLE PRECISION ROUTINE **** +C DGAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR +C Z.GT.0. THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES +C GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION +C G(Z+1)=Z*G(Z) FOR Z.LE.ZMIN. THE FUNCTION WAS MADE AS +C PORTABLE AS POSSIBLE BY COMPUTIMG ZMIN FROM THE NUMBER OF BASE +C 10 DIGITS IN A WORD, RLN=AMAX1(-ALOG10(R1MACH(4)),0.5E-18) +C LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY. +C +C SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100 +C VALUES IS USED FOR SPEED OF EXECUTION. +C +C DESCRIPTION OF ARGUMENTS +C +C INPUT Z IS D0UBLE PRECISION +C Z - ARGUMENT, Z.GT.0.0D0 +C +C OUTPUT DGAMLN IS DOUBLE PRECISION +C DGAMLN - NATURAL LOG OF THE GAMMA FUNCTION AT Z.NE.0.0D0 +C IERR - ERROR FLAG +C IERR=0, NORMAL RETURN, COMPUTATION COMPLETED +C IERR=1, Z.LE.0.0D0, NO COMPUTATION +C +C +C***REFERENCES COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C BY D. E. AMOS, SAND83-0083, MAY, 1983. +C***ROUTINES CALLED I1MACH,D1MACH +C***END PROLOGUE DGAMLN + DOUBLE PRECISION CF, CON, FLN, FZ, GLN, RLN, S, TLG, TRM, TST, + * T1, WDTOL, Z, ZDMY, ZINC, ZM, ZMIN, ZP, ZSQ, D1MACH + INTEGER I, IERR, I1M, K, MZ, NZ, I1MACH + DIMENSION CF(22), GLN(100) +C LNGAMMA(N), N=1,100 + DATA GLN(1), GLN(2), GLN(3), GLN(4), GLN(5), GLN(6), GLN(7), + 1 GLN(8), GLN(9), GLN(10), GLN(11), GLN(12), GLN(13), GLN(14), + 2 GLN(15), GLN(16), GLN(17), GLN(18), GLN(19), GLN(20), + 3 GLN(21), GLN(22)/ + 4 0.00000000000000000D+00, 0.00000000000000000D+00, + 5 6.93147180559945309D-01, 1.79175946922805500D+00, + 6 3.17805383034794562D+00, 4.78749174278204599D+00, + 7 6.57925121201010100D+00, 8.52516136106541430D+00, + 8 1.06046029027452502D+01, 1.28018274800814696D+01, + 9 1.51044125730755153D+01, 1.75023078458738858D+01, + A 1.99872144956618861D+01, 2.25521638531234229D+01, + B 2.51912211827386815D+01, 2.78992713838408916D+01, + C 3.06718601060806728D+01, 3.35050734501368889D+01, + D 3.63954452080330536D+01, 3.93398841871994940D+01, + E 4.23356164607534850D+01, 4.53801388984769080D+01/ + DATA GLN(23), GLN(24), GLN(25), GLN(26), GLN(27), GLN(28), + 1 GLN(29), GLN(30), GLN(31), GLN(32), GLN(33), GLN(34), + 2 GLN(35), GLN(36), GLN(37), GLN(38), GLN(39), GLN(40), + 3 GLN(41), GLN(42), GLN(43), GLN(44)/ + 4 4.84711813518352239D+01, 5.16066755677643736D+01, + 5 5.47847293981123192D+01, 5.80036052229805199D+01, + 6 6.12617017610020020D+01, 6.45575386270063311D+01, + 7 6.78897431371815350D+01, 7.12570389671680090D+01, + 8 7.46582363488301644D+01, 7.80922235533153106D+01, + 9 8.15579594561150372D+01, 8.50544670175815174D+01, + A 8.85808275421976788D+01, 9.21361756036870925D+01, + B 9.57196945421432025D+01, 9.93306124547874269D+01, + C 1.02968198614513813D+02, 1.06631760260643459D+02, + D 1.10320639714757395D+02, 1.14034211781461703D+02, + E 1.17771881399745072D+02, 1.21533081515438634D+02/ + DATA GLN(45), GLN(46), GLN(47), GLN(48), GLN(49), GLN(50), + 1 GLN(51), GLN(52), GLN(53), GLN(54), GLN(55), GLN(56), + 2 GLN(57), GLN(58), GLN(59), GLN(60), GLN(61), GLN(62), + 3 GLN(63), GLN(64), GLN(65), GLN(66)/ + 4 1.25317271149356895D+02, 1.29123933639127215D+02, + 5 1.32952575035616310D+02, 1.36802722637326368D+02, + 6 1.40673923648234259D+02, 1.44565743946344886D+02, + 7 1.48477766951773032D+02, 1.52409592584497358D+02, + 8 1.56360836303078785D+02, 1.60331128216630907D+02, + 9 1.64320112263195181D+02, 1.68327445448427652D+02, + A 1.72352797139162802D+02, 1.76395848406997352D+02, + B 1.80456291417543771D+02, 1.84533828861449491D+02, + C 1.88628173423671591D+02, 1.92739047287844902D+02, + D 1.96866181672889994D+02, 2.01009316399281527D+02, + E 2.05168199482641199D+02, 2.09342586752536836D+02/ + DATA GLN(67), GLN(68), GLN(69), GLN(70), GLN(71), GLN(72), + 1 GLN(73), GLN(74), GLN(75), GLN(76), GLN(77), GLN(78), + 2 GLN(79), GLN(80), GLN(81), GLN(82), GLN(83), GLN(84), + 3 GLN(85), GLN(86), GLN(87), GLN(88)/ + 4 2.13532241494563261D+02, 2.17736934113954227D+02, + 5 2.21956441819130334D+02, 2.26190548323727593D+02, + 6 2.30439043565776952D+02, 2.34701723442818268D+02, + 7 2.38978389561834323D+02, 2.43268849002982714D+02, + 8 2.47572914096186884D+02, 2.51890402209723194D+02, + 9 2.56221135550009525D+02, 2.60564940971863209D+02, + A 2.64921649798552801D+02, 2.69291097651019823D+02, + B 2.73673124285693704D+02, 2.78067573440366143D+02, + C 2.82474292687630396D+02, 2.86893133295426994D+02, + D 2.91323950094270308D+02, 2.95766601350760624D+02, + E 3.00220948647014132D+02, 3.04686856765668715D+02/ + DATA GLN(89), GLN(90), GLN(91), GLN(92), GLN(93), GLN(94), + 1 GLN(95), GLN(96), GLN(97), GLN(98), GLN(99), GLN(100)/ + 2 3.09164193580146922D+02, 3.13652829949879062D+02, + 3 3.18152639620209327D+02, 3.22663499126726177D+02, + 4 3.27185287703775217D+02, 3.31717887196928473D+02, + 5 3.36261181979198477D+02, 3.40815058870799018D+02, + 6 3.45379407062266854D+02, 3.49954118040770237D+02, + 7 3.54539085519440809D+02, 3.59134205369575399D+02/ +C COEFFICIENTS OF ASYMPTOTIC EXPANSION + DATA CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), CF(8), + 1 CF(9), CF(10), CF(11), CF(12), CF(13), CF(14), CF(15), + 2 CF(16), CF(17), CF(18), CF(19), CF(20), CF(21), CF(22)/ + 3 8.33333333333333333D-02, -2.77777777777777778D-03, + 4 7.93650793650793651D-04, -5.95238095238095238D-04, + 5 8.41750841750841751D-04, -1.91752691752691753D-03, + 6 6.41025641025641026D-03, -2.95506535947712418D-02, + 7 1.79644372368830573D-01, -1.39243221690590112D+00, + 8 1.34028640441683920D+01, -1.56848284626002017D+02, + 9 2.19310333333333333D+03, -3.61087712537249894D+04, + A 6.91472268851313067D+05, -1.52382215394074162D+07, + B 3.82900751391414141D+08, -1.08822660357843911D+10, + C 3.47320283765002252D+11, -1.23696021422692745D+13, + D 4.88788064793079335D+14, -2.13203339609193739D+16/ +C +C LN(2*PI) + DATA CON / 1.83787706640934548D+00/ +C +C***FIRST EXECUTABLE STATEMENT DGAMLN + IERR=0 + IF (Z.LE.0.0D0) GO TO 70 + IF (Z.GT.101.0D0) GO TO 10 + NZ = INT(SNGL(Z)) + FZ = Z - FLOAT(NZ) + IF (FZ.GT.0.0D0) GO TO 10 + IF (NZ.GT.100) GO TO 10 + DGAMLN = GLN(NZ) + RETURN + 10 CONTINUE + WDTOL = D1MACH(4) + WDTOL = DMAX1(WDTOL,0.5D-18) + I1M = I1MACH(14) + RLN = D1MACH(5)*FLOAT(I1M) + FLN = DMIN1(RLN,20.0D0) + FLN = DMAX1(FLN,3.0D0) + FLN = FLN - 3.0D0 + ZM = 1.8000D0 + 0.3875D0*FLN + MZ = INT(SNGL(ZM)) + 1 + ZMIN = FLOAT(MZ) + ZDMY = Z + ZINC = 0.0D0 + IF (Z.GE.ZMIN) GO TO 20 + ZINC = ZMIN - FLOAT(NZ) + ZDMY = Z + ZINC + 20 CONTINUE + ZP = 1.0D0/ZDMY + T1 = CF(1)*ZP + S = T1 + IF (ZP.LT.WDTOL) GO TO 40 + ZSQ = ZP*ZP + TST = T1*WDTOL + DO 30 K=2,22 + ZP = ZP*ZSQ + TRM = CF(K)*ZP + IF (DABS(TRM).LT.TST) GO TO 40 + S = S + TRM + 30 CONTINUE + 40 CONTINUE + IF (ZINC.NE.0.0D0) GO TO 50 + TLG = DLOG(Z) + DGAMLN = Z*(TLG-1.0D0) + 0.5D0*(CON-TLG) + S + RETURN + 50 CONTINUE + ZP = 1.0D0 + NZ = INT(SNGL(ZINC)) + DO 60 I=1,NZ + ZP = ZP*(Z+FLOAT(I-1)) + 60 CONTINUE + TLG = DLOG(ZDMY) + DGAMLN = ZDMY*(TLG-1.0D0) - DLOG(ZP) + 0.5D0*(CON-TLG) + S + RETURN +C +C + 70 CONTINUE + IERR=1 + RETURN + END diff --git a/amos/i1mach.f b/amos/i1mach.f new file mode 100644 index 0000000..70d8cc8 --- /dev/null +++ b/amos/i1mach.f @@ -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 diff --git a/amos/xerror.f b/amos/xerror.f new file mode 100644 index 0000000..baa5506 --- /dev/null +++ b/amos/xerror.f @@ -0,0 +1,22 @@ + SUBROUTINE XERROR(MESS,NMESS,L1,L2) +C +C THIS IS A DUMMY XERROR ROUTINE TO PRINT ERROR MESSAGES WITH NMESS +C CHARACTERS. L1 AND L2 ARE DUMMY PARAMETERS TO MAKE THIS CALL +C COMPATIBLE WITH THE SLATEC XERROR ROUTINE. THIS IS A FORTRAN 77 +C ROUTINE. +C + CHARACTER*(*) MESS + NN=NMESS/70 + NR=NMESS-70*NN + IF(NR.NE.0) NN=NN+1 + K=1 + PRINT 900 + 900 FORMAT(/) + DO 10 I=1,NN + KMIN=MIN0(K+69,NMESS) + PRINT *, MESS(K:KMIN) + K=K+70 + 10 CONTINUE + PRINT 900 + RETURN + END diff --git a/amos/zabs.f b/amos/zabs.f new file mode 100644 index 0000000..b25a7ad --- /dev/null +++ b/amos/zabs.f @@ -0,0 +1,29 @@ + DOUBLE PRECISION FUNCTION ZABS(ZR, ZI) +C***BEGIN PROLOGUE ZABS +C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY +C +C ZABS COMPUTES THE ABSOLUTE VALUE OR MAGNITUDE OF A DOUBLE +C PRECISION COMPLEX VARIABLE CMPLX(ZR,ZI) +C +C***ROUTINES CALLED (NONE) +C***END PROLOGUE ZABS + DOUBLE PRECISION ZR, ZI, U, V, Q, S + U = DABS(ZR) + V = DABS(ZI) + S = U + V +C----------------------------------------------------------------------- +C S*1.0D0 MAKES AN UNNORMALIZED UNDERFLOW ON CDC MACHINES INTO A +C TRUE FLOATING ZERO +C----------------------------------------------------------------------- + S = S*1.0D+0 + IF (S.EQ.0.0D+0) GO TO 20 + IF (U.GT.V) GO TO 10 + Q = U/V + ZABS = V*DSQRT(1.D+0+Q*Q) + RETURN + 10 Q = V/U + ZABS = U*DSQRT(1.D+0+Q*Q) + RETURN + 20 ZABS = 0.0D+0 + RETURN + END diff --git a/amos/zacai.f b/amos/zacai.f new file mode 100644 index 0000000..345e5eb --- /dev/null +++ b/amos/zacai.f @@ -0,0 +1,99 @@ + SUBROUTINE ZACAI(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, TOL, + * ELIM, ALIM) +C***BEGIN PROLOGUE ZACAI +C***REFER TO ZAIRY +C +C ZACAI APPLIES THE ANALYTIC CONTINUATION FORMULA +C +C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) +C MP=PI*MR*CMPLX(0.0,1.0) +C +C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT +C HALF Z PLANE FOR USE WITH ZAIRY WHERE FNU=1/3 OR 2/3 AND N=1. +C ZACAI IS THE SAME AS ZACON WITH THE PARTS FOR LARGER ORDERS AND +C RECURRENCE REMOVED. A RECURSIVE CALL TO ZACON CAN RESULT IF ZACON +C IS CALLED FROM ZAIRY. +C +C***ROUTINES CALLED ZASYI,ZBKNU,ZMLRI,ZSERI,ZS1S2,D1MACH,ZABS +C***END PROLOGUE ZACAI +C COMPLEX CSGN,CSPN,C1,C2,Y,Z,ZN,CY + DOUBLE PRECISION ALIM, ARG, ASCLE, AZ, CSGNR, CSGNI, CSPNR, + * CSPNI, C1R, C1I, C2R, C2I, CYR, CYI, DFNU, ELIM, FMR, FNU, PI, + * RL, SGN, TOL, YY, YR, YI, ZR, ZI, ZNR, ZNI, D1MACH, ZABS + INTEGER INU, IUF, KODE, MR, N, NN, NW, NZ + DIMENSION YR(N), YI(N), CYR(2), CYI(2) + DATA PI / 3.14159265358979324D0 / + NZ = 0 + ZNR = -ZR + ZNI = -ZI + AZ = ZABS(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 diff --git a/amos/zacon.f b/amos/zacon.f new file mode 100644 index 0000000..c3964e1 --- /dev/null +++ b/amos/zacon.f @@ -0,0 +1,203 @@ + SUBROUTINE ZACON(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, RL, FNUL, + * TOL, ELIM, ALIM) +C***BEGIN PROLOGUE ZACON +C***REFER TO ZBESK,ZBESH +C +C ZACON APPLIES THE ANALYTIC CONTINUATION FORMULA +C +C K(FNU,ZN*EXP(MP))=K(FNU,ZN)*EXP(-MP*FNU) - MP*I(FNU,ZN) +C MP=PI*MR*CMPLX(0.0,1.0) +C +C TO CONTINUE THE K FUNCTION FROM THE RIGHT HALF TO THE LEFT +C HALF Z PLANE +C +C***ROUTINES CALLED ZBINU,ZBKNU,ZS1S2,D1MACH,ZABS,ZMLT +C***END PROLOGUE ZACON +C COMPLEX CK,CONE,CSCL,CSCR,CSGN,CSPN,CY,CZERO,C1,C2,RZ,SC1,SC2,ST, +C *S1,S2,Y,Z,ZN + DOUBLE PRECISION ALIM, ARG, ASCLE, AS2, AZN, BRY, BSCLE, CKI, + * CKR, CONER, CPN, CSCL, CSCR, CSGNI, CSGNR, CSPNI, CSPNR, + * CSR, CSRR, CSSR, CYI, CYR, C1I, C1M, C1R, C2I, C2R, ELIM, FMR, + * FN, FNU, FNUL, PI, PTI, PTR, RAZN, RL, RZI, RZR, SC1I, SC1R, + * SC2I, SC2R, SGN, SPN, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, + * YY, ZEROR, ZI, ZNI, ZNR, ZR, D1MACH, ZABS + INTEGER I, INU, IUF, KFLAG, KODE, MR, N, NN, NW, NZ + DIMENSION YR(N), YI(N), CYR(2), CYI(2), CSSR(3), CSRR(3), BRY(3) + DATA PI / 3.14159265358979324D0 / + DATA ZEROR,CONER / 0.0D0,1.0D0 / + NZ = 0 + ZNR = -ZR + ZNI = -ZI + NN = N + CALL ZBINU(ZNR, ZNI, FNU, KODE, NN, YR, YI, NW, RL, FNUL, TOL, + * ELIM, ALIM) + IF (NW.LT.0) GO TO 90 +C----------------------------------------------------------------------- +C ANALYTIC CONTINUATION TO THE LEFT HALF PLANE FOR THE K FUNCTION +C----------------------------------------------------------------------- + NN = MIN0(2,N) + CALL ZBKNU(ZNR, ZNI, FNU, KODE, NN, CYR, CYI, NW, TOL, ELIM, ALIM) + IF (NW.NE.0) GO TO 90 + S1R = CYR(1) + S1I = CYI(1) + FMR = DBLE(FLOAT(MR)) + SGN = -DSIGN(PI,FMR) + CSGNR = ZEROR + CSGNI = SGN + IF (KODE.EQ.1) GO TO 10 + YY = -ZNI + CPN = DCOS(YY) + SPN = DSIN(YY) + CALL ZMLT(CSGNR, CSGNI, CPN, SPN, CSGNR, CSGNI) + 10 CONTINUE +C----------------------------------------------------------------------- +C CALCULATE CSPN=EXP(FNU*PI*I) TO MINIMIZE LOSSES OF SIGNIFICANCE +C WHEN FNU IS LARGE +C----------------------------------------------------------------------- + INU = INT(SNGL(FNU)) + ARG = (FNU-DBLE(FLOAT(INU)))*SGN + CPN = DCOS(ARG) + SPN = DSIN(ARG) + CSPNR = CPN + CSPNI = SPN + IF (MOD(INU,2).EQ.0) GO TO 20 + CSPNR = -CSPNR + CSPNI = -CSPNI + 20 CONTINUE + IUF = 0 + C1R = S1R + C1I = S1I + C2R = YR(1) + C2I = YI(1) + ASCLE = 1.0D+3*D1MACH(1)/TOL + IF (KODE.EQ.1) GO TO 30 + CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) + NZ = NZ + NW + SC1R = C1R + SC1I = C1I + 30 CONTINUE + CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI) + CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI) + YR(1) = STR + PTR + YI(1) = STI + PTI + IF (N.EQ.1) RETURN + CSPNR = -CSPNR + CSPNI = -CSPNI + S2R = CYR(2) + S2I = CYI(2) + C1R = S2R + C1I = S2I + C2R = YR(2) + C2I = YI(2) + IF (KODE.EQ.1) GO TO 40 + CALL ZS1S2(ZNR, ZNI, C1R, C1I, C2R, C2I, NW, ASCLE, ALIM, IUF) + NZ = NZ + NW + SC2R = C1R + SC2I = C1I + 40 CONTINUE + CALL ZMLT(CSPNR, CSPNI, C1R, C1I, STR, STI) + CALL ZMLT(CSGNR, CSGNI, C2R, C2I, PTR, PTI) + YR(2) = STR + PTR + YI(2) = STI + PTI + IF (N.EQ.2) RETURN + CSPNR = -CSPNR + CSPNI = -CSPNI + AZN = ZABS(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 diff --git a/amos/zairy.f b/amos/zairy.f new file mode 100644 index 0000000..d6ee764 --- /dev/null +++ b/amos/zairy.f @@ -0,0 +1,393 @@ + SUBROUTINE ZAIRY(ZR, ZI, ID, KODE, AIR, AII, NZ, IERR) +C***BEGIN PROLOGUE ZAIRY +C***DATE WRITTEN 830501 (YYMMDD) +C***REVISION DATE 890801 (YYMMDD) +C***CATEGORY NO. B5K +C***KEYWORDS AIRY FUNCTION,BESSEL FUNCTIONS OF ORDER ONE THIRD +C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES +C***PURPOSE TO COMPUTE AIRY FUNCTIONS AI(Z) AND DAI(Z) FOR COMPLEX Z +C***DESCRIPTION +C +C ***A DOUBLE PRECISION ROUTINE*** +C ON KODE=1, ZAIRY COMPUTES THE COMPLEX AIRY FUNCTION AI(Z) OR +C ITS DERIVATIVE DAI(Z)/DZ ON ID=0 OR ID=1 RESPECTIVELY. ON +C KODE=2, A SCALING OPTION CEXP(ZTA)*AI(Z) OR CEXP(ZTA)* +C DAI(Z)/DZ IS PROVIDED TO REMOVE THE EXPONENTIAL DECAY IN +C -PI/3.LT.ARG(Z).LT.PI/3 AND THE EXPONENTIAL GROWTH IN +C PI/3.LT.ABS(ARG(Z)).LT.PI WHERE ZTA=(2/3)*Z*CSQRT(Z). +C +C WHILE THE AIRY FUNCTIONS AI(Z) AND DAI(Z)/DZ ARE ANALYTIC IN +C THE WHOLE Z PLANE, THE CORRESPONDING SCALED FUNCTIONS DEFINED +C FOR KODE=2 HAVE A CUT ALONG THE NEGATIVE REAL AXIS. +C DEFINTIONS AND NOTATION ARE FOUND IN THE NBS HANDBOOK OF +C MATHEMATICAL FUNCTIONS (REF. 1). +C +C INPUT ZR,ZI ARE DOUBLE PRECISION +C ZR,ZI - Z=CMPLX(ZR,ZI) +C ID - ORDER OF DERIVATIVE, ID=0 OR ID=1 +C KODE - A PARAMETER TO INDICATE THE SCALING OPTION +C KODE= 1 RETURNS +C AI=AI(Z) ON ID=0 OR +C AI=DAI(Z)/DZ ON ID=1 +C = 2 RETURNS +C AI=CEXP(ZTA)*AI(Z) ON ID=0 OR +C AI=CEXP(ZTA)*DAI(Z)/DZ ON ID=1 WHERE +C ZTA=(2/3)*Z*CSQRT(Z) +C +C OUTPUT AIR,AII ARE DOUBLE PRECISION +C AIR,AII- COMPLEX ANSWER DEPENDING ON THE CHOICES FOR ID AND +C KODE +C NZ - UNDERFLOW INDICATOR +C NZ= 0 , NORMAL RETURN +C NZ= 1 , AI=CMPLX(0.0D0,0.0D0) DUE TO UNDERFLOW IN +C -PI/3.LT.ARG(Z).LT.PI/3 ON KODE=1 +C IERR - ERROR FLAG +C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED +C IERR=1, INPUT ERROR - NO COMPUTATION +C IERR=2, OVERFLOW - NO COMPUTATION, REAL(ZTA) +C TOO LARGE ON KODE=1 +C IERR=3, CABS(Z) LARGE - COMPUTATION COMPLETED +C LOSSES OF SIGNIFCANCE BY ARGUMENT REDUCTION +C PRODUCE LESS THAN HALF OF MACHINE ACCURACY +C IERR=4, CABS(Z) TOO LARGE - NO COMPUTATION +C COMPLETE LOSS OF ACCURACY BY ARGUMENT +C REDUCTION +C IERR=5, ERROR - NO COMPUTATION, +C ALGORITHM TERMINATION CONDITION NOT MET +C +C***LONG DESCRIPTION +C +C AI AND DAI ARE COMPUTED FOR CABS(Z).GT.1.0 FROM THE K BESSEL +C FUNCTIONS BY +C +C AI(Z)=C*SQRT(Z)*K(1/3,ZTA) , DAI(Z)=-C*Z*K(2/3,ZTA) +C C=1.0/(PI*SQRT(3.0)) +C ZTA=(2/3)*Z**(3/2) +C +C WITH THE POWER SERIES FOR CABS(Z).LE.1.0. +C +C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- +C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z IS LARGE, LOSSES +C OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. CONSEQUENTLY, IF +C THE MAGNITUDE OF ZETA=(2/3)*Z**1.5 EXCEEDS U1=SQRT(0.5/UR), +C THEN LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR +C FLAG IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS +C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. +C ALSO, IF THE MAGNITUDE OF ZETA IS LARGER THAN U2=0.5/UR, THEN +C ALL SIGNIFICANCE IS LOST AND IERR=4. IN ORDER TO USE THE INT +C FUNCTION, ZETA MUST BE FURTHER RESTRICTED NOT TO EXCEED THE +C LARGEST INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF ZETA +C MUST BE RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, +C AND U3 ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE +C PRECISION ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE +C PRECISION ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMIT- +C ING IN THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT THE MAG- +C NITUDE OF Z CANNOT EXCEED 3.1E+4 IN SINGLE AND 2.1E+6 IN +C DOUBLE PRECISION ARITHMETIC. THIS ALSO MEANS THAT ONE CAN +C EXPECT TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, +C NO DIGITS IN SINGLE PRECISION AND ONLY 7 DIGITS IN DOUBLE +C PRECISION ARITHMETIC. SIMILAR CONSIDERATIONS HOLD FOR OTHER +C MACHINES. +C +C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX +C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT +C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- +C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE +C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), +C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF +C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY +C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN +C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY +C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER +C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, +C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS +C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER +C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY +C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER +C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE +C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, +C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, +C OR -PI/2+P. +C +C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ +C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF +C COMMERCE, 1955. +C +C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 +C +C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- +C 1018, MAY, 1985 +C +C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. +C MATH. SOFTWARE, 1986 +C +C***ROUTINES CALLED ZACAI,ZBKNU,ZEXP,ZSQRT,I1MACH,D1MACH +C***END PROLOGUE ZAIRY +C COMPLEX AI,CONE,CSQ,CY,S1,S2,TRM1,TRM2,Z,ZTA,Z3 + DOUBLE PRECISION AA, AD, AII, AIR, AK, ALIM, ATRM, AZ, AZ3, BK, + * CC, CK, COEF, CONEI, CONER, CSQI, CSQR, CYI, CYR, C1, C2, DIG, + * DK, D1, D2, ELIM, FID, FNU, PTR, RL, R1M5, SFAC, STI, STR, + * S1I, S1R, S2I, S2R, TOL, TRM1I, TRM1R, TRM2I, TRM2R, TTH, ZEROI, + * ZEROR, ZI, ZR, ZTAI, ZTAR, Z3I, Z3R, D1MACH, ZABS, ALAZ, BB + INTEGER ID, IERR, IFLAG, K, KODE, K1, K2, MR, NN, NZ, I1MACH + DIMENSION CYR(1), CYI(1) + DATA TTH, C1, C2, COEF /6.66666666666666667D-01, + * 3.55028053887817240D-01,2.58819403792806799D-01, + * 1.83776298473930683D-01/ + DATA ZEROR, ZEROI, CONER, CONEI /0.0D0,0.0D0,1.0D0,0.0D0/ +C***FIRST EXECUTABLE STATEMENT ZAIRY + IERR = 0 + NZ=0 + IF (ID.LT.0 .OR. ID.GT.1) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (IERR.NE.0) RETURN + AZ = ZABS(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 diff --git a/amos/zasyi.f b/amos/zasyi.f new file mode 100644 index 0000000..5cd09fa --- /dev/null +++ b/amos/zasyi.f @@ -0,0 +1,165 @@ + SUBROUTINE ZASYI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, RL, TOL, ELIM, + * ALIM) +C***BEGIN PROLOGUE ZASYI +C***REFER TO ZBESI,ZBESK +C +C ZASYI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY +C MEANS OF THE ASYMPTOTIC EXPANSION FOR LARGE CABS(Z) IN THE +C REGION CABS(Z).GT.MAX(RL,FNU*FNU/2). NZ=0 IS A NORMAL RETURN. +C NZ.LT.0 INDICATES AN OVERFLOW ON KODE=1. +C +C***ROUTINES CALLED D1MACH,ZABS,ZDIV,ZEXP,ZMLT,ZSQRT +C***END PROLOGUE ZASYI +C COMPLEX AK1,CK,CONE,CS1,CS2,CZ,CZERO,DK,EZ,P1,RZ,S2,Y,Z + DOUBLE PRECISION AA, AEZ, AK, AK1I, AK1R, ALIM, ARG, ARM, ATOL, + * AZ, BB, BK, CKI, CKR, CONEI, CONER, CS1I, CS1R, CS2I, CS2R, CZI, + * CZR, DFNU, DKI, DKR, DNU2, ELIM, EZI, EZR, FDN, FNU, PI, P1I, + * P1R, RAZ, RL, RTPI, RTR1, RZI, RZR, S, SGN, SQK, STI, STR, S2I, + * S2R, TOL, TZI, TZR, YI, YR, ZEROI, ZEROR, ZI, ZR, D1MACH, ZABS + INTEGER I, IB, IL, INU, J, JL, K, KODE, KODED, M, N, NN, NZ + DIMENSION YR(N), YI(N) + DATA PI, RTPI /3.14159265358979324D0 , 0.159154943091895336D0 / + DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / +C + NZ = 0 + AZ = ZABS(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 diff --git a/amos/zbesh.f b/amos/zbesh.f new file mode 100644 index 0000000..cedeb8b --- /dev/null +++ b/amos/zbesh.f @@ -0,0 +1,348 @@ + SUBROUTINE ZBESH(ZR, ZI, FNU, KODE, M, N, CYR, CYI, NZ, IERR) +C***BEGIN PROLOGUE ZBESH +C***DATE WRITTEN 830501 (YYMMDD) +C***REVISION DATE 890801 (YYMMDD) +C***CATEGORY NO. B5K +C***KEYWORDS H-BESSEL FUNCTIONS,BESSEL FUNCTIONS OF COMPLEX ARGUMENT, +C BESSEL FUNCTIONS OF THIRD KIND,HANKEL FUNCTIONS +C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES +C***PURPOSE TO COMPUTE THE H-BESSEL FUNCTIONS OF A COMPLEX ARGUMENT +C***DESCRIPTION +C +C ***A DOUBLE PRECISION ROUTINE*** +C ON KODE=1, ZBESH COMPUTES AN N MEMBER SEQUENCE OF COMPLEX +C HANKEL (BESSEL) FUNCTIONS CY(J)=H(M,FNU+J-1,Z) FOR KINDS M=1 +C OR 2, REAL, NONNEGATIVE ORDERS FNU+J-1, J=1,...,N, AND COMPLEX +C Z.NE.CMPLX(0.0,0.0) IN THE CUT PLANE -PI.LT.ARG(Z).LE.PI. +C ON KODE=2, ZBESH RETURNS THE SCALED HANKEL FUNCTIONS +C +C CY(I)=EXP(-MM*Z*I)*H(M,FNU+J-1,Z) MM=3-2*M, I**2=-1. +C +C WHICH REMOVES THE EXPONENTIAL BEHAVIOR IN BOTH THE UPPER AND +C LOWER HALF PLANES. DEFINITIONS AND NOTATION ARE FOUND IN THE +C NBS HANDBOOK OF MATHEMATICAL FUNCTIONS (REF. 1). +C +C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION +C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0), +C -PT.LT.ARG(Z).LE.PI +C FNU - ORDER OF INITIAL H FUNCTION, FNU.GE.0.0D0 +C KODE - A PARAMETER TO INDICATE THE SCALING OPTION +C KODE= 1 RETURNS +C CY(J)=H(M,FNU+J-1,Z), J=1,...,N +C = 2 RETURNS +C CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) +C J=1,...,N , I**2=-1 +C M - KIND OF HANKEL FUNCTION, M=1 OR 2 +C N - NUMBER OF MEMBERS IN THE SEQUENCE, N.GE.1 +C +C OUTPUT CYR,CYI ARE DOUBLE PRECISION +C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS +C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE +C CY(J)=H(M,FNU+J-1,Z) OR +C CY(J)=H(M,FNU+J-1,Z)*EXP(-I*Z*(3-2M)) J=1,...,N +C DEPENDING ON KODE, I**2=-1. +C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW, +C NZ= 0 , NORMAL RETURN +C NZ.GT.0 , FIRST NZ COMPONENTS OF CY SET TO ZERO DUE +C TO UNDERFLOW, CY(J)=CMPLX(0.0D0,0.0D0) +C J=1,...,NZ WHEN Y.GT.0.0 AND M=1 OR +C Y.LT.0.0 AND M=2. FOR THE COMPLMENTARY +C HALF PLANES, NZ STATES ONLY THE NUMBER +C OF UNDERFLOWS. +C IERR - ERROR FLAG +C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED +C IERR=1, INPUT ERROR - NO COMPUTATION +C IERR=2, OVERFLOW - NO COMPUTATION, FNU TOO +C LARGE OR CABS(Z) TOO SMALL OR BOTH +C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE +C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT +C REDUCTION PRODUCE LESS THAN HALF OF MACHINE +C ACCURACY +C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- +C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- +C CANCE BY ARGUMENT REDUCTION +C IERR=5, ERROR - NO COMPUTATION, +C ALGORITHM TERMINATION CONDITION NOT MET +C +C***LONG DESCRIPTION +C +C THE COMPUTATION IS CARRIED OUT BY THE RELATION +C +C H(M,FNU,Z)=(1/MP)*EXP(-MP*FNU)*K(FNU,Z*EXP(-MP)) +C MP=MM*HPI*I, MM=3-2*M, HPI=PI/2, I**2=-1 +C +C FOR M=1 OR 2 WHERE THE K BESSEL FUNCTION IS COMPUTED FOR THE +C RIGHT HALF PLANE RE(Z).GE.0.0. THE K FUNCTION IS CONTINUED +C TO THE LEFT HALF PLANE BY THE RELATION +C +C K(FNU,Z*EXP(MP)) = EXP(-MP*FNU)*K(FNU,Z)-MP*I(FNU,Z) +C MP=MR*PI*I, MR=+1 OR -1, RE(Z).GT.0, I**2=-1 +C +C WHERE I(FNU,Z) IS THE I BESSEL FUNCTION. +C +C EXPONENTIAL DECAY OF H(M,FNU,Z) OCCURS IN THE UPPER HALF Z +C PLANE FOR M=1 AND THE LOWER HALF Z PLANE FOR M=2. EXPONENTIAL +C GROWTH OCCURS IN THE COMPLEMENTARY HALF PLANES. SCALING +C BY EXP(-MM*Z*I) REMOVES THE EXPONENTIAL BEHAVIOR IN THE +C WHOLE Z PLANE FOR Z TO INFINITY. +C +C FOR NEGATIVE ORDERS,THE FORMULAE +C +C H(1,-FNU,Z) = H(1,FNU,Z)*CEXP( PI*FNU*I) +C H(2,-FNU,Z) = H(2,FNU,Z)*CEXP(-PI*FNU*I) +C I**2=-1 +C +C CAN BE USED. +C +C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- +C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS +C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. +C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN +C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG +C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS +C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. +C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS +C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS +C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE +C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS +C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 +C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION +C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION +C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN +C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT +C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS +C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. +C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. +C +C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX +C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT +C ROUNDOFF,1.0D-18) IS THE NOMINAL PRECISION AND 10**S REPRE- +C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE +C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), +C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF +C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY +C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN +C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY +C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER +C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, +C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS +C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER +C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY +C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER +C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE +C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, +C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, +C OR -PI/2+P. +C +C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ +C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF +C COMMERCE, 1955. +C +C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C BY D. E. AMOS, SAND83-0083, MAY, 1983. +C +C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 +C +C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- +C 1018, MAY, 1985 +C +C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. +C MATH. SOFTWARE, 1986 +C +C***ROUTINES CALLED ZACON,ZBKNU,ZBUNK,ZUOIK,ZABS,I1MACH,D1MACH +C***END PROLOGUE ZBESH +C +C COMPLEX CY,Z,ZN,ZT,CSGN + DOUBLE PRECISION AA, ALIM, ALN, ARG, AZ, CYI, CYR, DIG, ELIM, + * FMM, FN, FNU, FNUL, HPI, RHPI, RL, R1M5, SGN, STR, TOL, UFL, ZI, + * ZNI, ZNR, ZR, ZTI, D1MACH, ZABS, BB, ASCLE, RTOL, ATOL, STI, + * CSGNR, CSGNI + INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, M, + * MM, MR, N, NN, NUF, NW, NZ, I1MACH + DIMENSION CYR(N), CYI(N) +C + DATA HPI /1.57079632679489662D0/ +C +C***FIRST EXECUTABLE STATEMENT ZBESH + IERR = 0 + NZ=0 + IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1 + IF (FNU.LT.0.0D0) IERR=1 + IF (M.LT.1 .OR. M.GT.2) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (N.LT.1) IERR=1 + IF (IERR.NE.0) RETURN + NN = N +C----------------------------------------------------------------------- +C SET PARAMETERS RELATED TO MACHINE CONSTANTS. +C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. +C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. +C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND +C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR +C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. +C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. +C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). +C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU +C----------------------------------------------------------------------- + TOL = DMAX1(D1MACH(4),1.0D-18) + K1 = I1MACH(15) + K2 = I1MACH(16) + R1M5 = D1MACH(5) + K = MIN0(IABS(K1),IABS(K2)) + ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) + K1 = I1MACH(14) - 1 + AA = R1M5*DBLE(FLOAT(K1)) + DIG = DMIN1(AA,18.0D0) + AA = AA*2.303D0 + ALIM = ELIM + DMAX1(-AA,-41.45D0) + FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) + RL = 1.2D0*DIG + 3.0D0 + FN = FNU + DBLE(FLOAT(NN-1)) + MM = 3 - M - M + FMM = DBLE(FLOAT(MM)) + ZNR = FMM*ZI + ZNI = -FMM*ZR +C----------------------------------------------------------------------- +C TEST FOR PROPER RANGE +C----------------------------------------------------------------------- + AZ = ZABS(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 diff --git a/amos/zbesj.f b/amos/zbesj.f new file mode 100644 index 0000000..f3a73de --- /dev/null +++ b/amos/zbesj.f @@ -0,0 +1,266 @@ + SUBROUTINE ZBESJ(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, IERR) +C***BEGIN PROLOGUE ZBESJ +C***DATE WRITTEN 830501 (YYMMDD) +C***REVISION DATE 890801 (YYMMDD) +C***CATEGORY NO. B5K +C***KEYWORDS J-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT, +C BESSEL FUNCTION OF FIRST KIND +C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES +C***PURPOSE TO COMPUTE THE J-BESSEL FUNCTION OF A COMPLEX ARGUMENT +C***DESCRIPTION +C +C ***A DOUBLE PRECISION ROUTINE*** +C ON KODE=1, CBESJ COMPUTES AN N MEMBER SEQUENCE OF COMPLEX +C BESSEL FUNCTIONS CY(I)=J(FNU+I-1,Z) FOR REAL, NONNEGATIVE +C ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE +C -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESJ RETURNS THE SCALED +C FUNCTIONS +C +C CY(I)=EXP(-ABS(Y))*J(FNU+I-1,Z) I = 1,...,N , Y=AIMAG(Z) +C +C WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND +C LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION +C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS +C (REF. 1). +C +C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION +C ZR,ZI - Z=CMPLX(ZR,ZI), -PI.LT.ARG(Z).LE.PI +C FNU - ORDER OF INITIAL J FUNCTION, FNU.GE.0.0D0 +C KODE - A PARAMETER TO INDICATE THE SCALING OPTION +C KODE= 1 RETURNS +C CY(I)=J(FNU+I-1,Z), I=1,...,N +C = 2 RETURNS +C CY(I)=J(FNU+I-1,Z)EXP(-ABS(Y)), I=1,...,N +C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 +C +C OUTPUT CYR,CYI ARE DOUBLE PRECISION +C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS +C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE +C CY(I)=J(FNU+I-1,Z) OR +C CY(I)=J(FNU+I-1,Z)EXP(-ABS(Y)) I=1,...,N +C DEPENDING ON KODE, Y=AIMAG(Z). +C NZ - NUMBER OF COMPONENTS SET TO ZERO DUE TO UNDERFLOW, +C NZ= 0 , NORMAL RETURN +C NZ.GT.0 , LAST NZ COMPONENTS OF CY SET ZERO DUE +C TO UNDERFLOW, CY(I)=CMPLX(0.0D0,0.0D0), +C I = N-NZ+1,...,N +C IERR - ERROR FLAG +C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED +C IERR=1, INPUT ERROR - NO COMPUTATION +C IERR=2, OVERFLOW - NO COMPUTATION, AIMAG(Z) +C TOO LARGE ON KODE=1 +C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE +C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT +C REDUCTION PRODUCE LESS THAN HALF OF MACHINE +C ACCURACY +C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- +C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- +C CANCE BY ARGUMENT REDUCTION +C IERR=5, ERROR - NO COMPUTATION, +C ALGORITHM TERMINATION CONDITION NOT MET +C +C***LONG DESCRIPTION +C +C THE COMPUTATION IS CARRIED OUT BY THE FORMULA +C +C J(FNU,Z)=EXP( FNU*PI*I/2)*I(FNU,-I*Z) AIMAG(Z).GE.0.0 +C +C J(FNU,Z)=EXP(-FNU*PI*I/2)*I(FNU, I*Z) AIMAG(Z).LT.0.0 +C +C WHERE I**2 = -1 AND I(FNU,Z) IS THE I BESSEL FUNCTION. +C +C FOR NEGATIVE ORDERS,THE FORMULA +C +C J(-FNU,Z) = J(FNU,Z)*COS(PI*FNU) - Y(FNU,Z)*SIN(PI*FNU) +C +C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO INTEGERS, THE +C THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE POSITIVE +C INTEGER,THE MAGNITUDE OF J(-FNU,Z)=J(FNU,Z)*COS(PI*FNU) IS A +C LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS NOT AN INTEGER, +C Y(FNU,Z) DOMINATES IN MAGNITUDE WITH A LARGE POSITIVE POWER OF +C TEN AND THE MOST THAT THE SECOND TERM CAN BE REDUCED IS BY +C UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, WIDE CHANGES CAN +C OCCUR WITHIN UNIT ROUNDOFF OF A LARGE INTEGER FOR FNU. HERE, +C LARGE MEANS FNU.GT.CABS(Z). +C +C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- +C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS +C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. +C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN +C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG +C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS +C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. +C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS +C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS +C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE +C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS +C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 +C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION +C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION +C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN +C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT +C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS +C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. +C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. +C +C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX +C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT +C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- +C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE +C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), +C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF +C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY +C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN +C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY +C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER +C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, +C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS +C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER +C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY +C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER +C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE +C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, +C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, +C OR -PI/2+P. +C +C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ +C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF +C COMMERCE, 1955. +C +C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C BY D. E. AMOS, SAND83-0083, MAY, 1983. +C +C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 +C +C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- +C 1018, MAY, 1985 +C +C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. +C MATH. SOFTWARE, 1986 +C +C***ROUTINES CALLED ZBINU,I1MACH,D1MACH +C***END PROLOGUE ZBESJ +C +C COMPLEX CI,CSGN,CY,Z,ZN + DOUBLE PRECISION AA, ALIM, ARG, CII, CSGNI, CSGNR, CYI, CYR, DIG, + * ELIM, FNU, FNUL, HPI, RL, R1M5, STR, TOL, ZI, ZNI, ZNR, ZR, + * D1MACH, BB, FN, AZ, ZABS, ASCLE, RTOL, ATOL, STI + INTEGER I, IERR, INU, INUH, IR, K, KODE, K1, K2, N, NL, NZ, I1MACH + DIMENSION CYR(N), CYI(N) + DATA HPI /1.57079632679489662D0/ +C +C***FIRST EXECUTABLE STATEMENT ZBESJ + IERR = 0 + NZ=0 + IF (FNU.LT.0.0D0) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (N.LT.1) IERR=1 + IF (IERR.NE.0) RETURN +C----------------------------------------------------------------------- +C SET PARAMETERS RELATED TO MACHINE CONSTANTS. +C TOL IS THE APPROXIMATE UNIT ROUNDOFF LIMITED TO 1.0E-18. +C ELIM IS THE APPROXIMATE EXPONENTIAL OVER- AND UNDERFLOW LIMIT. +C EXP(-ELIM).LT.EXP(-ALIM)=EXP(-ELIM)/TOL AND +C EXP(ELIM).GT.EXP(ALIM)=EXP(ELIM)*TOL ARE INTERVALS NEAR +C UNDERFLOW AND OVERFLOW LIMITS WHERE SCALED ARITHMETIC IS DONE. +C RL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC EXPANSION FOR LARGE Z. +C DIG = NUMBER OF BASE 10 DIGITS IN TOL = 10**(-DIG). +C FNUL IS THE LOWER BOUNDARY OF THE ASYMPTOTIC SERIES FOR LARGE FNU. +C----------------------------------------------------------------------- + TOL = DMAX1(D1MACH(4),1.0D-18) + K1 = I1MACH(15) + K2 = I1MACH(16) + R1M5 = D1MACH(5) + K = MIN0(IABS(K1),IABS(K2)) + ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) + K1 = I1MACH(14) - 1 + AA = R1M5*DBLE(FLOAT(K1)) + DIG = DMIN1(AA,18.0D0) + AA = AA*2.303D0 + ALIM = ELIM + DMAX1(-AA,-41.45D0) + RL = 1.2D0*DIG + 3.0D0 + FNUL = 10.0D0 + 6.0D0*(DIG-3.0D0) +C----------------------------------------------------------------------- +C TEST FOR PROPER RANGE +C----------------------------------------------------------------------- + AZ = ZABS(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 diff --git a/amos/zbesy.f b/amos/zbesy.f new file mode 100644 index 0000000..05ec40b --- /dev/null +++ b/amos/zbesy.f @@ -0,0 +1,244 @@ + SUBROUTINE ZBESY(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, CWRKR, CWRKI, + * IERR) +C***BEGIN PROLOGUE ZBESY +C***DATE WRITTEN 830501 (YYMMDD) +C***REVISION DATE 890801 (YYMMDD) +C***CATEGORY NO. B5K +C***KEYWORDS Y-BESSEL FUNCTION,BESSEL FUNCTION OF COMPLEX ARGUMENT, +C BESSEL FUNCTION OF SECOND KIND +C***AUTHOR AMOS, DONALD E., SANDIA NATIONAL LABORATORIES +C***PURPOSE TO COMPUTE THE Y-BESSEL FUNCTION OF A COMPLEX ARGUMENT +C***DESCRIPTION +C +C ***A DOUBLE PRECISION ROUTINE*** +C +C ON KODE=1, CBESY COMPUTES AN N MEMBER SEQUENCE OF COMPLEX +C BESSEL FUNCTIONS CY(I)=Y(FNU+I-1,Z) FOR REAL, NONNEGATIVE +C ORDERS FNU+I-1, I=1,...,N AND COMPLEX Z IN THE CUT PLANE +C -PI.LT.ARG(Z).LE.PI. ON KODE=2, CBESY RETURNS THE SCALED +C FUNCTIONS +C +C CY(I)=EXP(-ABS(Y))*Y(FNU+I-1,Z) I = 1,...,N , Y=AIMAG(Z) +C +C WHICH REMOVE THE EXPONENTIAL GROWTH IN BOTH THE UPPER AND +C LOWER HALF PLANES FOR Z TO INFINITY. DEFINITIONS AND NOTATION +C ARE FOUND IN THE NBS HANDBOOK OF MATHEMATICAL FUNCTIONS +C (REF. 1). +C +C INPUT ZR,ZI,FNU ARE DOUBLE PRECISION +C ZR,ZI - Z=CMPLX(ZR,ZI), Z.NE.CMPLX(0.0D0,0.0D0), +C -PI.LT.ARG(Z).LE.PI +C FNU - ORDER OF INITIAL Y FUNCTION, FNU.GE.0.0D0 +C KODE - A PARAMETER TO INDICATE THE SCALING OPTION +C KODE= 1 RETURNS +C CY(I)=Y(FNU+I-1,Z), I=1,...,N +C = 2 RETURNS +C CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y)), I=1,...,N +C WHERE Y=AIMAG(Z) +C N - NUMBER OF MEMBERS OF THE SEQUENCE, N.GE.1 +C CWRKR, - DOUBLE PRECISION WORK VECTORS OF DIMENSION AT +C CWRKI AT LEAST N +C +C OUTPUT CYR,CYI ARE DOUBLE PRECISION +C CYR,CYI- DOUBLE PRECISION VECTORS WHOSE FIRST N COMPONENTS +C CONTAIN REAL AND IMAGINARY PARTS FOR THE SEQUENCE +C CY(I)=Y(FNU+I-1,Z) OR +C CY(I)=Y(FNU+I-1,Z)*EXP(-ABS(Y)) I=1,...,N +C DEPENDING ON KODE. +C NZ - NZ=0 , A NORMAL RETURN +C NZ.GT.0 , NZ COMPONENTS OF CY SET TO ZERO DUE TO +C UNDERFLOW (GENERALLY ON KODE=2) +C IERR - ERROR FLAG +C IERR=0, NORMAL RETURN - COMPUTATION COMPLETED +C IERR=1, INPUT ERROR - NO COMPUTATION +C IERR=2, OVERFLOW - NO COMPUTATION, FNU IS +C TOO LARGE OR CABS(Z) IS TOO SMALL OR BOTH +C IERR=3, CABS(Z) OR FNU+N-1 LARGE - COMPUTATION DONE +C BUT LOSSES OF SIGNIFCANCE BY ARGUMENT +C REDUCTION PRODUCE LESS THAN HALF OF MACHINE +C ACCURACY +C IERR=4, CABS(Z) OR FNU+N-1 TOO LARGE - NO COMPUTA- +C TION BECAUSE OF COMPLETE LOSSES OF SIGNIFI- +C CANCE BY ARGUMENT REDUCTION +C IERR=5, ERROR - NO COMPUTATION, +C ALGORITHM TERMINATION CONDITION NOT MET +C +C***LONG DESCRIPTION +C +C THE COMPUTATION IS CARRIED OUT BY THE FORMULA +C +C Y(FNU,Z)=0.5*(H(1,FNU,Z)-H(2,FNU,Z))/I +C +C WHERE I**2 = -1 AND THE HANKEL BESSEL FUNCTIONS H(1,FNU,Z) +C AND H(2,FNU,Z) ARE CALCULATED IN CBESH. +C +C FOR NEGATIVE ORDERS,THE FORMULA +C +C Y(-FNU,Z) = Y(FNU,Z)*COS(PI*FNU) + J(FNU,Z)*SIN(PI*FNU) +C +C CAN BE USED. HOWEVER,FOR LARGE ORDERS CLOSE TO HALF ODD +C INTEGERS THE FUNCTION CHANGES RADICALLY. WHEN FNU IS A LARGE +C POSITIVE HALF ODD INTEGER,THE MAGNITUDE OF Y(-FNU,Z)=J(FNU,Z)* +C SIN(PI*FNU) IS A LARGE NEGATIVE POWER OF TEN. BUT WHEN FNU IS +C NOT A HALF ODD INTEGER, Y(FNU,Z) DOMINATES IN MAGNITUDE WITH A +C LARGE POSITIVE POWER OF TEN AND THE MOST THAT THE SECOND TERM +C CAN BE REDUCED IS BY UNIT ROUNDOFF FROM THE COEFFICIENT. THUS, +C WIDE CHANGES CAN OCCUR WITHIN UNIT ROUNDOFF OF A LARGE HALF +C ODD INTEGER. HERE, LARGE MEANS FNU.GT.CABS(Z). +C +C IN MOST COMPLEX VARIABLE COMPUTATION, ONE MUST EVALUATE ELE- +C MENTARY FUNCTIONS. WHEN THE MAGNITUDE OF Z OR FNU+N-1 IS +C LARGE, LOSSES OF SIGNIFICANCE BY ARGUMENT REDUCTION OCCUR. +C CONSEQUENTLY, IF EITHER ONE EXCEEDS U1=SQRT(0.5/UR), THEN +C LOSSES EXCEEDING HALF PRECISION ARE LIKELY AND AN ERROR FLAG +C IERR=3 IS TRIGGERED WHERE UR=DMAX1(D1MACH(4),1.0D-18) IS +C DOUBLE PRECISION UNIT ROUNDOFF LIMITED TO 18 DIGITS PRECISION. +C IF EITHER IS LARGER THAN U2=0.5/UR, THEN ALL SIGNIFICANCE IS +C LOST AND IERR=4. IN ORDER TO USE THE INT FUNCTION, ARGUMENTS +C MUST BE FURTHER RESTRICTED NOT TO EXCEED THE LARGEST MACHINE +C INTEGER, U3=I1MACH(9). THUS, THE MAGNITUDE OF Z AND FNU+N-1 IS +C RESTRICTED BY MIN(U2,U3). ON 32 BIT MACHINES, U1,U2, AND U3 +C ARE APPROXIMATELY 2.0E+3, 4.2E+6, 2.1E+9 IN SINGLE PRECISION +C ARITHMETIC AND 1.3E+8, 1.8E+16, 2.1E+9 IN DOUBLE PRECISION +C ARITHMETIC RESPECTIVELY. THIS MAKES U2 AND U3 LIMITING IN +C THEIR RESPECTIVE ARITHMETICS. THIS MEANS THAT ONE CAN EXPECT +C TO RETAIN, IN THE WORST CASES ON 32 BIT MACHINES, NO DIGITS +C IN SINGLE AND ONLY 7 DIGITS IN DOUBLE PRECISION ARITHMETIC. +C SIMILAR CONSIDERATIONS HOLD FOR OTHER MACHINES. +C +C THE APPROXIMATE RELATIVE ERROR IN THE MAGNITUDE OF A COMPLEX +C BESSEL FUNCTION CAN BE EXPRESSED BY P*10**S WHERE P=MAX(UNIT +C ROUNDOFF,1.0E-18) IS THE NOMINAL PRECISION AND 10**S REPRE- +C SENTS THE INCREASE IN ERROR DUE TO ARGUMENT REDUCTION IN THE +C ELEMENTARY FUNCTIONS. HERE, S=MAX(1,ABS(LOG10(CABS(Z))), +C ABS(LOG10(FNU))) APPROXIMATELY (I.E. S=MAX(1,ABS(EXPONENT OF +C CABS(Z),ABS(EXPONENT OF FNU)) ). HOWEVER, THE PHASE ANGLE MAY +C HAVE ONLY ABSOLUTE ACCURACY. THIS IS MOST LIKELY TO OCCUR WHEN +C ONE COMPONENT (IN ABSOLUTE VALUE) IS LARGER THAN THE OTHER BY +C SEVERAL ORDERS OF MAGNITUDE. IF ONE COMPONENT IS 10**K LARGER +C THAN THE OTHER, THEN ONE CAN EXPECT ONLY MAX(ABS(LOG10(P))-K, +C 0) SIGNIFICANT DIGITS; OR, STATED ANOTHER WAY, WHEN K EXCEEDS +C THE EXPONENT OF P, NO SIGNIFICANT DIGITS REMAIN IN THE SMALLER +C COMPONENT. HOWEVER, THE PHASE ANGLE RETAINS ABSOLUTE ACCURACY +C BECAUSE, IN COMPLEX ARITHMETIC WITH PRECISION P, THE SMALLER +C COMPONENT WILL NOT (AS A RULE) DECREASE BELOW P TIMES THE +C MAGNITUDE OF THE LARGER COMPONENT. IN THESE EXTREME CASES, +C THE PRINCIPAL PHASE ANGLE IS ON THE ORDER OF +P, -P, PI/2-P, +C OR -PI/2+P. +C +C***REFERENCES HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ +C AND I. A. STEGUN, NBS AMS SERIES 55, U.S. DEPT. OF +C COMMERCE, 1955. +C +C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C BY D. E. AMOS, SAND83-0083, MAY, 1983. +C +C COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT +C AND LARGE ORDER BY D. E. AMOS, SAND83-0643, MAY, 1983 +C +C A SUBROUTINE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, SAND85- +C 1018, MAY, 1985 +C +C A PORTABLE PACKAGE FOR BESSEL FUNCTIONS OF A COMPLEX +C ARGUMENT AND NONNEGATIVE ORDER BY D. E. AMOS, TRANS. +C MATH. SOFTWARE, 1986 +C +C***ROUTINES CALLED ZBESH,I1MACH,D1MACH +C***END PROLOGUE ZBESY +C +C COMPLEX CWRK,CY,C1,C2,EX,HCI,Z,ZU,ZV + DOUBLE PRECISION CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2R, + * ELIM, EXI, EXR, EY, FNU, HCII, STI, STR, TAY, ZI, ZR, DEXP, + * D1MACH, ASCLE, RTOL, ATOL, AA, BB, TOL + INTEGER I, IERR, K, KODE, K1, K2, N, NZ, NZ1, NZ2, I1MACH + DIMENSION CYR(N), CYI(N), CWRKR(N), CWRKI(N) +C***FIRST EXECUTABLE STATEMENT ZBESY + IERR = 0 + NZ=0 + IF (ZR.EQ.0.0D0 .AND. ZI.EQ.0.0D0) IERR=1 + IF (FNU.LT.0.0D0) IERR=1 + IF (KODE.LT.1 .OR. KODE.GT.2) IERR=1 + IF (N.LT.1) IERR=1 + IF (IERR.NE.0) RETURN + HCII = 0.5D0 + CALL ZBESH(ZR, ZI, FNU, KODE, 1, N, CYR, CYI, NZ1, IERR) + IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170 + CALL ZBESH(ZR, ZI, FNU, KODE, 2, N, CWRKR, CWRKI, NZ2, IERR) + IF (IERR.NE.0.AND.IERR.NE.3) GO TO 170 + NZ = MIN0(NZ1,NZ2) + IF (KODE.EQ.2) GO TO 60 + DO 50 I=1,N + STR = CWRKR(I) - CYR(I) + STI = CWRKI(I) - CYI(I) + CYR(I) = -STI*HCII + CYI(I) = STR*HCII + 50 CONTINUE + RETURN + 60 CONTINUE + TOL = DMAX1(D1MACH(4),1.0D-18) + K1 = I1MACH(15) + K2 = I1MACH(16) + K = MIN0(IABS(K1),IABS(K2)) + R1M5 = D1MACH(5) +C----------------------------------------------------------------------- +C ELIM IS THE APPROXIMATE EXPONENTIAL UNDER- AND OVERFLOW LIMIT +C----------------------------------------------------------------------- + ELIM = 2.303D0*(DBLE(FLOAT(K))*R1M5-3.0D0) + EXR = DCOS(ZR) + EXI = DSIN(ZR) + EY = 0.0D0 + TAY = DABS(ZI+ZI) + IF (TAY.LT.ELIM) EY = DEXP(-TAY) + IF (ZI.LT.0.0D0) GO TO 90 + C1R = EXR*EY + C1I = EXI*EY + C2R = EXR + C2I = -EXI + 70 CONTINUE + NZ = 0 + RTOL = 1.0D0/TOL + ASCLE = D1MACH(1)*RTOL*1.0D+3 + DO 80 I=1,N +C STR = C1R*CYR(I) - C1I*CYI(I) +C STI = C1R*CYI(I) + C1I*CYR(I) +C STR = -STR + C2R*CWRKR(I) - C2I*CWRKI(I) +C STI = -STI + C2R*CWRKI(I) + C2I*CWRKR(I) +C CYR(I) = -STI*HCII +C CYI(I) = STR*HCII + AA = CWRKR(I) + BB = CWRKI(I) + ATOL = 1.0D0 + IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 75 + AA = AA*RTOL + BB = BB*RTOL + ATOL = TOL + 75 CONTINUE + STR = (AA*C2R - BB*C2I)*ATOL + STI = (AA*C2I + BB*C2R)*ATOL + AA = CYR(I) + BB = CYI(I) + ATOL = 1.0D0 + IF (DMAX1(DABS(AA),DABS(BB)).GT.ASCLE) GO TO 85 + AA = AA*RTOL + BB = BB*RTOL + ATOL = TOL + 85 CONTINUE + STR = STR - (AA*C1R - BB*C1I)*ATOL + STI = STI - (AA*C1I + BB*C1R)*ATOL + CYR(I) = -STI*HCII + CYI(I) = STR*HCII + IF (STR.EQ.0.0D0 .AND. STI.EQ.0.0D0 .AND. EY.EQ.0.0D0) NZ = NZ + * + 1 + 80 CONTINUE + RETURN + 90 CONTINUE + C1R = EXR + C1I = EXI + C2R = EXR*EY + C2I = -EXI*EY + GO TO 70 + 170 CONTINUE + NZ = 0 + RETURN + END diff --git a/amos/zbinu.f b/amos/zbinu.f new file mode 100644 index 0000000..7294f41 --- /dev/null +++ b/amos/zbinu.f @@ -0,0 +1,110 @@ + SUBROUTINE ZBINU(ZR, ZI, FNU, KODE, N, CYR, CYI, NZ, RL, FNUL, + * TOL, ELIM, ALIM) +C***BEGIN PROLOGUE ZBINU +C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZAIRY,ZBIRY +C +C ZBINU COMPUTES THE I FUNCTION IN THE RIGHT HALF Z PLANE +C +C***ROUTINES CALLED ZABS,ZASYI,ZBUNI,ZMLRI,ZSERI,ZUOIK,ZWRSK +C***END PROLOGUE ZBINU + DOUBLE PRECISION ALIM, AZ, CWI, CWR, CYI, CYR, DFNU, ELIM, FNU, + * FNUL, RL, TOL, ZEROI, ZEROR, ZI, ZR, ZABS + INTEGER I, INW, KODE, N, NLAST, NN, NUI, NW, NZ + DIMENSION CYR(N), CYI(N), CWR(2), CWI(2) + DATA ZEROR,ZEROI / 0.0D0, 0.0D0 / +C + NZ = 0 + AZ = ZABS(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 diff --git a/amos/zbknu.f b/amos/zbknu.f new file mode 100644 index 0000000..4d78d06 --- /dev/null +++ b/amos/zbknu.f @@ -0,0 +1,568 @@ + SUBROUTINE ZBKNU(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, + * ALIM) +C***BEGIN PROLOGUE ZBKNU +C***REFER TO ZBESI,ZBESK,ZAIRY,ZBESH +C +C ZBKNU COMPUTES THE K BESSEL FUNCTION IN THE RIGHT HALF Z PLANE. +C +C***ROUTINES CALLED DGAMLN,I1MACH,D1MACH,ZKSCL,ZSHCH,ZUCHK,ZABS,ZDIV, +C ZEXP,ZLOG,ZMLT,ZSQRT +C***END PROLOGUE ZBKNU +C + DOUBLE PRECISION AA, AK, ALIM, ASCLE, A1, A2, BB, BK, BRY, CAZ, + * CBI, CBR, CC, CCHI, CCHR, CKI, CKR, COEFI, COEFR, CONEI, CONER, + * CRSCR, CSCLR, CSHI, CSHR, CSI, CSR, CSRR, CSSR, CTWOR, + * CZEROI, CZEROR, CZI, CZR, DNU, DNU2, DPI, ELIM, ETEST, FC, FHS, + * FI, FK, FKS, FMUI, FMUR, FNU, FPI, FR, G1, G2, HPI, PI, PR, PTI, + * PTR, P1I, P1R, P2I, P2M, P2R, QI, QR, RAK, RCAZ, RTHPI, RZI, + * RZR, R1, S, SMUI, SMUR, SPI, STI, STR, S1I, S1R, S2I, S2R, TM, + * TOL, TTH, T1, T2, YI, YR, ZI, ZR, DGAMLN, D1MACH, ZABS, ELM, + * CELMR, ZDR, ZDI, AS, ALAS, HELIM, CYR, CYI + INTEGER I, IFLAG, INU, K, KFLAG, KK, KMAX, KODE, KODED, N, NZ, + * IDUM, I1MACH, J, IC, INUB, NW + DIMENSION YR(N), YI(N), CC(8), CSSR(3), CSRR(3), BRY(3), CYR(2), + * CYI(2) +C COMPLEX Z,Y,A,B,RZ,SMU,FU,FMU,F,FLRZ,CZ,S1,S2,CSH,CCH +C COMPLEX CK,P,Q,COEF,P1,P2,CBK,PT,CZERO,CONE,CTWO,ST,EZ,CS,DK +C + DATA KMAX / 30 / + DATA CZEROR,CZEROI,CONER,CONEI,CTWOR,R1/ + 1 0.0D0 , 0.0D0 , 1.0D0 , 0.0D0 , 2.0D0 , 2.0D0 / + DATA DPI, RTHPI, SPI ,HPI, FPI, TTH / + 1 3.14159265358979324D0, 1.25331413731550025D0, + 2 1.90985931710274403D0, 1.57079632679489662D0, + 3 1.89769999331517738D0, 6.66666666666666666D-01/ + DATA CC(1), CC(2), CC(3), CC(4), CC(5), CC(6), CC(7), CC(8)/ + 1 5.77215664901532861D-01, -4.20026350340952355D-02, + 2 -4.21977345555443367D-02, 7.21894324666309954D-03, + 3 -2.15241674114950973D-04, -2.01348547807882387D-05, + 4 1.13302723198169588D-06, 6.11609510448141582D-09/ +C + CAZ = ZABS(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 diff --git a/amos/zbuni.f b/amos/zbuni.f new file mode 100644 index 0000000..51cd547 --- /dev/null +++ b/amos/zbuni.f @@ -0,0 +1,174 @@ + SUBROUTINE ZBUNI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NUI, NLAST, + * FNUL, TOL, ELIM, ALIM) +C***BEGIN PROLOGUE ZBUNI +C***REFER TO ZBESI,ZBESK +C +C ZBUNI COMPUTES THE I BESSEL FUNCTION FOR LARGE CABS(Z).GT. +C FNUL AND FNU+N-1.LT.FNUL. THE ORDER IS INCREASED FROM +C FNU+N-1 GREATER THAN FNUL BY ADDING NUI AND COMPUTING +C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR I(FNU,Z) +C ON IFORM=1 AND THE EXPANSION FOR J(FNU,Z) ON IFORM=2 +C +C***ROUTINES CALLED ZUNI1,ZUNI2,ZABS,D1MACH +C***END PROLOGUE ZBUNI +C COMPLEX CSCL,CSCR,CY,RZ,ST,S1,S2,Y,Z + DOUBLE PRECISION ALIM, AX, AY, CSCLR, CSCRR, CYI, CYR, DFNU, + * ELIM, FNU, FNUI, FNUL, GNU, RAZ, RZI, RZR, STI, STR, S1I, S1R, + * S2I, S2R, TOL, YI, YR, ZI, ZR, ZABS, ASCLE, BRY, C1R, C1I, C1M, + * D1MACH + INTEGER I, IFLAG, IFORM, K, KODE, N, NL, NLAST, NUI, NW, NZ + DIMENSION YR(N), YI(N), CYR(2), CYI(2), BRY(3) + NZ = 0 + AX = DABS(ZR)*1.7321D0 + AY = DABS(ZI) + IFORM = 1 + IF (AY.GT.AX) IFORM = 2 + IF (NUI.EQ.0) GO TO 60 + FNUI = DBLE(FLOAT(NUI)) + DFNU = FNU + DBLE(FLOAT(N-1)) + GNU = DFNU + FNUI + IF (IFORM.EQ.2) GO TO 10 +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR I(FNU,Z) FOR LARGE FNU APPLIED IN +C -PI/3.LE.ARG(Z).LE.PI/3 +C----------------------------------------------------------------------- + CALL ZUNI1(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, + * ELIM, ALIM) + GO TO 20 + 10 CONTINUE +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR J(FNU,Z*EXP(M*HPI)) FOR LARGE FNU +C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I +C AND HPI=PI/2 +C----------------------------------------------------------------------- + CALL ZUNI2(ZR, ZI, GNU, KODE, 2, CYR, CYI, NW, NLAST, FNUL, TOL, + * ELIM, ALIM) + 20 CONTINUE + IF (NW.LT.0) GO TO 50 + IF (NW.NE.0) GO TO 90 + STR = ZABS(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 diff --git a/amos/zbunk.f b/amos/zbunk.f new file mode 100644 index 0000000..b20b79f --- /dev/null +++ b/amos/zbunk.f @@ -0,0 +1,35 @@ + SUBROUTINE ZBUNK(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, + * ALIM) +C***BEGIN PROLOGUE ZBUNK +C***REFER TO ZBESK,ZBESH +C +C ZBUNK COMPUTES THE K BESSEL FUNCTION FOR FNU.GT.FNUL. +C ACCORDING TO THE UNIFORM ASYMPTOTIC EXPANSION FOR K(FNU,Z) +C IN ZUNK1 AND THE EXPANSION FOR H(2,FNU,Z) IN ZUNK2 +C +C***ROUTINES CALLED ZUNK1,ZUNK2 +C***END PROLOGUE ZBUNK +C COMPLEX Y,Z + DOUBLE PRECISION ALIM, AX, AY, ELIM, FNU, TOL, YI, YR, ZI, ZR + INTEGER KODE, MR, N, NZ + DIMENSION YR(N), YI(N) + NZ = 0 + AX = DABS(ZR)*1.7321D0 + AY = DABS(ZI) + IF (AY.GT.AX) GO TO 10 +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR K(FNU,Z) FOR LARGE FNU APPLIED IN +C -PI/3.LE.ARG(Z).LE.PI/3 +C----------------------------------------------------------------------- + CALL ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM) + GO TO 20 + 10 CONTINUE +C----------------------------------------------------------------------- +C ASYMPTOTIC EXPANSION FOR H(2,FNU,Z*EXP(M*HPI)) FOR LARGE FNU +C APPLIED IN PI/3.LT.ABS(ARG(Z)).LE.PI/2 WHERE M=+I OR -I +C AND HPI=PI/2 +C----------------------------------------------------------------------- + CALL ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, ALIM) + 20 CONTINUE + RETURN + END diff --git a/amos/zdiv.f b/amos/zdiv.f new file mode 100644 index 0000000..1384d8e --- /dev/null +++ b/amos/zdiv.f @@ -0,0 +1,19 @@ + SUBROUTINE ZDIV(AR, AI, BR, BI, CR, CI) +C***BEGIN PROLOGUE ZDIV +C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY +C +C DOUBLE PRECISION COMPLEX DIVIDE C=A/B. +C +C***ROUTINES CALLED ZABS +C***END PROLOGUE ZDIV + DOUBLE PRECISION AR, AI, BR, BI, CR, CI, BM, CA, CB, CC, CD + DOUBLE PRECISION ZABS + BM = 1.0D0/ZABS(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 diff --git a/amos/zexp.f b/amos/zexp.f new file mode 100644 index 0000000..fcb553c --- /dev/null +++ b/amos/zexp.f @@ -0,0 +1,16 @@ + SUBROUTINE ZEXP(AR, AI, BR, BI) +C***BEGIN PROLOGUE ZEXP +C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY +C +C DOUBLE PRECISION COMPLEX EXPONENTIAL FUNCTION B=EXP(A) +C +C***ROUTINES CALLED (NONE) +C***END PROLOGUE ZEXP + DOUBLE PRECISION AR, AI, BR, BI, ZM, CA, CB + ZM = DEXP(AR) + CA = ZM*DCOS(AI) + CB = ZM*DSIN(AI) + BR = CA + BI = CB + RETURN + END diff --git a/amos/zkscl.f b/amos/zkscl.f new file mode 100644 index 0000000..e051745 --- /dev/null +++ b/amos/zkscl.f @@ -0,0 +1,121 @@ + SUBROUTINE ZKSCL(ZRR,ZRI,FNU,N,YR,YI,NZ,RZR,RZI,ASCLE,TOL,ELIM) +C***BEGIN PROLOGUE ZKSCL +C***REFER TO ZBESK +C +C SET K FUNCTIONS TO ZERO ON UNDERFLOW, CONTINUE RECURRENCE +C ON SCALED FUNCTIONS UNTIL TWO MEMBERS COME ON SCALE, THEN +C RETURN WITH MIN(NZ+2,N) VALUES SCALED BY 1/TOL. +C +C***ROUTINES CALLED ZUCHK,ZABS,ZLOG +C***END PROLOGUE ZKSCL +C COMPLEX CK,CS,CY,CZERO,RZ,S1,S2,Y,ZR,ZD,CELM + DOUBLE PRECISION ACS, AS, ASCLE, CKI, CKR, CSI, CSR, CYI, + * CYR, ELIM, FN, FNU, RZI, RZR, STR, S1I, S1R, S2I, + * S2R, TOL, YI, YR, ZEROI, ZEROR, ZRI, ZRR, ZABS, + * ZDR, ZDI, CELMR, ELM, HELIM, ALAS + INTEGER I, IC, IDUM, KK, N, NN, NW, NZ + DIMENSION YR(N), YI(N), CYR(2), CYI(2) + DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 / +C + NZ = 0 + IC = 0 + NN = MIN0(2,N) + DO 10 I=1,NN + S1R = YR(I) + S1I = YI(I) + CYR(I) = S1R + CYI(I) = S1I + AS = ZABS(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 diff --git a/amos/zlog.f b/amos/zlog.f new file mode 100644 index 0000000..a9368d5 --- /dev/null +++ b/amos/zlog.f @@ -0,0 +1,41 @@ + SUBROUTINE ZLOG(AR, AI, BR, BI, IERR) +C***BEGIN PROLOGUE ZLOG +C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY +C +C DOUBLE PRECISION COMPLEX LOGARITHM B=CLOG(A) +C IERR=0,NORMAL RETURN IERR=1, Z=CMPLX(0.0,0.0) +C***ROUTINES CALLED ZABS +C***END PROLOGUE ZLOG + DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DHPI + DOUBLE PRECISION ZABS + DATA DPI , DHPI / 3.141592653589793238462643383D+0, + 1 1.570796326794896619231321696D+0/ +C + IERR=0 + IF (AR.EQ.0.0D+0) GO TO 10 + IF (AI.EQ.0.0D+0) GO TO 20 + DTHETA = DATAN(AI/AR) + IF (DTHETA.LE.0.0D+0) GO TO 40 + IF (AR.LT.0.0D+0) DTHETA = DTHETA - DPI + GO TO 50 + 10 IF (AI.EQ.0.0D+0) GO TO 60 + BI = DHPI + BR = DLOG(DABS(AI)) + IF (AI.LT.0.0D+0) BI = -BI + RETURN + 20 IF (AR.GT.0.0D+0) GO TO 30 + BR = DLOG(DABS(AR)) + BI = DPI + RETURN + 30 BR = DLOG(AR) + BI = 0.0D+0 + RETURN + 40 IF (AR.LT.0.0D+0) DTHETA = DTHETA + DPI + 50 ZM = ZABS(AR,AI) + BR = DLOG(ZM) + BI = DTHETA + RETURN + 60 CONTINUE + IERR=1 + RETURN + END diff --git a/amos/zmlri.f b/amos/zmlri.f new file mode 100644 index 0000000..27a5547 --- /dev/null +++ b/amos/zmlri.f @@ -0,0 +1,204 @@ + SUBROUTINE ZMLRI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL) +C***BEGIN PROLOGUE ZMLRI +C***REFER TO ZBESI,ZBESK +C +C ZMLRI COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY THE +C MILLER ALGORITHM NORMALIZED BY A NEUMANN SERIES. +C +C***ROUTINES CALLED DGAMLN,D1MACH,ZABS,ZEXP,ZLOG,ZMLT +C***END PROLOGUE ZMLRI +C COMPLEX CK,CNORM,CONE,CTWO,CZERO,PT,P1,P2,RZ,SUM,Y,Z + DOUBLE PRECISION ACK, AK, AP, AT, AZ, BK, CKI, CKR, CNORMI, + * CNORMR, CONEI, CONER, FKAP, FKK, FLAM, FNF, FNU, PTI, PTR, P1I, + * P1R, P2I, P2R, RAZ, RHO, RHO2, RZI, RZR, SCLE, STI, STR, SUMI, + * SUMR, TFNF, TOL, TST, YI, YR, ZEROI, ZEROR, ZI, ZR, DGAMLN, + * D1MACH, ZABS + INTEGER I, IAZ, IDUM, IFNU, INU, ITIME, K, KK, KM, KODE, M, N, NZ + DIMENSION YR(N), YI(N) + DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / + SCLE = D1MACH(1)/TOL + NZ=0 + AZ = ZABS(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 diff --git a/amos/zmlt.f b/amos/zmlt.f new file mode 100644 index 0000000..3bde7d3 --- /dev/null +++ b/amos/zmlt.f @@ -0,0 +1,15 @@ + SUBROUTINE ZMLT(AR, AI, BR, BI, CR, CI) +C***BEGIN PROLOGUE ZMLT +C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY +C +C DOUBLE PRECISION COMPLEX MULTIPLY, C=A*B. +C +C***ROUTINES CALLED (NONE) +C***END PROLOGUE ZMLT + DOUBLE PRECISION AR, AI, BR, BI, CR, CI, CA, CB + CA = AR*BR - AI*BI + CB = AR*BI + AI*BR + CR = CA + CI = CB + RETURN + END diff --git a/amos/zrati.f b/amos/zrati.f new file mode 100644 index 0000000..0458918 --- /dev/null +++ b/amos/zrati.f @@ -0,0 +1,132 @@ + SUBROUTINE ZRATI(ZR, ZI, FNU, N, CYR, CYI, TOL) +C***BEGIN PROLOGUE ZRATI +C***REFER TO ZBESI,ZBESK,ZBESH +C +C ZRATI COMPUTES RATIOS OF I BESSEL FUNCTIONS BY BACKWARD +C RECURRENCE. THE STARTING INDEX IS DETERMINED BY FORWARD +C RECURRENCE AS DESCRIBED IN J. RES. OF NAT. BUR. OF STANDARDS-B, +C MATHEMATICAL SCIENCES, VOL 77B, P111-114, SEPTEMBER, 1973, +C BESSEL FUNCTIONS I AND J OF COMPLEX ARGUMENT AND INTEGER ORDER, +C BY D. J. SOOKNE. +C +C***ROUTINES CALLED ZABS,ZDIV +C***END PROLOGUE ZRATI +C COMPLEX Z,CY(1),CONE,CZERO,P1,P2,T1,RZ,PT,CDFNU + DOUBLE PRECISION AK, AMAGZ, AP1, AP2, ARG, AZ, CDFNUI, CDFNUR, + * CONEI, CONER, CYI, CYR, CZEROI, CZEROR, DFNU, FDNU, FLAM, FNU, + * FNUP, PTI, PTR, P1I, P1R, P2I, P2R, RAK, RAP1, RHO, RT2, RZI, + * RZR, TEST, TEST1, TOL, TTI, TTR, T1I, T1R, ZI, ZR, ZABS + INTEGER I, ID, IDNU, INU, ITIME, K, KK, MAGZ, N + DIMENSION CYR(N), CYI(N) + DATA CZEROR,CZEROI,CONER,CONEI,RT2/ + 1 0.0D0, 0.0D0, 1.0D0, 0.0D0, 1.41421356237309505D0 / + AZ = ZABS(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 diff --git a/amos/zs1s2.f b/amos/zs1s2.f new file mode 100644 index 0000000..749e57e --- /dev/null +++ b/amos/zs1s2.f @@ -0,0 +1,49 @@ + SUBROUTINE ZS1S2(ZRR, ZRI, S1R, S1I, S2R, S2I, NZ, ASCLE, ALIM, + * IUF) +C***BEGIN PROLOGUE ZS1S2 +C***REFER TO ZBESK,ZAIRY +C +C ZS1S2 TESTS FOR A POSSIBLE UNDERFLOW RESULTING FROM THE +C ADDITION OF THE I AND K FUNCTIONS IN THE ANALYTIC CON- +C TINUATION FORMULA WHERE S1=K FUNCTION AND S2=I FUNCTION. +C ON KODE=1 THE I AND K FUNCTIONS ARE DIFFERENT ORDERS OF +C MAGNITUDE, BUT FOR KODE=2 THEY CAN BE OF THE SAME ORDER +C OF MAGNITUDE AND THE MAXIMUM MUST BE AT LEAST ONE +C PRECISION ABOVE THE UNDERFLOW LIMIT. +C +C***ROUTINES CALLED ZABS,ZEXP,ZLOG +C***END PROLOGUE ZS1S2 +C COMPLEX CZERO,C1,S1,S1D,S2,ZR + DOUBLE PRECISION AA, ALIM, ALN, ASCLE, AS1, AS2, C1I, C1R, S1DI, + * S1DR, S1I, S1R, S2I, S2R, ZEROI, ZEROR, ZRI, ZRR, ZABS + INTEGER IUF, IDUM, NZ + DATA ZEROR,ZEROI / 0.0D0 , 0.0D0 / + NZ = 0 + AS1 = ZABS(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 diff --git a/amos/zseri.f b/amos/zseri.f new file mode 100644 index 0000000..2e8e14a --- /dev/null +++ b/amos/zseri.f @@ -0,0 +1,190 @@ + SUBROUTINE ZSERI(ZR, ZI, FNU, KODE, N, YR, YI, NZ, TOL, ELIM, + * ALIM) +C***BEGIN PROLOGUE ZSERI +C***REFER TO ZBESI,ZBESK +C +C ZSERI COMPUTES THE I BESSEL FUNCTION FOR REAL(Z).GE.0.0 BY +C MEANS OF THE POWER SERIES FOR LARGE CABS(Z) IN THE +C REGION CABS(Z).LE.2*SQRT(FNU+1). NZ=0 IS A NORMAL RETURN. +C NZ.GT.0 MEANS THAT THE LAST NZ COMPONENTS WERE SET TO ZERO +C DUE TO UNDERFLOW. NZ.LT.0 MEANS UNDERFLOW OCCURRED, BUT THE +C CONDITION CABS(Z).LE.2*SQRT(FNU+1) WAS VIOLATED AND THE +C COMPUTATION MUST BE COMPLETED IN ANOTHER ROUTINE WITH N=N-ABS(NZ). +C +C***ROUTINES CALLED DGAMLN,D1MACH,ZUCHK,ZABS,ZDIV,ZLOG,ZMLT +C***END PROLOGUE ZSERI +C COMPLEX AK1,CK,COEF,CONE,CRSC,CSCL,CZ,CZERO,HZ,RZ,S1,S2,Y,Z + DOUBLE PRECISION AA, ACZ, AK, AK1I, AK1R, ALIM, ARM, ASCLE, ATOL, + * AZ, CKI, CKR, COEFI, COEFR, CONEI, CONER, CRSCR, CZI, CZR, DFNU, + * ELIM, FNU, FNUP, HZI, HZR, RAZ, RS, RTR1, RZI, RZR, S, SS, STI, + * STR, S1I, S1R, S2I, S2R, TOL, YI, YR, WI, WR, ZEROI, ZEROR, ZI, + * ZR, DGAMLN, D1MACH, ZABS + INTEGER I, IB, IDUM, IFLAG, IL, K, KODE, L, M, N, NN, NZ, NW + DIMENSION YR(N), YI(N), WR(2), WI(2) + DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / +C + NZ = 0 + AZ = ZABS(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 diff --git a/amos/zshch.f b/amos/zshch.f new file mode 100644 index 0000000..168e62e --- /dev/null +++ b/amos/zshch.f @@ -0,0 +1,22 @@ + SUBROUTINE ZSHCH(ZR, ZI, CSHR, CSHI, CCHR, CCHI) +C***BEGIN PROLOGUE ZSHCH +C***REFER TO ZBESK,ZBESH +C +C ZSHCH COMPUTES THE COMPLEX HYPERBOLIC FUNCTIONS CSH=SINH(X+I*Y) +C AND CCH=COSH(X+I*Y), WHERE I**2=-1. +C +C***ROUTINES CALLED (NONE) +C***END PROLOGUE ZSHCH +C + DOUBLE PRECISION CCHI, CCHR, CH, CN, CSHI, CSHR, SH, SN, ZI, ZR, + * DCOSH, DSINH + SH = DSINH(ZR) + CH = DCOSH(ZR) + SN = DSIN(ZI) + CN = DCOS(ZI) + CSHR = SH*CN + CSHI = CH*SN + CCHR = CH*CN + CCHI = SH*SN + RETURN + END diff --git a/amos/zsqrt.f b/amos/zsqrt.f new file mode 100644 index 0000000..08c17cc --- /dev/null +++ b/amos/zsqrt.f @@ -0,0 +1,44 @@ + SUBROUTINE ZSQRT(AR, AI, BR, BI) +C***BEGIN PROLOGUE ZSQRT +C***REFER TO ZBESH,ZBESI,ZBESJ,ZBESK,ZBESY,ZAIRY,ZBIRY +C +C DOUBLE PRECISION COMPLEX SQUARE ROOT, B=CSQRT(A) +C +C***ROUTINES CALLED ZABS +C***END PROLOGUE ZSQRT + DOUBLE PRECISION AR, AI, BR, BI, ZM, DTHETA, DPI, DRT + DOUBLE PRECISION ZABS + DATA DRT , DPI / 7.071067811865475244008443621D-1, + 1 3.141592653589793238462643383D+0/ + ZM = ZABS(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 diff --git a/amos/zuchk.f b/amos/zuchk.f new file mode 100644 index 0000000..d15dc84 --- /dev/null +++ b/amos/zuchk.f @@ -0,0 +1,28 @@ + SUBROUTINE ZUCHK(YR, YI, NZ, ASCLE, TOL) +C***BEGIN PROLOGUE ZUCHK +C***REFER TO ZSERI,ZUOIK,ZUNK1,ZUNK2,ZUNI1,ZUNI2,ZKSCL +C +C Y ENTERS AS A SCALED QUANTITY WHOSE MAGNITUDE IS GREATER THAN +C EXP(-ALIM)=ASCLE=1.0E+3*D1MACH(1)/TOL. THE TEST IS MADE TO SEE +C IF THE MAGNITUDE OF THE REAL OR IMAGINARY PART WOULD UNDERFLOW +C WHEN Y IS SCALED (BY TOL) TO ITS PROPER VALUE. Y IS ACCEPTED +C IF THE UNDERFLOW IS AT LEAST ONE PRECISION BELOW THE MAGNITUDE +C OF THE LARGEST COMPONENT; OTHERWISE THE PHASE ANGLE DOES NOT HAVE +C ABSOLUTE ACCURACY AND AN UNDERFLOW IS ASSUMED. +C +C***ROUTINES CALLED (NONE) +C***END PROLOGUE ZUCHK +C +C COMPLEX Y + DOUBLE PRECISION ASCLE, SS, ST, TOL, WR, WI, YR, YI + INTEGER NZ + NZ = 0 + WR = DABS(YR) + WI = DABS(YI) + ST = DMIN1(WR,WI) + IF (ST.GT.ASCLE) RETURN + SS = DMAX1(WR,WI) + ST = ST/TOL + IF (SS.LT.ST) NZ = 1 + RETURN + END diff --git a/amos/zunhj.f b/amos/zunhj.f new file mode 100644 index 0000000..41ecc24 --- /dev/null +++ b/amos/zunhj.f @@ -0,0 +1,714 @@ + SUBROUTINE ZUNHJ(ZR, ZI, FNU, IPMTR, TOL, PHIR, PHII, ARGR, ARGI, + * ZETA1R, ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) +C***BEGIN PROLOGUE ZUNHJ +C***REFER TO ZBESI,ZBESK +C +C REFERENCES +C HANDBOOK OF MATHEMATICAL FUNCTIONS BY M. ABRAMOWITZ AND I.A. +C STEGUN, AMS55, NATIONAL BUREAU OF STANDARDS, 1965, CHAPTER 9. +C +C ASYMPTOTICS AND SPECIAL FUNCTIONS BY F.W.J. OLVER, ACADEMIC +C PRESS, N.Y., 1974, PAGE 420 +C +C ABSTRACT +C ZUNHJ COMPUTES PARAMETERS FOR BESSEL FUNCTIONS C(FNU,Z) = +C J(FNU,Z), Y(FNU,Z) OR H(I,FNU,Z) I=1,2 FOR LARGE ORDERS FNU +C BY MEANS OF THE UNIFORM ASYMPTOTIC EXPANSION +C +C C(FNU,Z)=C1*PHI*( ASUM*AIRY(ARG) + C2*BSUM*DAIRY(ARG) ) +C +C FOR PROPER CHOICES OF C1, C2, AIRY AND DAIRY WHERE AIRY IS +C AN AIRY FUNCTION AND DAIRY IS ITS DERIVATIVE. +C +C (2/3)*FNU*ZETA**1.5 = ZETA1-ZETA2, +C +C ZETA1=0.5*FNU*CLOG((1+W)/(1-W)), ZETA2=FNU*W FOR SCALING +C PURPOSES IN AIRY FUNCTIONS FROM CAIRY OR CBIRY. +C +C MCONJ=SIGN OF AIMAG(Z), BUT IS AMBIGUOUS WHEN Z IS REAL AND +C MUST BE SPECIFIED. IPMTR=0 RETURNS ALL PARAMETERS. IPMTR= +C 1 COMPUTES ALL EXCEPT ASUM AND BSUM. +C +C***ROUTINES CALLED ZABS,ZDIV,ZLOG,ZSQRT,D1MACH +C***END PROLOGUE ZUNHJ +C COMPLEX ARG,ASUM,BSUM,CFNU,CONE,CR,CZERO,DR,P,PHI,PRZTH,PTFN, +C *RFN13,RTZTA,RZTH,SUMA,SUMB,TFN,T2,UP,W,W2,Z,ZA,ZB,ZC,ZETA,ZETA1, +C *ZETA2,ZTH + DOUBLE PRECISION ALFA, ANG, AP, AR, ARGI, ARGR, ASUMI, ASUMR, + * ATOL, AW2, AZTH, BETA, BR, BSUMI, BSUMR, BTOL, C, CONEI, CONER, + * CRI, CRR, DRI, DRR, EX1, EX2, FNU, FN13, FN23, GAMA, GPI, HPI, + * PHII, PHIR, PI, PP, PR, PRZTHI, PRZTHR, PTFNI, PTFNR, RAW, RAW2, + * RAZTH, RFNU, RFNU2, RFN13, RTZTI, RTZTR, RZTHI, RZTHR, STI, STR, + * SUMAI, SUMAR, SUMBI, SUMBR, TEST, TFNI, TFNR, THPI, TOL, TZAI, + * TZAR, T2I, T2R, UPI, UPR, WI, WR, W2I, W2R, ZAI, ZAR, ZBI, ZBR, + * ZCI, ZCR, ZEROI, ZEROR, ZETAI, ZETAR, ZETA1I, ZETA1R, ZETA2I, + * ZETA2R, ZI, ZR, ZTHI, ZTHR, ZABS, AC, D1MACH + INTEGER IAS, IBS, IPMTR, IS, J, JR, JU, K, KMAX, KP1, KS, L, LR, + * LRP1, L1, L2, M, IDUM + DIMENSION AR(14), BR(14), C(105), ALFA(180), BETA(210), GAMA(30), + * AP(30), PR(30), PI(30), UPR(14), UPI(14), CRR(14), CRI(14), + * DRR(14), DRI(14) + DATA AR(1), AR(2), AR(3), AR(4), AR(5), AR(6), AR(7), AR(8), + 1 AR(9), AR(10), AR(11), AR(12), AR(13), AR(14)/ + 2 1.00000000000000000D+00, 1.04166666666666667D-01, + 3 8.35503472222222222D-02, 1.28226574556327160D-01, + 4 2.91849026464140464D-01, 8.81627267443757652D-01, + 5 3.32140828186276754D+00, 1.49957629868625547D+01, + 6 7.89230130115865181D+01, 4.74451538868264323D+02, + 7 3.20749009089066193D+03, 2.40865496408740049D+04, + 8 1.98923119169509794D+05, 1.79190200777534383D+06/ + DATA BR(1), BR(2), BR(3), BR(4), BR(5), BR(6), BR(7), BR(8), + 1 BR(9), BR(10), BR(11), BR(12), BR(13), BR(14)/ + 2 1.00000000000000000D+00, -1.45833333333333333D-01, + 3 -9.87413194444444444D-02, -1.43312053915895062D-01, + 4 -3.17227202678413548D-01, -9.42429147957120249D-01, + 5 -3.51120304082635426D+00, -1.57272636203680451D+01, + 6 -8.22814390971859444D+01, -4.92355370523670524D+02, + 7 -3.31621856854797251D+03, -2.48276742452085896D+04, + 8 -2.04526587315129788D+05, -1.83844491706820990D+06/ + DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), + 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), + 2 C(19), C(20), C(21), C(22), C(23), C(24)/ + 3 1.00000000000000000D+00, -2.08333333333333333D-01, + 4 1.25000000000000000D-01, 3.34201388888888889D-01, + 5 -4.01041666666666667D-01, 7.03125000000000000D-02, + 6 -1.02581259645061728D+00, 1.84646267361111111D+00, + 7 -8.91210937500000000D-01, 7.32421875000000000D-02, + 8 4.66958442342624743D+00, -1.12070026162229938D+01, + 9 8.78912353515625000D+00, -2.36408691406250000D+00, + A 1.12152099609375000D-01, -2.82120725582002449D+01, + B 8.46362176746007346D+01, -9.18182415432400174D+01, + C 4.25349987453884549D+01, -7.36879435947963170D+00, + D 2.27108001708984375D-01, 2.12570130039217123D+02, + E -7.65252468141181642D+02, 1.05999045252799988D+03/ + DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), + 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), + 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ + 3 -6.99579627376132541D+02, 2.18190511744211590D+02, + 4 -2.64914304869515555D+01, 5.72501420974731445D-01, + 5 -1.91945766231840700D+03, 8.06172218173730938D+03, + 6 -1.35865500064341374D+04, 1.16553933368645332D+04, + 7 -5.30564697861340311D+03, 1.20090291321635246D+03, + 8 -1.08090919788394656D+02, 1.72772750258445740D+00, + 9 2.02042913309661486D+04, -9.69805983886375135D+04, + A 1.92547001232531532D+05, -2.03400177280415534D+05, + B 1.22200464983017460D+05, -4.11926549688975513D+04, + C 7.10951430248936372D+03, -4.93915304773088012D+02, + D 6.07404200127348304D+00, -2.42919187900551333D+05, + E 1.31176361466297720D+06, -2.99801591853810675D+06/ + DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), + 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), + 2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ + 3 3.76327129765640400D+06, -2.81356322658653411D+06, + 4 1.26836527332162478D+06, -3.31645172484563578D+05, + 5 4.52187689813627263D+04, -2.49983048181120962D+03, + 6 2.43805296995560639D+01, 3.28446985307203782D+06, + 7 -1.97068191184322269D+07, 5.09526024926646422D+07, + 8 -7.41051482115326577D+07, 6.63445122747290267D+07, + 9 -3.75671766607633513D+07, 1.32887671664218183D+07, + A -2.78561812808645469D+06, 3.08186404612662398D+05, + B -1.38860897537170405D+04, 1.10017140269246738D+02, + C -4.93292536645099620D+07, 3.25573074185765749D+08, + D -9.39462359681578403D+08, 1.55359689957058006D+09, + E -1.62108055210833708D+09, 1.10684281682301447D+09/ + DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), + 1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), + 2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ + 3 -4.95889784275030309D+08, 1.42062907797533095D+08, + 4 -2.44740627257387285D+07, 2.24376817792244943D+06, + 5 -8.40054336030240853D+04, 5.51335896122020586D+02, + 6 8.14789096118312115D+08, -5.86648149205184723D+09, + 7 1.86882075092958249D+10, -3.46320433881587779D+10, + 8 4.12801855797539740D+10, -3.30265997498007231D+10, + 9 1.79542137311556001D+10, -6.56329379261928433D+09, + A 1.55927986487925751D+09, -2.25105661889415278D+08, + B 1.73951075539781645D+07, -5.49842327572288687D+05, + C 3.03809051092238427D+03, -1.46792612476956167D+10, + D 1.14498237732025810D+11, -3.99096175224466498D+11, + E 8.19218669548577329D+11, -1.09837515608122331D+12/ + DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), + 1 C(105)/ + 2 1.00815810686538209D+12, -6.45364869245376503D+11, + 3 2.87900649906150589D+11, -8.78670721780232657D+10, + 4 1.76347306068349694D+10, -2.16716498322379509D+09, + 5 1.43157876718888981D+08, -3.87183344257261262D+06, + 6 1.82577554742931747D+04/ + DATA ALFA(1), ALFA(2), ALFA(3), ALFA(4), ALFA(5), ALFA(6), + 1 ALFA(7), ALFA(8), ALFA(9), ALFA(10), ALFA(11), ALFA(12), + 2 ALFA(13), ALFA(14), ALFA(15), ALFA(16), ALFA(17), ALFA(18), + 3 ALFA(19), ALFA(20), ALFA(21), ALFA(22)/ + 4 -4.44444444444444444D-03, -9.22077922077922078D-04, + 5 -8.84892884892884893D-05, 1.65927687832449737D-04, + 6 2.46691372741792910D-04, 2.65995589346254780D-04, + 7 2.61824297061500945D-04, 2.48730437344655609D-04, + 8 2.32721040083232098D-04, 2.16362485712365082D-04, + 9 2.00738858762752355D-04, 1.86267636637545172D-04, + A 1.73060775917876493D-04, 1.61091705929015752D-04, + B 1.50274774160908134D-04, 1.40503497391269794D-04, + C 1.31668816545922806D-04, 1.23667445598253261D-04, + D 1.16405271474737902D-04, 1.09798298372713369D-04, + E 1.03772410422992823D-04, 9.82626078369363448D-05/ + DATA ALFA(23), ALFA(24), ALFA(25), ALFA(26), ALFA(27), ALFA(28), + 1 ALFA(29), ALFA(30), ALFA(31), ALFA(32), ALFA(33), ALFA(34), + 2 ALFA(35), ALFA(36), ALFA(37), ALFA(38), ALFA(39), ALFA(40), + 3 ALFA(41), ALFA(42), ALFA(43), ALFA(44)/ + 4 9.32120517249503256D-05, 8.85710852478711718D-05, + 5 8.42963105715700223D-05, 8.03497548407791151D-05, + 6 7.66981345359207388D-05, 7.33122157481777809D-05, + 7 7.01662625163141333D-05, 6.72375633790160292D-05, + 8 6.93735541354588974D-04, 2.32241745182921654D-04, + 9 -1.41986273556691197D-05, -1.16444931672048640D-04, + A -1.50803558053048762D-04, -1.55121924918096223D-04, + B -1.46809756646465549D-04, -1.33815503867491367D-04, + C -1.19744975684254051D-04, -1.06184319207974020D-04, + D -9.37699549891194492D-05, -8.26923045588193274D-05, + E -7.29374348155221211D-05, -6.44042357721016283D-05/ + DATA ALFA(45), ALFA(46), ALFA(47), ALFA(48), ALFA(49), ALFA(50), + 1 ALFA(51), ALFA(52), ALFA(53), ALFA(54), ALFA(55), ALFA(56), + 2 ALFA(57), ALFA(58), ALFA(59), ALFA(60), ALFA(61), ALFA(62), + 3 ALFA(63), ALFA(64), ALFA(65), ALFA(66)/ + 4 -5.69611566009369048D-05, -5.04731044303561628D-05, + 5 -4.48134868008882786D-05, -3.98688727717598864D-05, + 6 -3.55400532972042498D-05, -3.17414256609022480D-05, + 7 -2.83996793904174811D-05, -2.54522720634870566D-05, + 8 -2.28459297164724555D-05, -2.05352753106480604D-05, + 9 -1.84816217627666085D-05, -1.66519330021393806D-05, + A -1.50179412980119482D-05, -1.35554031379040526D-05, + B -1.22434746473858131D-05, -1.10641884811308169D-05, + C -3.54211971457743841D-04, -1.56161263945159416D-04, + D 3.04465503594936410D-05, 1.30198655773242693D-04, + E 1.67471106699712269D-04, 1.70222587683592569D-04/ + DATA ALFA(67), ALFA(68), ALFA(69), ALFA(70), ALFA(71), ALFA(72), + 1 ALFA(73), ALFA(74), ALFA(75), ALFA(76), ALFA(77), ALFA(78), + 2 ALFA(79), ALFA(80), ALFA(81), ALFA(82), ALFA(83), ALFA(84), + 3 ALFA(85), ALFA(86), ALFA(87), ALFA(88)/ + 4 1.56501427608594704D-04, 1.36339170977445120D-04, + 5 1.14886692029825128D-04, 9.45869093034688111D-05, + 6 7.64498419250898258D-05, 6.07570334965197354D-05, + 7 4.74394299290508799D-05, 3.62757512005344297D-05, + 8 2.69939714979224901D-05, 1.93210938247939253D-05, + 9 1.30056674793963203D-05, 7.82620866744496661D-06, + A 3.59257485819351583D-06, 1.44040049814251817D-07, + B -2.65396769697939116D-06, -4.91346867098485910D-06, + C -6.72739296091248287D-06, -8.17269379678657923D-06, + D -9.31304715093561232D-06, -1.02011418798016441D-05, + E -1.08805962510592880D-05, -1.13875481509603555D-05/ + DATA ALFA(89), ALFA(90), ALFA(91), ALFA(92), ALFA(93), ALFA(94), + 1 ALFA(95), ALFA(96), ALFA(97), ALFA(98), ALFA(99), ALFA(100), + 2 ALFA(101), ALFA(102), ALFA(103), ALFA(104), ALFA(105), + 3 ALFA(106), ALFA(107), ALFA(108), ALFA(109), ALFA(110)/ + 4 -1.17519675674556414D-05, -1.19987364870944141D-05, + 5 3.78194199201772914D-04, 2.02471952761816167D-04, + 6 -6.37938506318862408D-05, -2.38598230603005903D-04, + 7 -3.10916256027361568D-04, -3.13680115247576316D-04, + 8 -2.78950273791323387D-04, -2.28564082619141374D-04, + 9 -1.75245280340846749D-04, -1.25544063060690348D-04, + A -8.22982872820208365D-05, -4.62860730588116458D-05, + B -1.72334302366962267D-05, 5.60690482304602267D-06, + C 2.31395443148286800D-05, 3.62642745856793957D-05, + D 4.58006124490188752D-05, 5.24595294959114050D-05, + E 5.68396208545815266D-05, 5.94349820393104052D-05/ + DATA ALFA(111), ALFA(112), ALFA(113), ALFA(114), ALFA(115), + 1 ALFA(116), ALFA(117), ALFA(118), ALFA(119), ALFA(120), + 2 ALFA(121), ALFA(122), ALFA(123), ALFA(124), ALFA(125), + 3 ALFA(126), ALFA(127), ALFA(128), ALFA(129), ALFA(130)/ + 4 6.06478527578421742D-05, 6.08023907788436497D-05, + 5 6.01577894539460388D-05, 5.89199657344698500D-05, + 6 5.72515823777593053D-05, 5.52804375585852577D-05, + 7 5.31063773802880170D-05, 5.08069302012325706D-05, + 8 4.84418647620094842D-05, 4.60568581607475370D-05, + 9 -6.91141397288294174D-04, -4.29976633058871912D-04, + A 1.83067735980039018D-04, 6.60088147542014144D-04, + B 8.75964969951185931D-04, 8.77335235958235514D-04, + C 7.49369585378990637D-04, 5.63832329756980918D-04, + D 3.68059319971443156D-04, 1.88464535514455599D-04/ + DATA ALFA(131), ALFA(132), ALFA(133), ALFA(134), ALFA(135), + 1 ALFA(136), ALFA(137), ALFA(138), ALFA(139), ALFA(140), + 2 ALFA(141), ALFA(142), ALFA(143), ALFA(144), ALFA(145), + 3 ALFA(146), ALFA(147), ALFA(148), ALFA(149), ALFA(150)/ + 4 3.70663057664904149D-05, -8.28520220232137023D-05, + 5 -1.72751952869172998D-04, -2.36314873605872983D-04, + 6 -2.77966150694906658D-04, -3.02079514155456919D-04, + 7 -3.12594712643820127D-04, -3.12872558758067163D-04, + 8 -3.05678038466324377D-04, -2.93226470614557331D-04, + 9 -2.77255655582934777D-04, -2.59103928467031709D-04, + A -2.39784014396480342D-04, -2.20048260045422848D-04, + B -2.00443911094971498D-04, -1.81358692210970687D-04, + C -1.63057674478657464D-04, -1.45712672175205844D-04, + D -1.29425421983924587D-04, -1.14245691942445952D-04/ + DATA ALFA(151), ALFA(152), ALFA(153), ALFA(154), ALFA(155), + 1 ALFA(156), ALFA(157), ALFA(158), ALFA(159), ALFA(160), + 2 ALFA(161), ALFA(162), ALFA(163), ALFA(164), ALFA(165), + 3 ALFA(166), ALFA(167), ALFA(168), ALFA(169), ALFA(170)/ + 4 1.92821964248775885D-03, 1.35592576302022234D-03, + 5 -7.17858090421302995D-04, -2.58084802575270346D-03, + 6 -3.49271130826168475D-03, -3.46986299340960628D-03, + 7 -2.82285233351310182D-03, -1.88103076404891354D-03, + 8 -8.89531718383947600D-04, 3.87912102631035228D-06, + 9 7.28688540119691412D-04, 1.26566373053457758D-03, + A 1.62518158372674427D-03, 1.83203153216373172D-03, + B 1.91588388990527909D-03, 1.90588846755546138D-03, + C 1.82798982421825727D-03, 1.70389506421121530D-03, + D 1.55097127171097686D-03, 1.38261421852276159D-03/ + DATA ALFA(171), ALFA(172), ALFA(173), ALFA(174), ALFA(175), + 1 ALFA(176), ALFA(177), ALFA(178), ALFA(179), ALFA(180)/ + 2 1.20881424230064774D-03, 1.03676532638344962D-03, + 3 8.71437918068619115D-04, 7.16080155297701002D-04, + 4 5.72637002558129372D-04, 4.42089819465802277D-04, + 5 3.24724948503090564D-04, 2.20342042730246599D-04, + 6 1.28412898401353882D-04, 4.82005924552095464D-05/ + DATA BETA(1), BETA(2), BETA(3), BETA(4), BETA(5), BETA(6), + 1 BETA(7), BETA(8), BETA(9), BETA(10), BETA(11), BETA(12), + 2 BETA(13), BETA(14), BETA(15), BETA(16), BETA(17), BETA(18), + 3 BETA(19), BETA(20), BETA(21), BETA(22)/ + 4 1.79988721413553309D-02, 5.59964911064388073D-03, + 5 2.88501402231132779D-03, 1.80096606761053941D-03, + 6 1.24753110589199202D-03, 9.22878876572938311D-04, + 7 7.14430421727287357D-04, 5.71787281789704872D-04, + 8 4.69431007606481533D-04, 3.93232835462916638D-04, + 9 3.34818889318297664D-04, 2.88952148495751517D-04, + A 2.52211615549573284D-04, 2.22280580798883327D-04, + B 1.97541838033062524D-04, 1.76836855019718004D-04, + C 1.59316899661821081D-04, 1.44347930197333986D-04, + D 1.31448068119965379D-04, 1.20245444949302884D-04, + E 1.10449144504599392D-04, 1.01828770740567258D-04/ + DATA BETA(23), BETA(24), BETA(25), BETA(26), BETA(27), BETA(28), + 1 BETA(29), BETA(30), BETA(31), BETA(32), BETA(33), BETA(34), + 2 BETA(35), BETA(36), BETA(37), BETA(38), BETA(39), BETA(40), + 3 BETA(41), BETA(42), BETA(43), BETA(44)/ + 4 9.41998224204237509D-05, 8.74130545753834437D-05, + 5 8.13466262162801467D-05, 7.59002269646219339D-05, + 6 7.09906300634153481D-05, 6.65482874842468183D-05, + 7 6.25146958969275078D-05, 5.88403394426251749D-05, + 8 -1.49282953213429172D-03, -8.78204709546389328D-04, + 9 -5.02916549572034614D-04, -2.94822138512746025D-04, + A -1.75463996970782828D-04, -1.04008550460816434D-04, + B -5.96141953046457895D-05, -3.12038929076098340D-05, + C -1.26089735980230047D-05, -2.42892608575730389D-07, + D 8.05996165414273571D-06, 1.36507009262147391D-05, + E 1.73964125472926261D-05, 1.98672978842133780D-05/ + DATA BETA(45), BETA(46), BETA(47), BETA(48), BETA(49), BETA(50), + 1 BETA(51), BETA(52), BETA(53), BETA(54), BETA(55), BETA(56), + 2 BETA(57), BETA(58), BETA(59), BETA(60), BETA(61), BETA(62), + 3 BETA(63), BETA(64), BETA(65), BETA(66)/ + 4 2.14463263790822639D-05, 2.23954659232456514D-05, + 5 2.28967783814712629D-05, 2.30785389811177817D-05, + 6 2.30321976080909144D-05, 2.28236073720348722D-05, + 7 2.25005881105292418D-05, 2.20981015361991429D-05, + 8 2.16418427448103905D-05, 2.11507649256220843D-05, + 9 2.06388749782170737D-05, 2.01165241997081666D-05, + A 1.95913450141179244D-05, 1.90689367910436740D-05, + B 1.85533719641636667D-05, 1.80475722259674218D-05, + C 5.52213076721292790D-04, 4.47932581552384646D-04, + D 2.79520653992020589D-04, 1.52468156198446602D-04, + E 6.93271105657043598D-05, 1.76258683069991397D-05/ + DATA BETA(67), BETA(68), BETA(69), BETA(70), BETA(71), BETA(72), + 1 BETA(73), BETA(74), BETA(75), BETA(76), BETA(77), BETA(78), + 2 BETA(79), BETA(80), BETA(81), BETA(82), BETA(83), BETA(84), + 3 BETA(85), BETA(86), BETA(87), BETA(88)/ + 4 -1.35744996343269136D-05, -3.17972413350427135D-05, + 5 -4.18861861696693365D-05, -4.69004889379141029D-05, + 6 -4.87665447413787352D-05, -4.87010031186735069D-05, + 7 -4.74755620890086638D-05, -4.55813058138628452D-05, + 8 -4.33309644511266036D-05, -4.09230193157750364D-05, + 9 -3.84822638603221274D-05, -3.60857167535410501D-05, + A -3.37793306123367417D-05, -3.15888560772109621D-05, + B -2.95269561750807315D-05, -2.75978914828335759D-05, + C -2.58006174666883713D-05, -2.41308356761280200D-05, + D -2.25823509518346033D-05, -2.11479656768912971D-05, + E -1.98200638885294927D-05, -1.85909870801065077D-05/ + DATA BETA(89), BETA(90), BETA(91), BETA(92), BETA(93), BETA(94), + 1 BETA(95), BETA(96), BETA(97), BETA(98), BETA(99), BETA(100), + 2 BETA(101), BETA(102), BETA(103), BETA(104), BETA(105), + 3 BETA(106), BETA(107), BETA(108), BETA(109), BETA(110)/ + 4 -1.74532699844210224D-05, -1.63997823854497997D-05, + 5 -4.74617796559959808D-04, -4.77864567147321487D-04, + 6 -3.20390228067037603D-04, -1.61105016119962282D-04, + 7 -4.25778101285435204D-05, 3.44571294294967503D-05, + 8 7.97092684075674924D-05, 1.03138236708272200D-04, + 9 1.12466775262204158D-04, 1.13103642108481389D-04, + A 1.08651634848774268D-04, 1.01437951597661973D-04, + B 9.29298396593363896D-05, 8.40293133016089978D-05, + C 7.52727991349134062D-05, 6.69632521975730872D-05, + D 5.92564547323194704D-05, 5.22169308826975567D-05, + E 4.58539485165360646D-05, 4.01445513891486808D-05/ + DATA BETA(111), BETA(112), BETA(113), BETA(114), BETA(115), + 1 BETA(116), BETA(117), BETA(118), BETA(119), BETA(120), + 2 BETA(121), BETA(122), BETA(123), BETA(124), BETA(125), + 3 BETA(126), BETA(127), BETA(128), BETA(129), BETA(130)/ + 4 3.50481730031328081D-05, 3.05157995034346659D-05, + 5 2.64956119950516039D-05, 2.29363633690998152D-05, + 6 1.97893056664021636D-05, 1.70091984636412623D-05, + 7 1.45547428261524004D-05, 1.23886640995878413D-05, + 8 1.04775876076583236D-05, 8.79179954978479373D-06, + 9 7.36465810572578444D-04, 8.72790805146193976D-04, + A 6.22614862573135066D-04, 2.85998154194304147D-04, + B 3.84737672879366102D-06, -1.87906003636971558D-04, + C -2.97603646594554535D-04, -3.45998126832656348D-04, + D -3.53382470916037712D-04, -3.35715635775048757D-04/ + DATA BETA(131), BETA(132), BETA(133), BETA(134), BETA(135), + 1 BETA(136), BETA(137), BETA(138), BETA(139), BETA(140), + 2 BETA(141), BETA(142), BETA(143), BETA(144), BETA(145), + 3 BETA(146), BETA(147), BETA(148), BETA(149), BETA(150)/ + 4 -3.04321124789039809D-04, -2.66722723047612821D-04, + 5 -2.27654214122819527D-04, -1.89922611854562356D-04, + 6 -1.55058918599093870D-04, -1.23778240761873630D-04, + 7 -9.62926147717644187D-05, -7.25178327714425337D-05, + 8 -5.22070028895633801D-05, -3.50347750511900522D-05, + 9 -2.06489761035551757D-05, -8.70106096849767054D-06, + A 1.13698686675100290D-06, 9.16426474122778849D-06, + B 1.56477785428872620D-05, 2.08223629482466847D-05, + C 2.48923381004595156D-05, 2.80340509574146325D-05, + D 3.03987774629861915D-05, 3.21156731406700616D-05/ + DATA BETA(151), BETA(152), BETA(153), BETA(154), BETA(155), + 1 BETA(156), BETA(157), BETA(158), BETA(159), BETA(160), + 2 BETA(161), BETA(162), BETA(163), BETA(164), BETA(165), + 3 BETA(166), BETA(167), BETA(168), BETA(169), BETA(170)/ + 4 -1.80182191963885708D-03, -2.43402962938042533D-03, + 5 -1.83422663549856802D-03, -7.62204596354009765D-04, + 6 2.39079475256927218D-04, 9.49266117176881141D-04, + 7 1.34467449701540359D-03, 1.48457495259449178D-03, + 8 1.44732339830617591D-03, 1.30268261285657186D-03, + 9 1.10351597375642682D-03, 8.86047440419791759D-04, + A 6.73073208165665473D-04, 4.77603872856582378D-04, + B 3.05991926358789362D-04, 1.60315694594721630D-04, + C 4.00749555270613286D-05, -5.66607461635251611D-05, + D -1.32506186772982638D-04, -1.90296187989614057D-04/ + DATA BETA(171), BETA(172), BETA(173), BETA(174), BETA(175), + 1 BETA(176), BETA(177), BETA(178), BETA(179), BETA(180), + 2 BETA(181), BETA(182), BETA(183), BETA(184), BETA(185), + 3 BETA(186), BETA(187), BETA(188), BETA(189), BETA(190)/ + 4 -2.32811450376937408D-04, -2.62628811464668841D-04, + 5 -2.82050469867598672D-04, -2.93081563192861167D-04, + 6 -2.97435962176316616D-04, -2.96557334239348078D-04, + 7 -2.91647363312090861D-04, -2.83696203837734166D-04, + 8 -2.73512317095673346D-04, -2.61750155806768580D-04, + 9 6.38585891212050914D-03, 9.62374215806377941D-03, + A 7.61878061207001043D-03, 2.83219055545628054D-03, + B -2.09841352012720090D-03, -5.73826764216626498D-03, + C -7.70804244495414620D-03, -8.21011692264844401D-03, + D -7.65824520346905413D-03, -6.47209729391045177D-03/ + DATA BETA(191), BETA(192), BETA(193), BETA(194), BETA(195), + 1 BETA(196), BETA(197), BETA(198), BETA(199), BETA(200), + 2 BETA(201), BETA(202), BETA(203), BETA(204), BETA(205), + 3 BETA(206), BETA(207), BETA(208), BETA(209), BETA(210)/ + 4 -4.99132412004966473D-03, -3.45612289713133280D-03, + 5 -2.01785580014170775D-03, -7.59430686781961401D-04, + 6 2.84173631523859138D-04, 1.10891667586337403D-03, + 7 1.72901493872728771D-03, 2.16812590802684701D-03, + 8 2.45357710494539735D-03, 2.61281821058334862D-03, + 9 2.67141039656276912D-03, 2.65203073395980430D-03, + A 2.57411652877287315D-03, 2.45389126236094427D-03, + B 2.30460058071795494D-03, 2.13684837686712662D-03, + C 1.95896528478870911D-03, 1.77737008679454412D-03, + D 1.59690280765839059D-03, 1.42111975664438546D-03/ + DATA GAMA(1), GAMA(2), GAMA(3), GAMA(4), GAMA(5), GAMA(6), + 1 GAMA(7), GAMA(8), GAMA(9), GAMA(10), GAMA(11), GAMA(12), + 2 GAMA(13), GAMA(14), GAMA(15), GAMA(16), GAMA(17), GAMA(18), + 3 GAMA(19), GAMA(20), GAMA(21), GAMA(22)/ + 4 6.29960524947436582D-01, 2.51984209978974633D-01, + 5 1.54790300415655846D-01, 1.10713062416159013D-01, + 6 8.57309395527394825D-02, 6.97161316958684292D-02, + 7 5.86085671893713576D-02, 5.04698873536310685D-02, + 8 4.42600580689154809D-02, 3.93720661543509966D-02, + 9 3.54283195924455368D-02, 3.21818857502098231D-02, + A 2.94646240791157679D-02, 2.71581677112934479D-02, + B 2.51768272973861779D-02, 2.34570755306078891D-02, + C 2.19508390134907203D-02, 2.06210828235646240D-02, + D 1.94388240897880846D-02, 1.83810633800683158D-02, + E 1.74293213231963172D-02, 1.65685837786612353D-02/ + DATA GAMA(23), GAMA(24), GAMA(25), GAMA(26), GAMA(27), GAMA(28), + 1 GAMA(29), GAMA(30)/ + 2 1.57865285987918445D-02, 1.50729501494095594D-02, + 3 1.44193250839954639D-02, 1.38184805735341786D-02, + 4 1.32643378994276568D-02, 1.27517121970498651D-02, + 5 1.22761545318762767D-02, 1.18338262398482403D-02/ + DATA EX1, EX2, HPI, GPI, THPI / + 1 3.33333333333333333D-01, 6.66666666666666667D-01, + 2 1.57079632679489662D+00, 3.14159265358979324D+00, + 3 4.71238898038468986D+00/ + DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / +C + RFNU = 1.0D0/FNU +C----------------------------------------------------------------------- +C OVERFLOW TEST (Z/FNU TOO SMALL) +C----------------------------------------------------------------------- + TEST = D1MACH(1)*1.0D+3 + AC = FNU*TEST + IF (DABS(ZR).GT.AC .OR. DABS(ZI).GT.AC) GO TO 15 + ZETA1R = 2.0D0*DABS(DLOG(TEST))+FNU + ZETA1I = 0.0D0 + ZETA2R = FNU + ZETA2I = 0.0D0 + PHIR = 1.0D0 + PHII = 0.0D0 + ARGR = 1.0D0 + ARGI = 0.0D0 + RETURN + 15 CONTINUE + ZBR = ZR*RFNU + ZBI = ZI*RFNU + RFNU2 = RFNU*RFNU +C----------------------------------------------------------------------- +C COMPUTE IN THE FOURTH QUADRANT +C----------------------------------------------------------------------- + FN13 = FNU**EX1 + FN23 = FN13*FN13 + RFN13 = 1.0D0/FN13 + W2R = CONER - ZBR*ZBR + ZBI*ZBI + W2I = CONEI - ZBR*ZBI - ZBR*ZBI + AW2 = ZABS(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 diff --git a/amos/zuni1.f b/amos/zuni1.f new file mode 100644 index 0000000..0e6ab5d --- /dev/null +++ b/amos/zuni1.f @@ -0,0 +1,204 @@ + SUBROUTINE ZUNI1(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, + * TOL, ELIM, ALIM) +C***BEGIN PROLOGUE ZUNI1 +C***REFER TO ZBESI,ZBESK +C +C ZUNI1 COMPUTES I(FNU,Z) BY MEANS OF THE UNIFORM ASYMPTOTIC +C EXPANSION FOR I(FNU,Z) IN -PI/3.LE.ARG Z.LE.PI/3. +C +C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC +C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. +C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER +C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. +C Y(I)=CZERO FOR I=NLAST+1,N +C +C***ROUTINES CALLED ZUCHK,ZUNIK,ZUOIK,D1MACH,ZABS +C***END PROLOGUE ZUNI1 +C COMPLEX CFN,CONE,CRSC,CSCL,CSR,CSS,CWRK,CZERO,C1,C2,PHI,RZ,SUM,S1, +C *S2,Y,Z,ZETA1,ZETA2 + DOUBLE PRECISION ALIM, APHI, ASCLE, BRY, CONER, CRSC, + * CSCL, CSRR, CSSR, CWRKI, CWRKR, C1R, C2I, C2M, C2R, ELIM, FN, + * FNU, FNUL, PHII, PHIR, RAST, RS1, RZI, RZR, STI, STR, SUMI, + * SUMR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, + * ZETA1R, ZETA2I, ZETA2R, ZI, ZR, CYR, CYI, D1MACH, ZABS + INTEGER I, IFLAG, INIT, K, KODE, M, N, ND, NLAST, NN, NUF, NW, NZ + DIMENSION BRY(3), YR(N), YI(N), CWRKR(16), CWRKI(16), CSSR(3), + * CSRR(3), CYR(2), CYI(2) + DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / +C + NZ = 0 + ND = N + NLAST = 0 +C----------------------------------------------------------------------- +C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- +C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, +C EXP(ALIM)=EXP(ELIM)*TOL +C----------------------------------------------------------------------- + CSCL = 1.0D0/TOL + CRSC = TOL + CSSR(1) = CSCL + CSSR(2) = CONER + CSSR(3) = CRSC + CSRR(1) = CRSC + CSRR(2) = CONER + CSRR(3) = CSCL + BRY(1) = 1.0D+3*D1MACH(1)/TOL +C----------------------------------------------------------------------- +C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER +C----------------------------------------------------------------------- + FN = DMAX1(FNU,1.0D0) + INIT = 0 + CALL ZUNIK(ZR, ZI, FN, 1, 1, TOL, INIT, PHIR, PHII, ZETA1R, + * ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) + IF (KODE.EQ.1) GO TO 10 + STR = ZR + ZETA2R + STI = ZI + ZETA2I + RAST = FN/ZABS(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 diff --git a/amos/zuni2.f b/amos/zuni2.f new file mode 100644 index 0000000..6f6b579 --- /dev/null +++ b/amos/zuni2.f @@ -0,0 +1,267 @@ + SUBROUTINE ZUNI2(ZR, ZI, FNU, KODE, N, YR, YI, NZ, NLAST, FNUL, + * TOL, ELIM, ALIM) +C***BEGIN PROLOGUE ZUNI2 +C***REFER TO ZBESI,ZBESK +C +C ZUNI2 COMPUTES I(FNU,Z) IN THE RIGHT HALF PLANE BY MEANS OF +C UNIFORM ASYMPTOTIC EXPANSION FOR J(FNU,ZN) WHERE ZN IS Z*I +C OR -Z*I AND ZN IS IN THE RIGHT HALF PLANE ALSO. +C +C FNUL IS THE SMALLEST ORDER PERMITTED FOR THE ASYMPTOTIC +C EXPANSION. NLAST=0 MEANS ALL OF THE Y VALUES WERE SET. +C NLAST.NE.0 IS THE NUMBER LEFT TO BE COMPUTED BY ANOTHER +C FORMULA FOR ORDERS FNU TO FNU+NLAST-1 BECAUSE FNU+NLAST-1.LT.FNUL. +C Y(I)=CZERO FOR I=NLAST+1,N +C +C***ROUTINES CALLED ZAIRY,ZUCHK,ZUNHJ,ZUOIK,D1MACH,ZABS +C***END PROLOGUE ZUNI2 +C COMPLEX AI,ARG,ASUM,BSUM,CFN,CI,CID,CIP,CONE,CRSC,CSCL,CSR,CSS, +C *CZERO,C1,C2,DAI,PHI,RZ,S1,S2,Y,Z,ZB,ZETA1,ZETA2,ZN + DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGI, + * ARGR, ASCLE, ASUMI, ASUMR, BRY, BSUMI, BSUMR, CIDI, CIPI, CIPR, + * CONER, CRSC, CSCL, CSRR, CSSR, C1R, C2I, C2M, C2R, DAII, + * DAIR, ELIM, FN, FNU, FNUL, HPI, PHII, PHIR, RAST, RAZ, RS1, RZI, + * RZR, STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, ZBI, ZBR, ZEROI, + * ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, ZNI, ZNR, ZR, CYR, + * CYI, D1MACH, ZABS, CAR, SAR + INTEGER I, IFLAG, IN, INU, J, K, KODE, N, NAI, ND, NDAI, NLAST, + * NN, NUF, NW, NZ, IDUM + DIMENSION BRY(3), YR(N), YI(N), CIPR(4), CIPI(4), CSSR(3), + * CSRR(3), CYR(2), CYI(2) + DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / + DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4), + * CIPI(4)/ 1.0D0,0.0D0, 0.0D0,1.0D0, -1.0D0,0.0D0, 0.0D0,-1.0D0/ + DATA HPI, AIC / + 1 1.57079632679489662D+00, 1.265512123484645396D+00/ +C + NZ = 0 + ND = N + NLAST = 0 +C----------------------------------------------------------------------- +C COMPUTED VALUES WITH EXPONENTS BETWEEN ALIM AND ELIM IN MAG- +C NITUDE ARE SCALED TO KEEP INTERMEDIATE ARITHMETIC ON SCALE, +C EXP(ALIM)=EXP(ELIM)*TOL +C----------------------------------------------------------------------- + CSCL = 1.0D0/TOL + CRSC = TOL + CSSR(1) = CSCL + CSSR(2) = CONER + CSSR(3) = CRSC + CSRR(1) = CRSC + CSRR(2) = CONER + CSRR(3) = CSCL + BRY(1) = 1.0D+3*D1MACH(1)/TOL +C----------------------------------------------------------------------- +C ZN IS IN THE RIGHT HALF PLANE AFTER ROTATION BY CI OR -CI +C----------------------------------------------------------------------- + ZNR = ZI + ZNI = -ZR + ZBR = ZR + ZBI = ZI + CIDI = -CONER + INU = INT(SNGL(FNU)) + ANG = HPI*(FNU-DBLE(FLOAT(INU))) + C2R = DCOS(ANG) + C2I = DSIN(ANG) + CAR = C2R + SAR = C2I + IN = INU + N - 1 + IN = MOD(IN,4) + 1 + STR = C2R*CIPR(IN) - C2I*CIPI(IN) + C2I = C2R*CIPI(IN) + C2I*CIPR(IN) + C2R = STR + IF (ZI.GT.0.0D0) GO TO 10 + ZNR = -ZNR + ZBI = -ZBI + CIDI = -CIDI + C2I = -C2I + 10 CONTINUE +C----------------------------------------------------------------------- +C CHECK FOR UNDERFLOW AND OVERFLOW ON FIRST MEMBER +C----------------------------------------------------------------------- + FN = DMAX1(FNU,1.0D0) + CALL ZUNHJ(ZNR, ZNI, FN, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, + * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) + IF (KODE.EQ.1) GO TO 20 + STR = ZBR + ZETA2R + STI = ZBI + ZETA2I + RAST = FN/ZABS(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 diff --git a/amos/zunik.f b/amos/zunik.f new file mode 100644 index 0000000..3e8293e --- /dev/null +++ b/amos/zunik.f @@ -0,0 +1,211 @@ + SUBROUTINE ZUNIK(ZRR, ZRI, FNU, IKFLG, IPMTR, TOL, INIT, PHIR, + * PHII, ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) +C***BEGIN PROLOGUE ZUNIK +C***REFER TO ZBESI,ZBESK +C +C ZUNIK COMPUTES PARAMETERS FOR THE UNIFORM ASYMPTOTIC +C EXPANSIONS OF THE I AND K FUNCTIONS ON IKFLG= 1 OR 2 +C RESPECTIVELY BY +C +C W(FNU,ZR) = PHI*EXP(ZETA)*SUM +C +C WHERE ZETA=-ZETA1 + ZETA2 OR +C ZETA1 - ZETA2 +C +C THE FIRST CALL MUST HAVE INIT=0. SUBSEQUENT CALLS WITH THE +C SAME ZR AND FNU WILL RETURN THE I OR K FUNCTION ON IKFLG= +C 1 OR 2 WITH NO CHANGE IN INIT. CWRK IS A COMPLEX WORK +C ARRAY. IPMTR=0 COMPUTES ALL PARAMETERS. IPMTR=1 COMPUTES PHI, +C ZETA1,ZETA2. +C +C***ROUTINES CALLED ZDIV,ZLOG,ZSQRT,D1MACH +C***END PROLOGUE ZUNIK +C COMPLEX CFN,CON,CONE,CRFN,CWRK,CZERO,PHI,S,SR,SUM,T,T2,ZETA1, +C *ZETA2,ZN,ZR + DOUBLE PRECISION AC, C, CON, CONEI, CONER, CRFNI, CRFNR, CWRKI, + * CWRKR, FNU, PHII, PHIR, RFN, SI, SR, SRI, SRR, STI, STR, SUMI, + * SUMR, TEST, TI, TOL, TR, T2I, T2R, ZEROI, ZEROR, ZETA1I, ZETA1R, + * ZETA2I, ZETA2R, ZNI, ZNR, ZRI, ZRR, D1MACH + INTEGER I, IDUM, IKFLG, INIT, IPMTR, J, K, L + DIMENSION C(120), CWRKR(16), CWRKI(16), CON(2) + DATA ZEROR,ZEROI,CONER,CONEI / 0.0D0, 0.0D0, 1.0D0, 0.0D0 / + DATA CON(1), CON(2) / + 1 3.98942280401432678D-01, 1.25331413731550025D+00 / + DATA C(1), C(2), C(3), C(4), C(5), C(6), C(7), C(8), C(9), C(10), + 1 C(11), C(12), C(13), C(14), C(15), C(16), C(17), C(18), + 2 C(19), C(20), C(21), C(22), C(23), C(24)/ + 3 1.00000000000000000D+00, -2.08333333333333333D-01, + 4 1.25000000000000000D-01, 3.34201388888888889D-01, + 5 -4.01041666666666667D-01, 7.03125000000000000D-02, + 6 -1.02581259645061728D+00, 1.84646267361111111D+00, + 7 -8.91210937500000000D-01, 7.32421875000000000D-02, + 8 4.66958442342624743D+00, -1.12070026162229938D+01, + 9 8.78912353515625000D+00, -2.36408691406250000D+00, + A 1.12152099609375000D-01, -2.82120725582002449D+01, + B 8.46362176746007346D+01, -9.18182415432400174D+01, + C 4.25349987453884549D+01, -7.36879435947963170D+00, + D 2.27108001708984375D-01, 2.12570130039217123D+02, + E -7.65252468141181642D+02, 1.05999045252799988D+03/ + DATA C(25), C(26), C(27), C(28), C(29), C(30), C(31), C(32), + 1 C(33), C(34), C(35), C(36), C(37), C(38), C(39), C(40), + 2 C(41), C(42), C(43), C(44), C(45), C(46), C(47), C(48)/ + 3 -6.99579627376132541D+02, 2.18190511744211590D+02, + 4 -2.64914304869515555D+01, 5.72501420974731445D-01, + 5 -1.91945766231840700D+03, 8.06172218173730938D+03, + 6 -1.35865500064341374D+04, 1.16553933368645332D+04, + 7 -5.30564697861340311D+03, 1.20090291321635246D+03, + 8 -1.08090919788394656D+02, 1.72772750258445740D+00, + 9 2.02042913309661486D+04, -9.69805983886375135D+04, + A 1.92547001232531532D+05, -2.03400177280415534D+05, + B 1.22200464983017460D+05, -4.11926549688975513D+04, + C 7.10951430248936372D+03, -4.93915304773088012D+02, + D 6.07404200127348304D+00, -2.42919187900551333D+05, + E 1.31176361466297720D+06, -2.99801591853810675D+06/ + DATA C(49), C(50), C(51), C(52), C(53), C(54), C(55), C(56), + 1 C(57), C(58), C(59), C(60), C(61), C(62), C(63), C(64), + 2 C(65), C(66), C(67), C(68), C(69), C(70), C(71), C(72)/ + 3 3.76327129765640400D+06, -2.81356322658653411D+06, + 4 1.26836527332162478D+06, -3.31645172484563578D+05, + 5 4.52187689813627263D+04, -2.49983048181120962D+03, + 6 2.43805296995560639D+01, 3.28446985307203782D+06, + 7 -1.97068191184322269D+07, 5.09526024926646422D+07, + 8 -7.41051482115326577D+07, 6.63445122747290267D+07, + 9 -3.75671766607633513D+07, 1.32887671664218183D+07, + A -2.78561812808645469D+06, 3.08186404612662398D+05, + B -1.38860897537170405D+04, 1.10017140269246738D+02, + C -4.93292536645099620D+07, 3.25573074185765749D+08, + D -9.39462359681578403D+08, 1.55359689957058006D+09, + E -1.62108055210833708D+09, 1.10684281682301447D+09/ + DATA C(73), C(74), C(75), C(76), C(77), C(78), C(79), C(80), + 1 C(81), C(82), C(83), C(84), C(85), C(86), C(87), C(88), + 2 C(89), C(90), C(91), C(92), C(93), C(94), C(95), C(96)/ + 3 -4.95889784275030309D+08, 1.42062907797533095D+08, + 4 -2.44740627257387285D+07, 2.24376817792244943D+06, + 5 -8.40054336030240853D+04, 5.51335896122020586D+02, + 6 8.14789096118312115D+08, -5.86648149205184723D+09, + 7 1.86882075092958249D+10, -3.46320433881587779D+10, + 8 4.12801855797539740D+10, -3.30265997498007231D+10, + 9 1.79542137311556001D+10, -6.56329379261928433D+09, + A 1.55927986487925751D+09, -2.25105661889415278D+08, + B 1.73951075539781645D+07, -5.49842327572288687D+05, + C 3.03809051092238427D+03, -1.46792612476956167D+10, + D 1.14498237732025810D+11, -3.99096175224466498D+11, + E 8.19218669548577329D+11, -1.09837515608122331D+12/ + DATA C(97), C(98), C(99), C(100), C(101), C(102), C(103), C(104), + 1 C(105), C(106), C(107), C(108), C(109), C(110), C(111), + 2 C(112), C(113), C(114), C(115), C(116), C(117), C(118)/ + 3 1.00815810686538209D+12, -6.45364869245376503D+11, + 4 2.87900649906150589D+11, -8.78670721780232657D+10, + 5 1.76347306068349694D+10, -2.16716498322379509D+09, + 6 1.43157876718888981D+08, -3.87183344257261262D+06, + 7 1.82577554742931747D+04, 2.86464035717679043D+11, + 8 -2.40629790002850396D+12, 9.10934118523989896D+12, + 9 -2.05168994109344374D+13, 3.05651255199353206D+13, + A -3.16670885847851584D+13, 2.33483640445818409D+13, + B -1.23204913055982872D+13, 4.61272578084913197D+12, + C -1.19655288019618160D+12, 2.05914503232410016D+11, + D -2.18229277575292237D+10, 1.24700929351271032D+09/ + DATA C(119), C(120)/ + 1 -2.91883881222208134D+07, 1.18838426256783253D+05/ +C + IF (INIT.NE.0) GO TO 40 +C----------------------------------------------------------------------- +C INITIALIZE ALL VARIABLES +C----------------------------------------------------------------------- + RFN = 1.0D0/FNU +C----------------------------------------------------------------------- +C OVERFLOW TEST (ZR/FNU TOO SMALL) +C----------------------------------------------------------------------- + TEST = D1MACH(1)*1.0D+3 + AC = FNU*TEST + IF (DABS(ZRR).GT.AC .OR. DABS(ZRI).GT.AC) GO TO 15 + ZETA1R = 2.0D0*DABS(DLOG(TEST))+FNU + ZETA1I = 0.0D0 + ZETA2R = FNU + ZETA2I = 0.0D0 + PHIR = 1.0D0 + PHII = 0.0D0 + RETURN + 15 CONTINUE + TR = ZRR*RFN + TI = ZRI*RFN + SR = CONER + (TR*TR-TI*TI) + SI = CONEI + (TR*TI+TI*TR) + CALL ZSQRT(SR, SI, SRR, SRI) + STR = CONER + SRR + STI = CONEI + SRI + CALL ZDIV(STR, STI, TR, TI, ZNR, ZNI) + CALL ZLOG(ZNR, ZNI, STR, STI, IDUM) + ZETA1R = FNU*STR + ZETA1I = FNU*STI + ZETA2R = FNU*SRR + ZETA2I = FNU*SRI + CALL ZDIV(CONER, CONEI, SRR, SRI, TR, TI) + SRR = TR*RFN + SRI = TI*RFN + CALL ZSQRT(SRR, SRI, CWRKR(16), CWRKI(16)) + PHIR = CWRKR(16)*CON(IKFLG) + PHII = CWRKI(16)*CON(IKFLG) + IF (IPMTR.NE.0) RETURN + CALL ZDIV(CONER, CONEI, SR, SI, T2R, T2I) + CWRKR(1) = CONER + CWRKI(1) = CONEI + CRFNR = CONER + CRFNI = CONEI + AC = 1.0D0 + L = 1 + DO 20 K=2,15 + SR = ZEROR + SI = ZEROI + DO 10 J=1,K + L = L + 1 + STR = SR*T2R - SI*T2I + C(L) + SI = SR*T2I + SI*T2R + SR = STR + 10 CONTINUE + STR = CRFNR*SRR - CRFNI*SRI + CRFNI = CRFNR*SRI + CRFNI*SRR + CRFNR = STR + CWRKR(K) = CRFNR*SR - CRFNI*SI + CWRKI(K) = CRFNR*SI + CRFNI*SR + AC = AC*RFN + TEST = DABS(CWRKR(K)) + DABS(CWRKI(K)) + IF (AC.LT.TOL .AND. TEST.LT.TOL) GO TO 30 + 20 CONTINUE + K = 15 + 30 CONTINUE + INIT = K + 40 CONTINUE + IF (IKFLG.EQ.2) GO TO 60 +C----------------------------------------------------------------------- +C COMPUTE SUM FOR THE I FUNCTION +C----------------------------------------------------------------------- + SR = ZEROR + SI = ZEROI + DO 50 I=1,INIT + SR = SR + CWRKR(I) + SI = SI + CWRKI(I) + 50 CONTINUE + SUMR = SR + SUMI = SI + PHIR = CWRKR(16)*CON(1) + PHII = CWRKI(16)*CON(1) + RETURN + 60 CONTINUE +C----------------------------------------------------------------------- +C COMPUTE SUM FOR THE K FUNCTION +C----------------------------------------------------------------------- + SR = ZEROR + SI = ZEROI + TR = CONER + DO 70 I=1,INIT + SR = SR + TR*CWRKR(I) + SI = SI + TR*CWRKI(I) + TR = -TR + 70 CONTINUE + SUMR = SR + SUMI = SI + PHIR = CWRKR(16)*CON(2) + PHII = CWRKI(16)*CON(2) + RETURN + END diff --git a/amos/zunk1.f b/amos/zunk1.f new file mode 100644 index 0000000..ea9ce9e --- /dev/null +++ b/amos/zunk1.f @@ -0,0 +1,426 @@ + SUBROUTINE ZUNK1(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, + * ALIM) +C***BEGIN PROLOGUE ZUNK1 +C***REFER TO ZBESK +C +C ZUNK1 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE +C RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE +C UNIFORM ASYMPTOTIC EXPANSION. +C MR INDICATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. +C NZ=-1 MEANS AN OVERFLOW WILL OCCUR +C +C***ROUTINES CALLED ZKSCL,ZS1S2,ZUCHK,ZUNIK,D1MACH,ZABS +C***END PROLOGUE ZUNK1 +C COMPLEX CFN,CK,CONE,CRSC,CS,CSCL,CSGN,CSPN,CSR,CSS,CWRK,CY,CZERO, +C *C1,C2,PHI,PHID,RZ,SUM,SUMD,S1,S2,Y,Z,ZETA1,ZETA1D,ZETA2,ZETA2D,ZR + DOUBLE PRECISION ALIM, ANG, APHI, ASC, ASCLE, BRY, CKI, CKR, + * CONER, CRSC, CSCL, CSGNI, CSPNI, CSPNR, CSR, CSRR, CSSR, + * CWRKI, CWRKR, CYI, CYR, C1I, C1R, C2I, C2M, C2R, ELIM, FMR, FN, + * FNF, FNU, PHIDI, PHIDR, PHII, PHIR, PI, RAST, RAZR, RS1, RZI, + * RZR, SGN, STI, STR, SUMDI, SUMDR, SUMI, SUMR, S1I, S1R, S2I, + * S2R, TOL, YI, YR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, + * ZET1DI, ZET1DR, ZET2DI, ZET2DR, ZI, ZR, ZRI, ZRR, D1MACH, ZABS + INTEGER I, IB, IFLAG, IFN, IL, INIT, INU, IUF, K, KDFLG, KFLAG, + * KK, KODE, MR, N, NW, NZ, INITD, IC, IPARD, J + DIMENSION BRY(3), INIT(2), YR(N), YI(N), SUMR(2), SUMI(2), + * ZETA1R(2), ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2), + * CWRKR(16,3), CWRKI(16,3), CSSR(3), CSRR(3), PHIR(2), PHII(2) + DATA ZEROR,ZEROI,CONER / 0.0D0, 0.0D0, 1.0D0 / + DATA PI / 3.14159265358979324D0 / +C + KDFLG = 1 + NZ = 0 +C----------------------------------------------------------------------- +C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN +C THE UNDERFLOW LIMIT +C----------------------------------------------------------------------- + CSCL = 1.0D0/TOL + CRSC = TOL + CSSR(1) = CSCL + CSSR(2) = CONER + CSSR(3) = CRSC + CSRR(1) = CRSC + CSRR(2) = CONER + CSRR(3) = CSCL + BRY(1) = 1.0D+3*D1MACH(1)/TOL + BRY(2) = 1.0D0/BRY(1) + BRY(3) = D1MACH(2) + ZRR = ZR + ZRI = ZI + IF (ZR.GE.0.0D0) GO TO 10 + ZRR = -ZR + ZRI = -ZI + 10 CONTINUE + J = 2 + DO 70 I=1,N +C----------------------------------------------------------------------- +C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J +C----------------------------------------------------------------------- + J = 3 - J + FN = FNU + DBLE(FLOAT(I-1)) + INIT(J) = 0 + CALL ZUNIK(ZRR, ZRI, FN, 2, 0, TOL, INIT(J), PHIR(J), PHII(J), + * ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), SUMR(J), SUMI(J), + * CWRKR(1,J), CWRKI(1,J)) + IF (KODE.EQ.1) GO TO 20 + STR = ZRR + ZETA2R(J) + STI = ZRI + ZETA2I(J) + RAST = FN/ZABS(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 diff --git a/amos/zunk2.f b/amos/zunk2.f new file mode 100644 index 0000000..6fa8f33 --- /dev/null +++ b/amos/zunk2.f @@ -0,0 +1,505 @@ + SUBROUTINE ZUNK2(ZR, ZI, FNU, KODE, MR, N, YR, YI, NZ, TOL, ELIM, + * ALIM) +C***BEGIN PROLOGUE ZUNK2 +C***REFER TO ZBESK +C +C ZUNK2 COMPUTES K(FNU,Z) AND ITS ANALYTIC CONTINUATION FROM THE +C RIGHT HALF PLANE TO THE LEFT HALF PLANE BY MEANS OF THE +C UNIFORM ASYMPTOTIC EXPANSIONS FOR H(KIND,FNU,ZN) AND J(FNU,ZN) +C WHERE ZN IS IN THE RIGHT HALF PLANE, KIND=(3-MR)/2, MR=+1 OR +C -1. HERE ZN=ZR*I OR -ZR*I WHERE ZR=Z IF Z IS IN THE RIGHT +C HALF PLANE OR ZR=-Z IF Z IS IN THE LEFT HALF PLANE. MR INDIC- +C ATES THE DIRECTION OF ROTATION FOR ANALYTIC CONTINUATION. +C NZ=-1 MEANS AN OVERFLOW WILL OCCUR +C +C***ROUTINES CALLED ZAIRY,ZKSCL,ZS1S2,ZUCHK,ZUNHJ,D1MACH,ZABS +C***END PROLOGUE ZUNK2 +C COMPLEX AI,ARG,ARGD,ASUM,ASUMD,BSUM,BSUMD,CFN,CI,CIP,CK,CONE,CRSC, +C *CR1,CR2,CS,CSCL,CSGN,CSPN,CSR,CSS,CY,CZERO,C1,C2,DAI,PHI,PHID,RZ, +C *S1,S2,Y,Z,ZB,ZETA1,ZETA1D,ZETA2,ZETA2D,ZN,ZR + DOUBLE PRECISION AARG, AIC, AII, AIR, ALIM, ANG, APHI, ARGDI, + * ARGDR, ARGI, ARGR, ASC, ASCLE, ASUMDI, ASUMDR, ASUMI, ASUMR, + * BRY, BSUMDI, BSUMDR, BSUMI, BSUMR, CAR, CIPI, CIPR, CKI, CKR, + * CONER, CRSC, CR1I, CR1R, CR2I, CR2R, CSCL, CSGNI, CSI, + * CSPNI, CSPNR, CSR, CSRR, CSSR, CYI, CYR, C1I, C1R, C2I, C2M, + * C2R, DAII, DAIR, ELIM, FMR, FN, FNF, FNU, HPI, PHIDI, PHIDR, + * PHII, PHIR, PI, PTI, PTR, RAST, RAZR, RS1, RZI, RZR, SAR, SGN, + * STI, STR, S1I, S1R, S2I, S2R, TOL, YI, YR, YY, ZBI, ZBR, ZEROI, + * ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZET1DI, ZET1DR, ZET2DI, + * ZET2DR, ZI, ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS + INTEGER I, IB, IFLAG, IFN, IL, IN, INU, IUF, K, KDFLG, KFLAG, KK, + * KODE, MR, N, NAI, NDAI, NW, NZ, IDUM, J, IPARD, IC + DIMENSION BRY(3), YR(N), YI(N), ASUMR(2), ASUMI(2), BSUMR(2), + * BSUMI(2), PHIR(2), PHII(2), ARGR(2), ARGI(2), ZETA1R(2), + * ZETA1I(2), ZETA2R(2), ZETA2I(2), CYR(2), CYI(2), CIPR(4), + * CIPI(4), CSSR(3), CSRR(3) + DATA ZEROR,ZEROI,CONER,CR1R,CR1I,CR2R,CR2I / + 1 0.0D0, 0.0D0, 1.0D0, + 1 1.0D0,1.73205080756887729D0 , -0.5D0,-8.66025403784438647D-01 / + DATA HPI, PI, AIC / + 1 1.57079632679489662D+00, 3.14159265358979324D+00, + 1 1.26551212348464539D+00/ + DATA CIPR(1),CIPI(1),CIPR(2),CIPI(2),CIPR(3),CIPI(3),CIPR(4), + * CIPI(4) / + 1 1.0D0,0.0D0 , 0.0D0,-1.0D0 , -1.0D0,0.0D0 , 0.0D0,1.0D0 / +C + KDFLG = 1 + NZ = 0 +C----------------------------------------------------------------------- +C EXP(-ALIM)=EXP(-ELIM)/TOL=APPROX. ONE PRECISION GREATER THAN +C THE UNDERFLOW LIMIT +C----------------------------------------------------------------------- + CSCL = 1.0D0/TOL + CRSC = TOL + CSSR(1) = CSCL + CSSR(2) = CONER + CSSR(3) = CRSC + CSRR(1) = CRSC + CSRR(2) = CONER + CSRR(3) = CSCL + BRY(1) = 1.0D+3*D1MACH(1)/TOL + BRY(2) = 1.0D0/BRY(1) + BRY(3) = D1MACH(2) + ZRR = ZR + ZRI = ZI + IF (ZR.GE.0.0D0) GO TO 10 + ZRR = -ZR + ZRI = -ZI + 10 CONTINUE + YY = ZRI + ZNR = ZRI + ZNI = -ZRR + ZBR = ZRR + ZBI = ZRI + INU = INT(SNGL(FNU)) + FNF = FNU - DBLE(FLOAT(INU)) + ANG = -HPI*FNF + CAR = DCOS(ANG) + SAR = DSIN(ANG) + C2R = HPI*SAR + C2I = -HPI*CAR + KK = MOD(INU,4) + 1 + STR = C2R*CIPR(KK) - C2I*CIPI(KK) + STI = C2R*CIPI(KK) + C2I*CIPR(KK) + CSR = CR1R*STR - CR1I*STI + CSI = CR1R*STI + CR1I*STR + IF (YY.GT.0.0D0) GO TO 20 + ZNR = -ZNR + ZBI = -ZBI + 20 CONTINUE +C----------------------------------------------------------------------- +C K(FNU,Z) IS COMPUTED FROM H(2,FNU,-I*Z) WHERE Z IS IN THE FIRST +C QUADRANT. FOURTH QUADRANT VALUES (YY.LE.0.0E0) ARE COMPUTED BY +C CONJUGATION SINCE THE K FUNCTION IS REAL ON THE POSITIVE REAL AXIS +C----------------------------------------------------------------------- + J = 2 + DO 80 I=1,N +C----------------------------------------------------------------------- +C J FLIP FLOPS BETWEEN 1 AND 2 IN J = 3 - J +C----------------------------------------------------------------------- + J = 3 - J + FN = FNU + DBLE(FLOAT(I-1)) + CALL ZUNHJ(ZNR, ZNI, FN, 0, TOL, PHIR(J), PHII(J), ARGR(J), + * ARGI(J), ZETA1R(J), ZETA1I(J), ZETA2R(J), ZETA2I(J), ASUMR(J), + * ASUMI(J), BSUMR(J), BSUMI(J)) + IF (KODE.EQ.1) GO TO 30 + STR = ZBR + ZETA2R(J) + STI = ZBI + ZETA2I(J) + RAST = FN/ZABS(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 diff --git a/amos/zuoik.f b/amos/zuoik.f new file mode 100644 index 0000000..4c1259c --- /dev/null +++ b/amos/zuoik.f @@ -0,0 +1,194 @@ + SUBROUTINE ZUOIK(ZR, ZI, FNU, KODE, IKFLG, N, YR, YI, NUF, TOL, + * ELIM, ALIM) +C***BEGIN PROLOGUE ZUOIK +C***REFER TO ZBESI,ZBESK,ZBESH +C +C ZUOIK COMPUTES THE LEADING TERMS OF THE UNIFORM ASYMPTOTIC +C EXPANSIONS FOR THE I AND K FUNCTIONS AND COMPARES THEM +C (IN LOGARITHMIC FORM) TO ALIM AND ELIM FOR OVER AND UNDERFLOW +C WHERE ALIM.LT.ELIM. IF THE MAGNITUDE, BASED ON THE LEADING +C EXPONENTIAL, IS LESS THAN ALIM OR GREATER THAN -ALIM, THEN +C THE RESULT IS ON SCALE. IF NOT, THEN A REFINED TEST USING OTHER +C MULTIPLIERS (IN LOGARITHMIC FORM) IS MADE BASED ON ELIM. HERE +C EXP(-ELIM)=SMALLEST MACHINE NUMBER*1.0E+3 AND EXP(-ALIM)= +C EXP(-ELIM)/TOL +C +C IKFLG=1 MEANS THE I SEQUENCE IS TESTED +C =2 MEANS THE K SEQUENCE IS TESTED +C NUF = 0 MEANS THE LAST MEMBER OF THE SEQUENCE IS ON SCALE +C =-1 MEANS AN OVERFLOW WOULD OCCUR +C IKFLG=1 AND NUF.GT.0 MEANS THE LAST NUF Y VALUES WERE SET TO ZERO +C THE FIRST N-NUF VALUES MUST BE SET BY ANOTHER ROUTINE +C IKFLG=2 AND NUF.EQ.N MEANS ALL Y VALUES WERE SET TO ZERO +C IKFLG=2 AND 0.LT.NUF.LT.N NOT CONSIDERED. Y MUST BE SET BY +C ANOTHER ROUTINE +C +C***ROUTINES CALLED ZUCHK,ZUNHJ,ZUNIK,D1MACH,ZABS,ZLOG +C***END PROLOGUE ZUOIK +C COMPLEX ARG,ASUM,BSUM,CWRK,CZ,CZERO,PHI,SUM,Y,Z,ZB,ZETA1,ZETA2,ZN, +C *ZR + DOUBLE PRECISION AARG, AIC, ALIM, APHI, ARGI, ARGR, ASUMI, ASUMR, + * ASCLE, AX, AY, BSUMI, BSUMR, CWRKI, CWRKR, CZI, CZR, ELIM, FNN, + * FNU, GNN, GNU, PHII, PHIR, RCZ, STR, STI, SUMI, SUMR, TOL, YI, + * YR, ZBI, ZBR, ZEROI, ZEROR, ZETA1I, ZETA1R, ZETA2I, ZETA2R, ZI, + * ZNI, ZNR, ZR, ZRI, ZRR, D1MACH, ZABS + INTEGER I, IDUM, IFORM, IKFLG, INIT, KODE, N, NN, NUF, NW + DIMENSION YR(N), YI(N), CWRKR(16), CWRKI(16) + DATA ZEROR,ZEROI / 0.0D0, 0.0D0 / + DATA AIC / 1.265512123484645396D+00 / + NUF = 0 + NN = N + ZRR = ZR + ZRI = ZI + IF (ZR.GE.0.0D0) GO TO 10 + ZRR = -ZR + ZRI = -ZI + 10 CONTINUE + ZBR = ZRR + ZBI = ZRI + AX = DABS(ZR)*1.7321D0 + AY = DABS(ZI) + IFORM = 1 + IF (AY.GT.AX) IFORM = 2 + GNU = DMAX1(FNU,1.0D0) + IF (IKFLG.EQ.1) GO TO 20 + FNN = DBLE(FLOAT(NN)) + GNN = FNU + FNN - 1.0D0 + GNU = DMAX1(GNN,FNN) + 20 CONTINUE +C----------------------------------------------------------------------- +C ONLY THE MAGNITUDE OF ARG AND PHI ARE NEEDED ALONG WITH THE +C REAL PARTS OF ZETA1, ZETA2 AND ZB. NO ATTEMPT IS MADE TO GET +C THE SIGN OF THE IMAGINARY PART CORRECT. +C----------------------------------------------------------------------- + IF (IFORM.EQ.2) GO TO 30 + INIT = 0 + CALL ZUNIK(ZRR, ZRI, GNU, IKFLG, 1, TOL, INIT, PHIR, PHII, + * ZETA1R, ZETA1I, ZETA2R, ZETA2I, SUMR, SUMI, CWRKR, CWRKI) + CZR = -ZETA1R + ZETA2R + CZI = -ZETA1I + ZETA2I + GO TO 50 + 30 CONTINUE + ZNR = ZRI + ZNI = -ZRR + IF (ZI.GT.0.0D0) GO TO 40 + ZNR = -ZNR + 40 CONTINUE + CALL ZUNHJ(ZNR, ZNI, GNU, 1, TOL, PHIR, PHII, ARGR, ARGI, ZETA1R, + * ZETA1I, ZETA2R, ZETA2I, ASUMR, ASUMI, BSUMR, BSUMI) + CZR = -ZETA1R + ZETA2R + CZI = -ZETA1I + ZETA2I + AARG = ZABS(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 diff --git a/amos/zwrsk.f b/amos/zwrsk.f new file mode 100644 index 0000000..5f0672f --- /dev/null +++ b/amos/zwrsk.f @@ -0,0 +1,94 @@ + SUBROUTINE ZWRSK(ZRR, ZRI, FNU, KODE, N, YR, YI, NZ, CWR, CWI, + * TOL, ELIM, ALIM) +C***BEGIN PROLOGUE ZWRSK +C***REFER TO ZBESI,ZBESK +C +C ZWRSK COMPUTES THE I BESSEL FUNCTION FOR RE(Z).GE.0.0 BY +C NORMALIZING THE I FUNCTION RATIOS FROM ZRATI BY THE WRONSKIAN +C +C***ROUTINES CALLED D1MACH,ZBKNU,ZRATI,ZABS +C***END PROLOGUE ZWRSK +C COMPLEX CINU,CSCL,CT,CW,C1,C2,RCT,ST,Y,ZR + DOUBLE PRECISION ACT, ACW, ALIM, ASCLE, CINUI, CINUR, CSCLR, CTI, + * CTR, CWI, CWR, C1I, C1R, C2I, C2R, ELIM, FNU, PTI, PTR, RACT, + * STI, STR, TOL, YI, YR, ZRI, ZRR, ZABS, D1MACH + INTEGER I, KODE, N, NW, NZ + DIMENSION YR(N), YI(N), CWR(2), CWI(2) +C----------------------------------------------------------------------- +C I(FNU+I-1,Z) BY BACKWARD RECURRENCE FOR RATIOS +C Y(I)=I(FNU+I,Z)/I(FNU+I-1,Z) FROM CRATI NORMALIZED BY THE +C WRONSKIAN WITH K(FNU,Z) AND K(FNU+1,Z) FROM CBKNU. +C----------------------------------------------------------------------- + NZ = 0 + CALL ZBKNU(ZRR, ZRI, FNU, KODE, 2, CWR, CWI, NW, TOL, ELIM, ALIM) + IF (NW.NE.0) GO TO 50 + CALL ZRATI(ZRR, ZRI, FNU, N, YR, YI, TOL) +C----------------------------------------------------------------------- +C RECUR FORWARD ON I(FNU+1,Z) = R(FNU,Z)*I(FNU,Z), +C R(FNU+J-1,Z)=Y(J), J=1,...,N +C----------------------------------------------------------------------- + CINUR = 1.0D0 + CINUI = 0.0D0 + IF (KODE.EQ.1) GO TO 10 + CINUR = DCOS(ZRI) + CINUI = DSIN(ZRI) + 10 CONTINUE +C----------------------------------------------------------------------- +C ON LOW EXPONENT MACHINES THE K FUNCTIONS CAN BE CLOSE TO BOTH +C THE UNDER AND OVERFLOW LIMITS AND THE NORMALIZATION MUST BE +C SCALED TO PREVENT OVER OR UNDERFLOW. CUOIK HAS DETERMINED THAT +C THE RESULT IS ON SCALE. +C----------------------------------------------------------------------- + ACW = ZABS(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