1740 lines
83 KiB
Fortran
1740 lines
83 KiB
Fortran
!
|
|
!=======================================================================
|
|
!
|
|
MODULE GAMMA_FUNCTION
|
|
!
|
|
! This module provides different subroutine/functions
|
|
! to compute the Gamma function, namely:
|
|
!
|
|
!
|
|
! 1) FUNCTION DLGAMA(X) <-- Log(Gamma(x)); x real
|
|
!
|
|
! 2) FUNCTION LNGAMMA(X) <-- Log(Gamma(x)); x real
|
|
!
|
|
! 3) FUNCTION DGAMLN(Z,IERR) <-- Log(Gamma(x)); x real
|
|
!
|
|
! 4) SUBROUTINE GAMMA(X,GA) <-- Gamma(x); x real
|
|
!
|
|
! 5) SUBROUTINE CGAMA(X,Y,KF,GR,GI) <-- Gamma(z); z = x + iy
|
|
! or Log (Gamma(z))
|
|
!
|
|
! 6) SUBROUTINE CGAMMA(MO,Z,W) <-- Gamma(z); z = x + iy
|
|
! or Log (Gamma(z))
|
|
!
|
|
! 7) FUNCTION ZGAMMA(ARG,LNPFQ) <-- Gamma(z)
|
|
!
|
|
! 8) SUBROUTINE ZGAM(CARG,CANS,ERREST,MODE) <-- Gamma(z); z = x + iy
|
|
! or Log (Gamma(z))
|
|
! or Log (Gamma(z))
|
|
!
|
|
USE ACCURACY_REAL
|
|
!
|
|
CONTAINS
|
|
!
|
|
!=======================================================================
|
|
!
|
|
FUNCTION DLGAMA(X)
|
|
!
|
|
!***********************************************************************
|
|
!* *
|
|
!* FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
|
|
!* 'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
|
|
!* *
|
|
!* J. R. M. HOSKING *
|
|
!* IBM RESEARCH DIVISION *
|
|
!* T. J. WATSON RESEARCH CENTER *
|
|
!* YORKTOWN HEIGHTS *
|
|
!* NEW YORK 10598, U.S.A. *
|
|
!* *
|
|
!* VERSION 3 AUGUST 1996 *
|
|
!* *
|
|
!***********************************************************************
|
|
!
|
|
! LOGARITHM OF GAMMA FUNCTION
|
|
!
|
|
! BASED ON ALGORITHM ACM291, COMMUN. ASSOC. COMPUT. MACH. (1966)
|
|
!
|
|
!
|
|
! Last modified (DS) : 20 Aug 2020
|
|
!
|
|
!
|
|
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
REAL (WP), INTENT(IN) :: X
|
|
REAL (WP) :: DLGAMA
|
|
!
|
|
REAL (WP), PARAMETER :: SMALL = 1.0E-7_WP
|
|
REAL (WP), PARAMETER :: CRIT = 13.0E0_WP
|
|
REAL (WP), PARAMETER :: BIG = 1.0E9_WP
|
|
REAL (WP), PARAMETER :: TOOBIG = 2.0E36_WP
|
|
!
|
|
REAL (WP) :: C0,C1,C2,C3,C4,C5,C6,C7
|
|
REAL (WP) :: S1,S2
|
|
REAL (WP) :: XX,SUM1,SUM2
|
|
REAL (WP) :: Y,Z
|
|
!
|
|
! C0 IS 0.5*LOG(2*PI)
|
|
! C1...C7 are the coeffts of the asymptotic expansion of DLGAMA
|
|
!
|
|
DATA C0,C1,C2,C3,C4,C5,C6,C7/ &
|
|
0.918938533204672742E0_WP , 0.833333333333333333E-1_WP, &
|
|
-0.277777777777777778E-2_WP, 0.793650793650793651E-3_WP, &
|
|
-0.595238095238095238E-3_WP, 0.841750841750841751E-3_WP, &
|
|
-0.191752691752691753E-2_WP, 0.641025641025641026E-2_WP /
|
|
!
|
|
! S1 is -(EULER'S CONSTANT), S2 is PI**2/12
|
|
!
|
|
DATA S1/ -0.577215664901532861E0_WP/
|
|
DATA S2/ 0.822467033424113218E0_WP/
|
|
!
|
|
DLGAMA = ZERO !
|
|
IF(X <= ZERO) GO TO 1000 !
|
|
IF(X > TOOBIG) GO TO 1000 !
|
|
!
|
|
! Use small-X Approximation if X is near 0, 1 or 2
|
|
!
|
|
IF(DABS(X - TWO) > SMALL) GO TO 10 !
|
|
DLGAMA = DLOG(X - ONE) !
|
|
XX = X - TWO !
|
|
GO TO 20 !
|
|
10 IF(DABS(X - ONE) > SMALL) GO TO 30 !
|
|
XX = X - ONE !
|
|
20 DLGAMA = DLGAMA + XX * (S1 + XX * S2) !
|
|
RETURN !
|
|
30 IF(X > SMALL) GO TO 40 !
|
|
DLGAMA = - DLOG(X) + S1 * X !
|
|
RETURN !
|
|
!
|
|
! Reduce to DLGAMA(X+N) where X+N>=CRIT
|
|
!
|
|
40 SUM1 = ZERO !
|
|
Y = X !
|
|
IF(Y >= CRIT) GO TO 60 !
|
|
Z = ONE !
|
|
50 Z = Z * Y !
|
|
Y = Y + ONE !
|
|
IF(Y < CRIT) GO TO 50 !
|
|
SUM1 = SUM1 - DLOG(Z) !
|
|
!
|
|
! Use asymptotic expansion if Y>=CRIT
|
|
!
|
|
60 SUM1 = SUM1 + (Y - HALF) * DLOG(Y) - Y + C0 !
|
|
SUM2 = ZERO !
|
|
IF(Y >= BIG) GO TO 70 !
|
|
Z = ONE / (Y * Y) !
|
|
SUM2 = ((((((C7*Z+C6)*Z+C5)*Z+C4)*Z+C3)*Z+C2)*Z+C1)/Y !
|
|
70 DLGAMA = SUM1 + SUM2 !
|
|
RETURN !
|
|
!
|
|
1000 RETURN !
|
|
!
|
|
7000 FORMAT(' *** ERROR *** ROUTINE DLGAMA :', &
|
|
' ARGUMENT OUT OF RANGE :',D24.16)
|
|
!
|
|
END FUNCTION DLGAMA
|
|
!
|
|
!=======================================================================
|
|
!
|
|
FUNCTION LNGAMMA(Z) RESULT(LANCZOS)
|
|
!
|
|
! Uses Lanczos-type approximation to ln(gamma) for z > 0.
|
|
! Reference:
|
|
! Lanczos, C. 'A precision approximation of the gamma
|
|
! function', J. SIAM Numer. Anal., B, 1, 86-96, 1964.
|
|
! Accuracy: About 14 significant digits except for small regions
|
|
! in the vicinity of 1 and 2.
|
|
|
|
! Programmer: Alan Miller
|
|
! 1 Creswick Street, Brighton, Vic. 3187, Australia
|
|
! e-mail: amiller @ bigpond.net.au
|
|
! Latest revision - 14 October 1996
|
|
!
|
|
!
|
|
! Last modified (DS) : 24 Aug 2020
|
|
!
|
|
!
|
|
USE REAL_NUMBERS, ONLY : ZERO,ONE,SEVEN,HALF
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER :: J
|
|
!
|
|
REAL (WP), INTENT(IN) :: Z
|
|
REAL (WP) :: LANCZOS
|
|
!
|
|
REAL (WP), PARAMETER :: LNSQRT2PI = 0.9189385332046727E0_WP
|
|
REAL (WP), PARAMETER :: SIXPT5 = 6.5E0_WP
|
|
!
|
|
REAL (WP) :: TMP
|
|
|
|
! Local variables
|
|
|
|
REAL (WP) :: A(9) = (/ &
|
|
0.9999999999995183E0_WP, &
|
|
676.5203681218835E0_WP, &
|
|
-1259.139216722289E0_WP, &
|
|
771.3234287757674E0_WP, &
|
|
-176.6150291498386E0_WP, &
|
|
12.50734324009056E0_WP, &
|
|
-0.1385710331296526E0_WP, &
|
|
0.9934937113930748E-05_WP, &
|
|
0.1659470187408462E-06_WP &
|
|
/)
|
|
!
|
|
IF(Z <= ZERO) THEN !
|
|
WRITE(6,10) !
|
|
RETURN !
|
|
END IF !
|
|
!
|
|
LANCZOS = ZERO !
|
|
TMP = Z + SEVEN !
|
|
DO J = 9, 2, -1 !
|
|
LANCZOS = LANCZOS + A(J) / TMP !
|
|
TMP = TMP - ONE !
|
|
END DO !
|
|
LANCZOS = LANCZOS + A(1)
|
|
LANCZOS = LOG(LANCZOS) + LNSQRT2PI - (Z + SIXPT5) + & !
|
|
(Z - HALF) * LOG(Z + SIXPT5) !
|
|
!
|
|
RETURN
|
|
!
|
|
! Format:
|
|
!
|
|
10 FORMAT('Error: zero or -ve argument for lngamma')
|
|
!
|
|
END FUNCTION LNGAMMA
|
|
!
|
|
!=======================================================================
|
|
!
|
|
FUNCTION DGAMLN(Z,IERR)
|
|
!
|
|
!***BEGIN PROLOGUE DGAMLN
|
|
!***SUBSIDIARY
|
|
!***PURPOSE Compute the logarithm of the Gamma function
|
|
!***LIBRARY SLATEC
|
|
!***CATEGORY C7A
|
|
!***TYPE DOUBLE PRECISION (GAMLN-S, DGAMLN-D)
|
|
!***KEYWORDS LOGARITHM OF GAMMA FUNCTION
|
|
!***AUTHOR Amos, D. E., (SNL)
|
|
!***DESCRIPTION
|
|
!
|
|
! **** A DOUBLE PRECISION ROUTINE ****
|
|
! DGAMLN COMPUTES THE NATURAL LOG OF THE GAMMA FUNCTION FOR
|
|
! Z>0. THE ASYMPTOTIC EXPANSION IS USED TO GENERATE VALUES
|
|
! GREATER THAN ZMIN WHICH ARE ADJUSTED BY THE RECURSION
|
|
! G(Z+1)=Z*G(Z) FOR Z<=ZMIN. THE FUNCTION WAS MADE AS
|
|
! PORTABLE AS POSSIBLE BY COMPUTING ZMIN FROM THE NUMBER OF BASE
|
|
! 10 DIGITS IN A WORD, RLN=MAX(-ALOG10(R1MACH(4)),0.5E-18)
|
|
! LIMITED TO 18 DIGITS OF (RELATIVE) ACCURACY.
|
|
!
|
|
! SINCE INTEGER ARGUMENTS ARE COMMON, A TABLE LOOK UP ON 100
|
|
! VALUES IS USED FOR SPEED OF EXECUTION.
|
|
!
|
|
! DESCRIPTION OF ARGUMENTS
|
|
!
|
|
! INPUT Z IS D0UBLE PRECISION
|
|
! Z - ARGUMENT, Z>0.0D0
|
|
!
|
|
! OUTPUT DGAMLN IS DOUBLE PRECISION
|
|
! DGAMLN - NATURAL LOG OF THE GAMMA FUNCTION AT Z.NE.0.0D0
|
|
! IERR - ERROR FLAG
|
|
! IERR=0, NORMAL RETURN, COMPUTATION COMPLETED
|
|
! IERR=1, Z<=0.0D0, NO COMPUTATION
|
|
!
|
|
!
|
|
!***REFERENCES COMPUTATION OF BESSEL FUNCTIONS OF COMPLEX ARGUMENT
|
|
! BY D. E. AMOS, SAND83-0083, MAY, 1983.
|
|
!***ROUTINES CALLED D1MACH, I1MACH
|
|
!***REVISION HISTORY (YYMMDD)
|
|
! 830501 DATE WRITTEN
|
|
! 830501 REVISION DATE from Version 3.2
|
|
! 910415 Prologue converted to Version 4.0 format. (BAB)
|
|
! 920128 Category corrected. (WRB)
|
|
! 921215 DGAMLN defined for Z negative. (WRB)
|
|
!***END PROLOGUE DGAMLN
|
|
!
|
|
! Last modified (DS) : 25 Aug 2020
|
|
!
|
|
!
|
|
USE REAL_NUMBERS, ONLY : ZERO,ONE,THREE,HALF
|
|
USE MACHINE_ACCURACY, ONLY : D1MACH,I1MACH
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER, INTENT(OUT) :: IERR
|
|
!
|
|
REAL (WP), INTENT(IN) :: Z
|
|
!
|
|
INTEGER :: I,I1M,K,MZ,NZ
|
|
!
|
|
REAL (WP) :: DGAMLN
|
|
REAL (WP) :: FLN,FZ,RLN,S
|
|
REAL (WP) :: CF(22)
|
|
REAL (WP) :: GLN(100)
|
|
REAL (WP) :: TLG,TRM,TST,T1,WDTOL
|
|
REAL (WP) :: ZDMY,ZINC,ZM,ZMIN,ZP,ZSQ
|
|
!
|
|
REAL (WP), PARAMETER :: CON = 1.83787706640934548356066E0_WP ! Ln(2 pi)
|
|
!
|
|
! LNGAMMA(N), N = 1,100
|
|
!
|
|
DATA GLN(1), GLN(2), GLN(3), GLN(4), GLN(5), GLN(6), GLN(7), &
|
|
GLN(8), GLN(9),GLN(10),GLN(11),GLN(12),GLN(13),GLN(14), &
|
|
GLN(15),GLN(16),GLN(17),GLN(18),GLN(19),GLN(20),GLN(21), &
|
|
GLN(22) / &
|
|
0.00000000000000000E+00_WP, 0.00000000000000000E+00_WP, &
|
|
6.93147180559945309E-01_WP, 1.79175946922805500E+00_WP, &
|
|
3.17805383034794562E+00_WP, 4.78749174278204599E+00_WP, &
|
|
6.57925121201010100E+00_WP, 8.52516136106541430E+00_WP, &
|
|
1.06046029027452502E+01_WP, 1.28018274800814696E+01_WP, &
|
|
1.51044125730755153E+01_WP, 1.75023078458738858E+01_WP, &
|
|
1.99872144956618861E+01_WP, 2.25521638531234229E+01_WP, &
|
|
2.51912211827386815E+01_WP, 2.78992713838408916E+01_WP, &
|
|
3.06718601060806728E+01_WP, 3.35050734501368889E+01_WP, &
|
|
3.63954452080330536E+01_WP, 3.93398841871994940E+01_WP, &
|
|
4.23356164607534850E+01_WP, 4.53801388984769080E+01_WP /
|
|
!
|
|
DATA GLN(23),GLN(24),GLN(25),GLN(26),GLN(27),GLN(28), &
|
|
GLN(29),GLN(30),GLN(31),GLN(32),GLN(33),GLN(34), &
|
|
GLN(35),GLN(36),GLN(37),GLN(38),GLN(39),GLN(40), &
|
|
GLN(41),GLN(42),GLN(43),GLN(44) / &
|
|
4.84711813518352239E+01_WP, 5.16066755677643736E+01_WP, &
|
|
5.47847293981123192E+01_WP, 5.80036052229805199E+01_WP, &
|
|
6.12617017610020020E+01_WP, 6.45575386270063311E+01_WP, &
|
|
6.78897431371815350E+01_WP, 7.12570389671680090E+01_WP, &
|
|
7.46582363488301644E+01_WP, 7.80922235533153106E+01_WP, &
|
|
8.15579594561150372E+01_WP, 8.50544670175815174E+01_WP, &
|
|
8.85808275421976788E+01_WP, 9.21361756036870925E+01_WP, &
|
|
9.57196945421432025E+01_WP, 9.93306124547874269E+01_WP, &
|
|
1.02968198614513813E+02_WP, 1.06631760260643459E+02_WP, &
|
|
1.10320639714757395E+02_WP, 1.14034211781461703E+02_WP, &
|
|
1.17771881399745072E+02_WP, 1.21533081515438634E+02_WP /
|
|
!
|
|
DATA GLN(45),GLN(46),GLN(47),GLN(48),GLN(49),GLN(50), &
|
|
GLN(51),GLN(52),GLN(53),GLN(54),GLN(55),GLN(56), &
|
|
GLN(57),GLN(58),GLN(59),GLN(60),GLN(61),GLN(62), &
|
|
GLN(63),GLN(64),GLN(65),GLN(66) / &
|
|
1.25317271149356895E+02_WP, 1.29123933639127215E+02_WP, &
|
|
1.32952575035616310E+02_WP, 1.36802722637326368E+02_WP, &
|
|
1.40673923648234259E+02_WP, 1.44565743946344886E+02_WP, &
|
|
1.48477766951773032E+02_WP, 1.52409592584497358E+02_WP, &
|
|
1.56360836303078785E+02_WP, 1.60331128216630907E+02_WP, &
|
|
1.64320112263195181E+02_WP, 1.68327445448427652E+02_WP, &
|
|
1.72352797139162802E+02_WP, 1.76395848406997352E+02_WP, &
|
|
1.80456291417543771E+02_WP, 1.84533828861449491E+02_WP, &
|
|
1.88628173423671591E+02_WP, 1.92739047287844902E+02_WP, &
|
|
1.96866181672889994E+02_WP, 2.01009316399281527E+02_WP, &
|
|
2.05168199482641199E+02_WP, 2.09342586752536836E+02_WP /
|
|
!
|
|
DATA GLN(67),GLN(68),GLN(69),GLN(70),GLN(71),GLN(72), &
|
|
GLN(73),GLN(74),GLN(75),GLN(76),GLN(77),GLN(78), &
|
|
GLN(79),GLN(80),GLN(81),GLN(82),GLN(83),GLN(84), &
|
|
GLN(85),GLN(86),GLN(87),GLN(88) / &
|
|
2.13532241494563261E+02_WP, 2.17736934113954227E+02_WP, &
|
|
2.21956441819130334E+02_WP, 2.26190548323727593E+02_WP, &
|
|
2.30439043565776952E+02_WP, 2.34701723442818268E+02_WP, &
|
|
2.38978389561834323E+02_WP, 2.43268849002982714E+02_WP, &
|
|
2.47572914096186884E+02_WP, 2.51890402209723194E+02_WP, &
|
|
2.56221135550009525E+02_WP, 2.60564940971863209E+02_WP, &
|
|
2.64921649798552801E+02_WP, 2.69291097651019823E+02_WP, &
|
|
2.73673124285693704E+02_WP, 2.78067573440366143E+02_WP, &
|
|
2.82474292687630396E+02_WP, 2.86893133295426994E+02_WP, &
|
|
2.91323950094270308E+02_WP, 2.95766601350760624E+02_WP, &
|
|
3.00220948647014132E+02_WP, 3.04686856765668715E+02_WP /
|
|
!
|
|
DATA GLN(89),GLN(90),GLN(91),GLN(92),GLN(93), GLN(94), &
|
|
GLN(95),GLN(96),GLN(97),GLN(98),GLN(99),GLN(100) / &
|
|
3.09164193580146922E+02_WP, 3.13652829949879062E+02_WP, &
|
|
3.18152639620209327E+02_WP, 3.22663499126726177E+02_WP, &
|
|
3.27185287703775217E+02_WP, 3.31717887196928473E+02_WP, &
|
|
3.36261181979198477E+02_WP, 3.40815058870799018E+02_WP, &
|
|
3.45379407062266854E+02_WP, 3.49954118040770237E+02_WP, &
|
|
3.54539085519440809E+02_WP, 3.59134205369575399E+02_WP /
|
|
!
|
|
! Coefficients of asymptotic expansion
|
|
!
|
|
DATA CF(1), CF(2), CF(3), CF(4), CF(5), CF(6), CF(7), CF(8), &
|
|
CF(9),CF(10),CF(11),CF(12),CF(13),CF(14),CF(15), &
|
|
CF(16),CF(17),CF(18),CF(19),CF(20),CF(21),CF(22) / &
|
|
8.33333333333333333E-02_WP, -2.77777777777777778E-03_WP, &
|
|
7.93650793650793651E-04_WP, -5.95238095238095238E-04_WP, &
|
|
8.41750841750841751E-04_WP, -1.91752691752691753E-03_WP, &
|
|
6.41025641025641026E-03_WP, -2.95506535947712418E-02_WP, &
|
|
1.79644372368830573E-01_WP, -1.39243221690590112E+00_WP, &
|
|
1.34028640441683920E+01_WP, -1.56848284626002017E+02_WP, &
|
|
2.19310333333333333E+03_WP, -3.61087712537249894E+04_WP, &
|
|
6.91472268851313067E+05_WP, -1.52382215394074162E+07_WP, &
|
|
3.82900751391414141E+08_WP, -1.08822660357843911E+10_WP, &
|
|
3.47320283765002252E+11_WP, -1.23696021422692745E+13_WP, &
|
|
4.88788064793079335E+14_WP, -2.13203339609193739E+16_WP /
|
|
!
|
|
!***First executable statement DGAMLN
|
|
!
|
|
IERR = 0 !
|
|
IF(Z <= ZERO) GO TO 70 !
|
|
IF(Z > 101.0E0_WP) GO TO 10 !
|
|
NZ = INT(Z) !
|
|
FZ = Z - NZ !
|
|
IF(FZ > ZERO) GO TO 10 !
|
|
IF(NZ > 100) GO TO 10 !
|
|
DGAMLN = GLN(NZ) !
|
|
RETURN !
|
|
10 CONTINUE !
|
|
WDTOL = D1MACH(4) !
|
|
WDTOL = MAX(WDTOL,0.5E-18_WP) !
|
|
I1M = I1MACH(14) !
|
|
RLN = D1MACH(5) * I1M !
|
|
FLN = MIN(RLN,20.0E0_WP) !
|
|
FLN = MAX(FLN,THREE) !
|
|
FLN = FLN - THREE !
|
|
ZM = 1.8000E0_WP + 0.3875E0_WP * FLN !
|
|
MZ = INT(ZM) + 1 !
|
|
ZMIN = MZ !
|
|
ZDMY = Z !
|
|
ZINC = ZERO !
|
|
IF(Z >= ZMIN) GO TO 20 !
|
|
ZINC = ZMIN - NZ !
|
|
ZDMY = Z + ZINC !
|
|
20 CONTINUE !
|
|
ZP = ONE / ZDMY !
|
|
T1 = CF(1) * ZP !
|
|
S = T1 !
|
|
IF(ZP < WDTOL) GO TO 40 !
|
|
ZSQ = ZP * ZP !
|
|
TST = T1 * WDTOL !
|
|
DO K = 2,22 !
|
|
ZP = ZP * ZSQ !
|
|
TRM = CF(K) * ZP !
|
|
IF(ABS(TRM) < TST) GO TO 40 !
|
|
S = S + TRM !
|
|
END DO !
|
|
40 CONTINUE !
|
|
IF(ZINC /= ZERO) GO TO 50 !
|
|
TLG = LOG(Z) !
|
|
DGAMLN = Z * (TLG - ONE) + HALF * (CON - TLG) + S !
|
|
RETURN !
|
|
50 CONTINUE !
|
|
ZP = ONE !
|
|
NZ = INT(ZINC) !
|
|
DO I = 1,NZ !
|
|
ZP = ZP * (Z + (I - 1)) !
|
|
END DO !
|
|
TLG = LOG(ZDMY) !
|
|
DGAMLN = ZDMY * (TLG - ONE) - LOG(ZP) + HALF * (CON - TLG) + S!
|
|
RETURN !
|
|
!
|
|
70 CONTINUE !
|
|
DGAMLN = D1MACH(2) !
|
|
IERR = 1 !
|
|
!
|
|
RETURN !
|
|
!
|
|
END FUNCTION DGAMLN
|
|
!
|
|
!=======================================================================
|
|
!
|
|
SUBROUTINE GAMMA(X,GA)
|
|
!
|
|
!*********************************************************************72
|
|
!
|
|
! GAMMA computes the Gamma function.
|
|
!
|
|
! Licensing:
|
|
!
|
|
! This routine is copyrighted by Shanjie Zhang and Jianming Jin. However,
|
|
! they give permission to incorporate this routine into a user program
|
|
! provided that the copyright is acknowledged.
|
|
!
|
|
! Modified:
|
|
!
|
|
! 14 July 2012
|
|
!
|
|
! Author:
|
|
!
|
|
! Shanjie Zhang, Jianming Jin
|
|
!
|
|
! Reference:
|
|
!
|
|
! Shanjie Zhang, Jianming Jin,
|
|
! Computation of Special Functions,
|
|
! Wiley, 1996,
|
|
! ISBN: 0-471-11963-6,
|
|
! LC: QA351.C45.
|
|
!
|
|
! ========================================================
|
|
!
|
|
! Purpose: Compute gamma function Gamma(x)
|
|
!
|
|
! Input : X --- Argument of Gamma(x)
|
|
! ( x is not equal to 0,-1,-2,úúú)
|
|
!
|
|
! Output: GA --- Gamma(x)
|
|
!
|
|
! ========================================================
|
|
!
|
|
!
|
|
! Last modified (DS) : 1 Sep 2020
|
|
!
|
|
!
|
|
USE REAL_NUMBERS, ONLY : ZERO,ONE,INF
|
|
USE PI_ETC, ONLY : PI
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER :: K,M,M1
|
|
!
|
|
REAL (WP), INTENT(IN) :: X
|
|
!
|
|
REAL (WP), INTENT(OUT) :: GA
|
|
!
|
|
REAL (WP) :: G(26)
|
|
REAL (WP) :: GR
|
|
REAL (WP) :: R,Z
|
|
!
|
|
SAVE G
|
|
!
|
|
DATA G / & !
|
|
1.0E+00_WP , & !
|
|
0.5772156649015329E+00_WP, & !
|
|
-0.6558780715202538E+00_WP, & !
|
|
-0.420026350340952E-01_WP , & !
|
|
0.1665386113822915E+00_WP, & !
|
|
-0.421977345555443E-01_WP , & !
|
|
-0.96219715278770E-02_WP , & !
|
|
0.72189432466630E-02_WP , & !
|
|
-0.11651675918591E-02_WP , & !
|
|
-0.2152416741149E-03_WP , & !
|
|
0.1280502823882E-03_WP , & !
|
|
-0.201348547807E-04_WP , & !
|
|
-0.12504934821E-05_WP , & !
|
|
0.11330272320E-05_WP , & !
|
|
-0.2056338417E-06_WP , & !
|
|
0.61160950E-08_WP , & !
|
|
0.50020075E-08_WP , & !
|
|
-0.11812746E-08_WP , & !
|
|
0.1043427E-09_WP , & !
|
|
0.77823E-11_WP , & !
|
|
-0.36968E-11_WP , & !
|
|
0.51E-12_WP , & !
|
|
-0.206E-13_WP , & !
|
|
-0.54E-14_WP , & !
|
|
0.14E-14_WP , & !
|
|
0.1E-15_WP /
|
|
!
|
|
IF(X == INT(X)) THEN !
|
|
!
|
|
IF(ZERO < X) THEN !
|
|
GA = ONE !
|
|
M1 = INT(X) - 1 !
|
|
DO K = 2, M1 !
|
|
GA = GA * K !
|
|
END DO !
|
|
ELSE !
|
|
GA = INF !
|
|
END IF !
|
|
!
|
|
ELSE !
|
|
!
|
|
IF(ONE < DABS(X) ) THEN !
|
|
Z = DABS(X) !
|
|
M = INT(Z) !
|
|
R = ONE !
|
|
DO K = 1, M !
|
|
R = R * (Z - K) !
|
|
END DO !
|
|
Z = Z - M !
|
|
ELSE !
|
|
Z = X !
|
|
END IF !
|
|
!
|
|
GR = G(26) !
|
|
DO K = 25, 1, -1 !
|
|
GR = GR * Z + G(K) !
|
|
END DO !
|
|
GA = ONE / (GR * Z)
|
|
!
|
|
IF(ONE < DABS(X)) THEN !
|
|
GA = GA * R !
|
|
IF(X < ZERO) THEN !
|
|
GA = - PI / (X * GA * DSIN(PI * X)) !
|
|
END IF !
|
|
END IF !
|
|
!
|
|
END IF !
|
|
!
|
|
RETURN !
|
|
!
|
|
END SUBROUTINE GAMMA
|
|
!
|
|
!=======================================================================
|
|
!
|
|
SUBROUTINE CGAMA(X,Y,KF,GR,GI)
|
|
!
|
|
! -----------------------------------------------------------
|
|
!
|
|
! Purpose: Compute the gamma function G(z) or Ln[G(z)]
|
|
! for a complex argument
|
|
!
|
|
! Input : x --- Real part of z
|
|
! y --- Imaginary part of z
|
|
! KF --- Function code
|
|
! KF=0 for Ln[G(z)]
|
|
! KF=1 for G(z)
|
|
!
|
|
! Output: GR --- Real part of Ln[G(z)] or G(z)
|
|
! GI --- Imaginary part of Ln[G(z)] or G(z)
|
|
!
|
|
! -----------------------------------------------------------
|
|
!
|
|
!* REFERENCE: *
|
|
!* "Fortran Routines for Computation of Special Functions, *
|
|
!* jin.ece.uiuc.edu/routines/routines.html". *
|
|
!* *
|
|
!* F90 Release By J-P Moreau, Paris. *
|
|
!* (www.jpmoreau.fr) *
|
|
!
|
|
! -----------------------------------------------------------
|
|
!
|
|
!
|
|
! Last modified (DS) : 24 Aug 2020
|
|
!
|
|
!
|
|
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,SEVEN,HALF,INF
|
|
USE PI_ETC, ONLY : PI
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER, INTENT(IN) :: KF
|
|
INTEGER :: NA,J,K
|
|
!
|
|
REAL (WP), INTENT(IN OUT) :: X,Y
|
|
REAL (WP), INTENT(OUT) :: GR,GI
|
|
REAL (WP) :: A(10)
|
|
REAL (WP) :: X1,Y1
|
|
REAL (WP) :: X0,Z1,Z2,TH,TH1,TH2,T
|
|
REAL (WP) :: GR1,GI1
|
|
REAL (WP) :: SR,SI,G0,XK
|
|
!
|
|
DATA A / 8.333333333333333E-02_WP,-2.777777777777778E-03_WP, &
|
|
7.936507936507937E-04_WP,-5.952380952380952E-04_WP, &
|
|
8.417508417508418E-04_WP,-1.917526917526918E-03_WP, &
|
|
6.410256410256410E-03_WP,-2.955065359477124E-02_WP, &
|
|
1.796443723688307E-01_WP,-1.39243221690590E+00_WP /
|
|
!
|
|
IF(Y == ZERO .AND. X==INT(X) .AND. X <= ZERO) THEN !
|
|
!
|
|
GR = INF !
|
|
GI = ZERO !
|
|
RETURN !
|
|
!
|
|
ELSE IF(X < ZERO) THEN !
|
|
!
|
|
X1 = X !
|
|
Y1 = Y !
|
|
X = - X !
|
|
Y = - Y !
|
|
!
|
|
END IF !
|
|
!
|
|
X0 = X !
|
|
!
|
|
IF(X <= SEVEN) THEN !
|
|
!
|
|
NA=INT(7-X) !
|
|
X0=X+NA !
|
|
!
|
|
END IF !
|
|
|
|
Z1 = DSQRT(X0 * X0 + Y * Y) !
|
|
TH = DATAN(Y / X0) !
|
|
GR = (X0 - HALF) * DLOG(Z1) - TH * Y - X0 + & !
|
|
HALF * DLOG(TWO * PI) !
|
|
GI = TH * (X0 - HALF) + Y * DLOG(Z1) - Y !
|
|
!
|
|
DO K = 1,10 !
|
|
XK = DFLOAT(K) !
|
|
T = Z1**(1 - 2 * K) !
|
|
GR = GR + A(K) * T *DCOS((TWO * XK - ONE) * TH) !
|
|
GI = GI - A(K) * T *DSIN((TWO * XK - ONE) * TH) !
|
|
END DO !
|
|
!
|
|
IF(X <= SEVEN) THEN !
|
|
!
|
|
GR1 = ZERO !
|
|
GI1 = ZERO !
|
|
DO J = 0,NA-1 !
|
|
GR1 = GR1 + HALF * DLOG((X + J)**2 + Y * Y) !
|
|
GI1 = GI1 + DATAN(Y / (X + J)) !
|
|
END DO !
|
|
GR = GR - GR1 !
|
|
GI = GI - GI1 !
|
|
!
|
|
END IF !
|
|
!
|
|
IF(X1 < ZERO) THEN !
|
|
!
|
|
Z1 = DSQRT(X * X + Y * Y) !
|
|
TH1 = DATAN(Y / X) !
|
|
SR = - DSIN(PI * X) * DCOSH(PI * Y) !
|
|
SI = - DCOS(PI * X) * DSINH(PI * Y) !
|
|
Z2 = DSQRT(SR * SR + SI * SI) !
|
|
TH2 = DATAN(SI / SR) !
|
|
IF(SR < ZERO) TH2 = PI + TH2 !
|
|
GR = DLOG(PI / (Z1 * Z2)) - GR !
|
|
GI = - TH1 - TH2 - GI !
|
|
X = X1 !
|
|
Y = Y1 !
|
|
!
|
|
END IF !
|
|
!
|
|
IF(KF == 1) THEN !
|
|
!
|
|
G0 = DEXP(GR) !
|
|
GR = G0 * DCOS(GI) !
|
|
GI = G0 * DSIN(GI) !
|
|
!
|
|
END IF !
|
|
|
|
RETURN !
|
|
|
|
END SUBROUTINE CGAMA
|
|
!
|
|
!=======================================================================
|
|
!
|
|
SUBROUTINE CGAMMA(MO,Z,W)
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! EVALUATION OF THE COMPLEX GAMMA AND LOGGAMMA FUNCTIONS
|
|
!
|
|
! ---------------
|
|
!
|
|
! MO IS AN INTEGER, Z A COMPLEX ARGUMENT, AND W A COMPLEX VARIABLE.
|
|
!
|
|
! W = GAMMA(Z) IF MO = 0
|
|
! W = LN(GAMMA(Z)) OTHERWISE
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
! WRITTEN BY ALFRED H. MORRIS, JR.
|
|
! NAVAL SURFACE WARFARE CENTER
|
|
! DAHLGREN, VIRGINIA
|
|
!
|
|
! This version, in a subset of Fortran 90, prepared by
|
|
! Alan.Miller @ vic.cmis.csiro.au
|
|
! http://www.ozemail.com.au/~milleraj
|
|
!
|
|
! This version is accurate to within 5 in the 14th significant
|
|
! decimal digit.
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
!
|
|
! Last modified (DS) : 20 Aug 2020
|
|
!
|
|
!
|
|
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF
|
|
USE PI_ETC, ONLY : PI
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER, INTENT(IN) :: MO
|
|
!
|
|
COMPLEX (WP), INTENT(IN) :: Z
|
|
COMPLEX (WP), INTENT(OUT) :: W
|
|
!
|
|
! Local variables
|
|
!
|
|
COMPLEX (WP) :: ETA,ETA2,SUM
|
|
!
|
|
REAL (WP), PARAMETER :: C0(12) = (/ &
|
|
.833333333333333E-01_WP, &
|
|
-.277777777777778E-02_WP, .793650793650794E-03_WP, &
|
|
-.595238095238095E-03_WP, .841750841750842E-03_WP, &
|
|
-.191752691752692E-02_WP, .641025641025641E-02_WP, &
|
|
-.295506535947712E-01_WP, .179644372368831_WP, &
|
|
-1.39243221690590_WP, 13.4028640441684_WP, &
|
|
-156.848284626002_WP /)
|
|
!
|
|
REAL (WP), PARAMETER :: PI2 = 6.28318530717959_WP
|
|
REAL (WP), PARAMETER :: ALPI = 1.14472988584940_WP
|
|
REAL (WP), PARAMETER :: HL2P = .918938533204673_WP
|
|
!
|
|
REAL (WP) :: A,A1,A2,C,CN,CUT,D,EPS
|
|
REAL (WP) :: ET,E2T,H1,H2,S,SN
|
|
REAL (WP) :: S1,S2,T,T1,T2,U,U1,U2
|
|
REAL (WP) :: V1,V2,W1,W2,X,Y,Y2
|
|
!
|
|
INTEGER :: J,K,L,M,MAX,N,NM1
|
|
!---------------------------
|
|
! ALPI = LOG(PI)
|
|
! HL2P = 0.5 * LOG(2*PI)
|
|
!---------------------------
|
|
|
|
! ****** MAX and EPS are machine dependent constants.
|
|
! MAX is the largest positive integer that may
|
|
! be used, and EPS is the smallest real number
|
|
! such that 1.0 + EPS > 1.0.
|
|
|
|
! MAX = IPMPAR(3)
|
|
MAX = HUGE(3) !
|
|
EPS = EPSILON(ONE) !
|
|
!
|
|
!---------------------------
|
|
!
|
|
X = REAL(Z, KIND=WP) !
|
|
Y = AIMAG(Z) !
|
|
IF(X < ZERO) THEN !
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
! Case when the real part of Z is negative
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
Y = ABS(Y) !
|
|
T = - PI * Y !
|
|
ET = EXP(T) !
|
|
E2T = ET * ET !
|
|
|
|
! set A1 = (1 + E2T)/2 AND A2 = (1 - E2T)/2
|
|
|
|
A1 = HALF * (ONE + E2T) !
|
|
T2 = T + T !
|
|
IF(T2 >= -0.15E0_WP) THEN !
|
|
A2 = -HALF * REXP(T2) !
|
|
ELSE !
|
|
A2 = HALF * (HALF + (HALF - E2T)) !
|
|
END IF !
|
|
!
|
|
! Compute SIN(PI*X) and COS(PI*X)
|
|
!
|
|
IF(ABS(X) >= MIN(REAL(MAX),ONE/EPS)) GO TO 70 !
|
|
K = ABS(X) !
|
|
U = X + K !
|
|
K = MOD(K,2) !
|
|
IF(U <= -HALF) THEN !
|
|
U = HALF + (HALF + U) !
|
|
K = K + 1 !
|
|
END IF !
|
|
U = PI * U !
|
|
SN = SIN(U) !
|
|
CN = COS(U) !
|
|
IF(K == 1) THEN !
|
|
SN = - SN !
|
|
CN = - CN !
|
|
END IF !
|
|
!
|
|
! Set H1 + H2*I to PI/SIN(PI*Z) or LOG(PI/SIN(PI*Z))
|
|
!
|
|
A1 = SN * A1 !
|
|
A2 = CN * A2 !
|
|
A = A1 * A1 + A2 * A2 !
|
|
IF(A == ZERO) GO TO 70 !
|
|
IF(MO == 0) THEN !
|
|
H1 = A1 / A !
|
|
H2 = -A2 / A !
|
|
C = PI * ET !
|
|
H1 = C * H1 !
|
|
H2 = C * H2 !
|
|
ELSE !
|
|
H1 = (ALPI+T) - HALF * LOG(A) !
|
|
H2 = - ATAN2(A2,A1) !
|
|
END IF !
|
|
IF(AIMAG(Z) >= ZERO) THEN !
|
|
X = ONE - X !
|
|
Y = - Y !
|
|
ELSE !
|
|
H2 = - H2 !
|
|
X = ONE - X !
|
|
END IF !
|
|
!
|
|
END IF !
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
! Case when the real part of Z is nonnegative
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
W1 = ZERO !
|
|
W2 = ZERO !
|
|
N = 0 !
|
|
T = X !
|
|
Y2 = Y * Y !
|
|
A = T * T + Y2 !
|
|
CUT = 36.0E0_WP !
|
|
IF(EPS > 1.E-8_WP) CUT = 16.0E0_WP !
|
|
IF(A < CUT) THEN !
|
|
IF(A == ZERO) GO TO 70 !
|
|
10 N = N + 1 !
|
|
T = T + ONE !
|
|
A = T * T + Y2 !
|
|
IF(A < CUT) GO TO 10 !
|
|
!
|
|
! Let S1 + S2*I be the product of the terms (Z+J)/(Z+N)
|
|
!
|
|
U1 = (X * T + Y2) / A !
|
|
U2 = Y / A !
|
|
S1 = U1 !
|
|
S2 = N * U2 !
|
|
IF(N >= 2) THEN !
|
|
U = T / A !
|
|
NM1 = N - 1 !
|
|
DO J = 1, NM1 !
|
|
V1 = U1 + J * U !
|
|
V2 = (N - J) * U2 !
|
|
C = S1 * V1 - S2 * V2 !
|
|
D = S1 * V2 + S2 * V1 !
|
|
S1 = C !
|
|
S2 = D !
|
|
END DO !
|
|
END IF !
|
|
!
|
|
! Set W1 + W2*I = LOG(S1 + S2*I) when MO is nonzero
|
|
!
|
|
S = S1 * S1 + S2 * S2 !
|
|
IF(MO /= 0) THEN !
|
|
W1 = HALF * LOG(S) !
|
|
W2 = ATAN2(S2,S1) !
|
|
END IF !
|
|
END IF !
|
|
!
|
|
! Set V1 + V2*I = (Z - 0.5) * LOG(Z + N) - Z
|
|
!
|
|
T1 = HALF * LOG(A) - ONE !
|
|
T2 = ATAN2(Y,T) !
|
|
U = X - HALF !
|
|
V1 = (U * T1 - HALF) - Y * T2 !
|
|
V2 = U * T2 + Y * T1 !
|
|
!
|
|
! Let A1 + A2*I be the asymptotic sum
|
|
!
|
|
ETA = CMPLX(T/A,-Y/A,KIND=WP) !
|
|
ETA2 = ETA * ETA !
|
|
M = 12 !
|
|
IF(A >= 289.0E0_DP) M = 6 !
|
|
IF(EPS > 1.E-8_WP) M = M / 2 !
|
|
SUM = CMPLX(C0(M), 0.0_DP, KIND=WP) !
|
|
L = M !
|
|
DO J = 2, M !
|
|
L = L - 1 !
|
|
SUM = CMPLX(C0(L),ZERO,KIND=WP) + SUM * ETA2 !
|
|
END DO !
|
|
SUM = SUM * ETA !
|
|
A1 = REAL(SUM,KIND=WP) !
|
|
A2 = AIMAG(SUM) !
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
! Gathering together the results
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
W1 = (((A1 + HL2P) - W1) + V1) - N !
|
|
W2 = (A2 - W2) + V2 !
|
|
IF(REAL(Z,KIND=DP) < ZERO) GO TO 50 !
|
|
IF(MO == 0) THEN !
|
|
!
|
|
! Case when the real part of Z is nonnegative and MO = 0
|
|
!
|
|
A = EXP(W1) !
|
|
W1 = A * COS(W2) !
|
|
W2 = A * SIN(W2) !
|
|
IF(N == 0) GO TO 60 !
|
|
C = (S1 * W1 + S2 * W2) / S !
|
|
D = (S1 * W2 - S2 *W1) / S !
|
|
W1 = C !
|
|
W2 = D !
|
|
GO TO 60 !
|
|
END IF !
|
|
!
|
|
! Case when the real part of z is nonnegative and MO is nonzero.
|
|
! The angle W2 is reduced to the interval -PI < W2 <= PI.
|
|
!
|
|
40 IF(W2 <= PI) THEN !
|
|
K = HALF - W2 / PI2 !
|
|
W2 = W2 + PI2 * K !
|
|
GO TO 60 !
|
|
END IF !
|
|
K = W2 / PI2 - HALF !
|
|
W2 = W2 - PI2 * REAL(K+1) !
|
|
IF(W2 <= - PI) W2 = PI !
|
|
GO TO 60 !
|
|
!
|
|
! Case when the real part of Z is negative and MO is nonzero
|
|
!
|
|
50 IF(MO /= 0) THEN !
|
|
W1 = H1 - W1 !
|
|
W2 = H2 - W2 !
|
|
GO TO 40 !
|
|
END IF !
|
|
!
|
|
! Case when the real part of Z is negative and MO = 0
|
|
!
|
|
A = EXP(-W1) !
|
|
T1 = A * COS(-W2) !
|
|
T2 = A * SIN(-W2) !
|
|
W1 = H1 * T1 - H2 * T2 !
|
|
W2 = H1 * T2 + H2 * T1 !
|
|
IF(N /= 0) THEN !
|
|
C = W1 * S1 - W2 * S2 !
|
|
D = W1 * S2 + W2 * S1 !
|
|
W1 = C !
|
|
W2 = D !
|
|
END IF !
|
|
!
|
|
! Termination
|
|
!
|
|
60 W = CMPLX(W1,W2,KIND=WP) !
|
|
RETURN !
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
! The requested value cannot be computed
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
70 W = (ZERO,ZERO) !
|
|
RETURN !
|
|
!
|
|
CONTAINS
|
|
!
|
|
FUNCTION REXP(X) RESULT(FN_VAL)
|
|
!
|
|
!-----------------------------------------------------------------------
|
|
! Evaluation of the function EXP(X) - 1
|
|
!-----------------------------------------------------------------------
|
|
!
|
|
!
|
|
! Last modified (DS) : 24 Aug 2020
|
|
!
|
|
!
|
|
USE REAL_NUMBERS, ONLY : ZERO,ONE,HALF
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
REAL (WP), INTENT(IN) :: X
|
|
REAL (WP) :: FN_VAL
|
|
!
|
|
! Local variables
|
|
!
|
|
REAL (WP), PARAMETER :: P1 = .914041914819518E-09_WP
|
|
REAL (WP), PARAMETER :: P2 = .238082361044469E-01_WP
|
|
REAL (WP), PARAMETER :: Q1 = -.499999999085958_WP
|
|
REAL (WP), PARAMETER :: Q2 = .107141568980644_WP
|
|
REAL (WP), PARAMETER :: Q3 = -.119041179760821E-01_WP
|
|
REAL (WP), PARAMETER :: Q4 = .595130811860248E-03_WP
|
|
!
|
|
REAL (WP) :: E
|
|
!
|
|
!-----------------------
|
|
!
|
|
IF(ABS(X) <= 0.15E0_WP) THEN !
|
|
FN_VAL = X * ( ((P2*X + P1)*X + ONE) / & !
|
|
((((Q4*X + Q3)*X + Q2)*X + Q1)*X + ONE) ) !
|
|
RETURN !
|
|
END IF !
|
|
!
|
|
IF(X >= ZERO) THEN !
|
|
E = EXP(X) !
|
|
FN_VAL = E * (HALF + (HALF - ONE / E)) !
|
|
RETURN !
|
|
END IF !
|
|
!
|
|
IF(X >= -37.0E0_WP) THEN !
|
|
FN_VAL = (EXP(X) - HALF) - HALF !
|
|
RETURN !
|
|
END IF !
|
|
!
|
|
FN_VAL = - ONE !
|
|
RETURN !
|
|
!
|
|
END FUNCTION REXP
|
|
!
|
|
END SUBROUTINE CGAMMA
|
|
!
|
|
!=======================================================================
|
|
!
|
|
FUNCTION ZGAMMA(ARG,LNPFQ)
|
|
!
|
|
! ****************************************************************
|
|
! * *
|
|
! * FUNCTION ZGAMMA *
|
|
! * *
|
|
! * *
|
|
! * Description : Calculates the complex gamma function. Based *
|
|
! * on a program written by F.A. Parpia published in Computer*
|
|
! * Physics Communications as the `GRASP2' program (public *
|
|
! * domain). *
|
|
! * *
|
|
! * *
|
|
! * Subprograms called: none. *
|
|
! * *
|
|
! ****************************************************************
|
|
!
|
|
!
|
|
! Note : This function was originally called CGAMMA
|
|
! in the hypergeometric function code pFq written by
|
|
! by W.F. Perger, M. Nardin and A. Bhalla
|
|
!
|
|
!
|
|
! Last modified (DS) : 28 Aug 2020
|
|
!
|
|
!
|
|
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,TEN, &
|
|
HALF,TENTH
|
|
USE PI_ETC, ONLY : PI
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
COMPLEX (WP) :: ZGAMMA,ARG
|
|
!
|
|
REAL (WP) :: FN(7),FD(7)
|
|
REAL (WP) :: ARGR,ARGI
|
|
REAL (WP) :: DNUM,TENMAX,EXPMAX
|
|
REAL (WP) :: PRECIS,HLNTPI,TWOI
|
|
REAL (WP) :: DIFF,CLNGI,CLNGR
|
|
REAL (WP) :: FACNEG,ARGUM
|
|
REAL (WP) :: OBASQ,OVLFAC,FAC
|
|
REAL (WP) :: ARGUI,ARGUI2
|
|
REAL (WP) :: ARGUR,ARGUR2
|
|
REAL (WP) :: OVLFR,OVLFI
|
|
REAL (WP) :: TERMR,TERMI
|
|
REAL (WP) :: OBASQR,OBASQI
|
|
REAL (WP) :: ZFACR,ZFACI
|
|
REAL (WP) :: RESR,RESI
|
|
!
|
|
LOGICAL :: FIRST,NEGARG
|
|
!
|
|
INTEGER :: LNPFQ
|
|
INTEGER :: ITNMAX
|
|
INTEGER :: I
|
|
!
|
|
!----------------------------------------------------------------------
|
|
!
|
|
! These are the Bernoulli numbers B02, B04, ..., B14, expressed as
|
|
! rational numbers. From Abramowitz and Stegun, P. 810.
|
|
!
|
|
DATA FN / 1.0E00_WP, -1.0E00_WP, 1.0E00_WP, &
|
|
-1.0E00_WP, 5.0E00_WP, -691.0E00_WP, &
|
|
7.0E00_WP /
|
|
DATA FD/ 6.0E00_WP, 30.0E00_WP, 42.0E00_WP, &
|
|
30.0E00_WP, 66.0E00_WP, 2730.0E00_WP, &
|
|
6.0E00_WP /
|
|
!
|
|
!----------------------------------------------------------------------
|
|
!
|
|
DATA HLNTPI /1.0E00_WP/
|
|
!
|
|
DATA FIRST/.TRUE./
|
|
!
|
|
ARGR = DREAL(ARG) !
|
|
ARGI = DIMAG(ARG) !
|
|
!
|
|
! On the first entry to this routine, set up the constants required
|
|
! for the reflection formula (CF. Abramowitz and Stegun 6.1.17) and
|
|
! Stirling's approximation (CF. Abramowitz and Stegun 6.1.40).
|
|
!
|
|
IF(FIRST) THEN !
|
|
!
|
|
! Set the machine-dependent parameters:
|
|
!
|
|
! TENMAX - maximum size of exponent of 10
|
|
!
|
|
ITNMAX = 1 !
|
|
DNUM = TENTH !
|
|
10 ITNMAX = ITNMAX+1 !
|
|
DNUM = DNUM * TENTH !
|
|
IF(DNUM > ZERO) GO TO 10 !
|
|
ITNMAX = ITNMAX - 1 !
|
|
TENMAX = DFLOAT(ITNMAX) !
|
|
!
|
|
! EXPMAX - maximum size of exponent of E
|
|
!
|
|
DNUM = TENTH**ITNMAX !
|
|
EXPMAX = - LOG(DNUM) !
|
|
!
|
|
! PRECIS - machine precision
|
|
!
|
|
PRECIS = ONE !
|
|
20 PRECIS = PRECIS / TWO !
|
|
DNUM = PRECIS + ONE !
|
|
IF(DNUM > ONE) GO TO 20 !
|
|
PRECIS = TWO * PRECIS !
|
|
!
|
|
HLNTPI = HALF * LOG(TWO*PI) !
|
|
!
|
|
DO I = 1,7 !
|
|
FN(I) = FN(I) / FD(I) !
|
|
TWOI = TWO * DBLE(I) !
|
|
FN(I) = FN(I) / (TWOI * (TWOI - ONE)) !
|
|
END DO !
|
|
!
|
|
FIRST = .FALSE. !
|
|
!
|
|
END IF !
|
|
!
|
|
! Cases where the argument is real
|
|
!
|
|
IF(ARGI == ZERO) THEN !
|
|
!
|
|
! Cases where the argument is real and negative
|
|
!
|
|
IF(ARGR <= ZERO) THEN !
|
|
!
|
|
! Stop with an error message if the argument is too near a pole
|
|
!
|
|
DIFF = ABS(DBLE(NINT(ARGR))-ARGR) !
|
|
IF(DIFF <= TWO*PRECIS) THEN !
|
|
WRITE(6,300) !
|
|
WRITE(6,301) ARGR,ARGI !
|
|
STOP '010801' !
|
|
ELSE !
|
|
!
|
|
! Otherwise use the reflection formula (Abramowitz and Stegun 6.1.17)
|
|
! to ensure that the argument is suitable for Stirling's
|
|
! formula
|
|
!
|
|
ARGUM = PI/(-ARGR*SIN(PI*ARGR)) !
|
|
IF(ARGUM < ZERO) THEN !
|
|
ARGUM = - ARGUM !
|
|
CLNGI = PI !
|
|
ELSE !
|
|
CLNGI = ZERO !
|
|
END IF
|
|
FACNEG = LOG(ARGUM) !
|
|
ARGUR = - ARGR !
|
|
NEGARG = .TRUE. !
|
|
!
|
|
END IF
|
|
!
|
|
! Cases where the argument is real and positive
|
|
!
|
|
ELSE !
|
|
!
|
|
CLNGI = ZERO !
|
|
ARGUR = ARGR !
|
|
NEGARG = .FALSE. !
|
|
!
|
|
END IF
|
|
!
|
|
! Use Abramowitz and Stegun formula 6.1.15 to ensure that
|
|
! the argument in Stirling's formula is greater than 10
|
|
!
|
|
OVLFAC = ONE !
|
|
40 IF(ARGUR < TEN) THEN !
|
|
OVLFAC = OVLFAC * ARGUR !
|
|
ARGUR = ARGUR + ONE !
|
|
GO TO 40 !
|
|
END IF !
|
|
!
|
|
! Now use Stirling's formula to compute LOG(GAMMA(ARGUM))
|
|
!
|
|
CLNGR = (ARGUR - HALF) * LOG(ARGUR) - ARGUR + HLNTPI !
|
|
FAC = ARGUR !
|
|
OBASQ = ONE / (ARGUR * ARGUR) !
|
|
DO I = 1,7
|
|
FAC = FAC * OBASQ !
|
|
CLNGR = CLNGR + FN(I) * FAC !
|
|
END DO !
|
|
!
|
|
! Include the contributions from the recurrence and reflection
|
|
! formulae
|
|
!
|
|
CLNGR = CLNGR - LOG(OVLFAC) !
|
|
IF(NEGARG) CLNGR = FACNEG - CLNGR !
|
|
!
|
|
ELSE !
|
|
!
|
|
! Cases where the argument is complex
|
|
!
|
|
ARGUR = ARGR !
|
|
ARGUI = ARGI !
|
|
ARGUI2 = ARGUI * ARGUI !
|
|
!
|
|
! Use the recurrence formula (Abramowitz and Stegun 6.1.15)
|
|
! to ensure that the magnitude of the argument in Stirling's
|
|
! formula is greater than 10
|
|
!
|
|
OVLFR = ONE !
|
|
OVLFI = ZERO !
|
|
60 ARGUM = SQRT(ARGUR * ARGUR + ARGUI2) !
|
|
IF(ARGUM < TEN) THEN !
|
|
TERMR = OVLFR * ARGUR - OVLFI * ARGUI !
|
|
TERMI = OVLFR * ARGUI + OVLFI * ARGUR !
|
|
OVLFR = TERMR !
|
|
OVLFI = TERMI !
|
|
ARGUR = ARGUR + ONE !
|
|
GO TO 60 !
|
|
END IF !
|
|
!
|
|
! Now use Stirling's formula to compute LOG(GAMMA(ARGUM))
|
|
!
|
|
ARGUR2 = ARGUR * ARGUR !
|
|
TERMR = HALF * LOG(ARGUR2 + ARGUI2) !
|
|
TERMI = ATAN2(ARGUI,ARGUR) !
|
|
CLNGR = (ARGUR - HALF) *TERMR - ARGUI * TERMI - ARGUR & !
|
|
+ HLNTPI !
|
|
CLNGI = (ARGUR - HALF) *TERMI + ARGUI * TERMR - ARGUI !
|
|
FAC = (ARGUR2 + ARGUI2)**(-2) !
|
|
OBASQR = (ARGUR2 - ARGUI2) * FAC !
|
|
OBASQI = - TWO * ARGUR * ARGUI * FAC !
|
|
ZFACR = ARGUR !
|
|
ZFACI = ARGUI !
|
|
DO I = 1,7 !
|
|
TERMR = ZFACR * OBASQR - ZFACI * OBASQI !
|
|
TERMI = ZFACR * OBASQI + ZFACI * OBASQR !
|
|
FAC = FN(I) !
|
|
CLNGR = CLNGR + TERMR * FAC !
|
|
CLNGI = CLNGI + TERMI * FAC !
|
|
ZFACR = TERMR !
|
|
ZFACI = TERMI !
|
|
END DO !
|
|
!
|
|
! Add in the relevant pieces from the recurrence formula
|
|
!
|
|
CLNGR = CLNGR - HALF * LOG(OVLFR * OVLFR + OVLFI * OVLFI) !
|
|
CLNGI = CLNGI - ATAN2(OVLFI,OVLFR) !
|
|
!
|
|
END IF !
|
|
!
|
|
IF(LNPFQ == 1) THEN !
|
|
ZGAMMA = DCMPLX(CLNGR,CLNGI) !
|
|
RETURN !
|
|
END IF !
|
|
!
|
|
! Now exponentiate the complex Log Gamma Function to get
|
|
! the complex Gamma function
|
|
!
|
|
IF( (CLNGR <= EXPMAX) .AND. (CLNGR >= -EXPMAX) ) THEN !
|
|
FAC = EXP(CLNGR) !
|
|
ELSE !
|
|
WRITE(6,300) !
|
|
WRITE(6,302) CLNGR !
|
|
STOP '010802' !
|
|
END IF !
|
|
RESR = FAC * COS(CLNGI) !
|
|
RESI = FAC * SIN(CLNGI) !
|
|
ZGAMMA = DCMPLX(RESR,RESI) !
|
|
!
|
|
RETURN
|
|
!
|
|
300 FORMAT (///' ***** ERROR IN SUBROUTINE ZGAMMA *****')
|
|
301 FORMAT (' ARGUMENT (',1P,1D14.7,',',1D14.7,') TOO CLOSE TO A',&
|
|
' POLE.')
|
|
302 FORMAT (' ARGUMENT TO EXPONENTIAL FUNCTION (',1P,1D14.7, &
|
|
') OUT OF RANGE.')
|
|
!
|
|
END FUNCTION ZGAMMA
|
|
!
|
|
!=======================================================================
|
|
!
|
|
SUBROUTINE ZGAM(CARG,CANS,ERREST,MODE)
|
|
!
|
|
! Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
|
|
! ALL RIGHTS RESERVED.
|
|
! Based on Government Sponsored Research NAS7-03001.
|
|
!>> 1996-03-30 ZGAM Krogh Added external statement.
|
|
!>> 1995-11-20 ZGAM Krogh Set up so M77CON converts between "Z" and "C".
|
|
!>> 1994-08-17 CLL Add tests on BIGINT to allow easier conversion to C.
|
|
!>> 1994-05-25 ZGAM WVS generate COEF using PARAMETER
|
|
!>> 1994-04-20 ZGAM CLL Make DP and SP versions similar.
|
|
!>> 1993-04-13 ZGAM CLL Edit for conversion to C.
|
|
!>> 1992-04-20 ZGAM CLL Edited comments.
|
|
!>> 1991-11-11 ZGAM CLL Made [Z/C]GAM from CDLGAM
|
|
!>> 1991-01-16 CDLGAM Lawson Removing use of subr D2MACH.
|
|
!>> 1985-08-02 CDLGAM Lawson Initial code.
|
|
!
|
|
! *** COMPLEX GAMMA AND LOGGAMMA FUNCTIONS WITH ERROR ESTIMATE
|
|
!
|
|
! -----------------------------------------------------------------
|
|
! SUBROUTINE ARGUMENTS
|
|
! --------------------
|
|
! CARG() A complex argument, given as an array of 2 floating-point
|
|
! elements consisting of the real component
|
|
! followed by the imaginary component.
|
|
!
|
|
! CANS() The complex answer, stored as an array of 2
|
|
! floating-point numbers, representing the real and
|
|
! imaginary parts.
|
|
!
|
|
! ERREST On output ERREST gives an estimate of the absolute
|
|
! (for LOGGAMMA) or the relative (for GAMMA) error
|
|
! of the answer.
|
|
!
|
|
! MODE Selects function to be computed. set it to 0 for
|
|
! LOGGAMMA, and 1 for GAMMA.
|
|
! -----------------------------------------------------------------
|
|
! MACHINE DEPENDANT PARAMETERS
|
|
! If the fraction part of a floating point number
|
|
! contains T digits using base B then
|
|
! EPS3 = B ** (-T)
|
|
! EPS4 = B ** (-T+1)
|
|
! OMEGA = overflow limit
|
|
! DESET = 5.0 on a binary machine
|
|
! = 2.0 on a base 16 machine
|
|
! -----------------------------------------------------------------
|
|
! REFERENCE: H.KUKI, Comm.ACM, Vol.15, (1972),
|
|
! pp.262-267, 271-272. Subroutine name was CDLGAM.
|
|
! Code developed for UNIVAC 1108 by E.W.NG, JPL, 1969.
|
|
! Modified for FORTRAN 77 portability by C.L.LAWSON &
|
|
! S.CHAN, JPL, 1983.
|
|
! -----------------------------------------------------------------
|
|
!--Z replaces "?": ?GAM
|
|
!--D (type)replaces "?": ?ERM1, ?ERV1
|
|
! Also uses I1MACH, and D1MACH
|
|
! -----------------------------------------------------------------
|
|
!
|
|
! Last modified (DS) : 1 Sep 2020
|
|
!
|
|
!
|
|
USE MACHINE_ACCURACY
|
|
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,FIVE,SIX,TEN, &
|
|
HALF,TENTH
|
|
USE PI_ETC, ONLY : PI
|
|
USE ERROR_CALTECH
|
|
!
|
|
IMPLICIT NONE
|
|
!
|
|
INTEGER :: ITEMP,J,K
|
|
INTEGER :: LF1,LF2,LF3
|
|
INTEGER :: MODE,N
|
|
!
|
|
REAL (WP) :: A,AL1,AL2,B,BIGINT
|
|
REAL (WP) :: CARG(2),CANS(2),COEF(7),CUT1
|
|
REAL (WP) :: DE0,DE1,DELTA,DESET,DN
|
|
REAL (WP) :: ELIMIT,EPS3,EPS4,ERREST
|
|
REAL (WP) :: H,H1,H2,OMEGA
|
|
REAL (WP) :: REPS3,T1,T2
|
|
REAL (WP) :: U,U1,U2,UU1,UU2,UUU1,UUU2
|
|
REAL (WP) :: V1,V2,VV1,VV2
|
|
REAL (WP) :: W1,W2,W3,Y1,Z1,Z2,ZZ1
|
|
!
|
|
REAL (WP), PARAMETER :: F0 = 840.07385296052619E0_WP
|
|
REAL (WP), PARAMETER :: F1 = 20.001230821894200E0_WP
|
|
REAL (WP), PARAMETER :: G0 = 1680.1477059210524E0_WP
|
|
REAL (WP), PARAMETER :: G1 = 180.01477047052042E0_WP
|
|
REAL (WP), PARAMETER :: TWOPI = 6.283185307179586476925E0_WP
|
|
REAL (WP), PARAMETER :: HL2P = 0.918938533204672742E0_WP
|
|
REAL (WP), PARAMETER :: AL2P = 1.83787706640934548E0_WP
|
|
!
|
|
REAL (WP), PARAMETER :: C1 = +1.0e0_WP / 156.0e0_WP
|
|
REAL (WP), PARAMETER :: C2 = -691.0e0_WP / 360360.0e0_WP
|
|
REAL (WP), PARAMETER :: C3 = +1.0e0_WP / 1188.0e0_WP
|
|
REAL (WP), PARAMETER :: C4 = -1.0e0_WP / 1680.0e0_WP
|
|
REAL (WP), PARAMETER :: C5 = +1.0e0_WP / 1260.0e0_WP
|
|
REAL (WP), PARAMETER :: C6 = -1.0e0_WP / 360.0e0_WP
|
|
REAL (WP), PARAMETER :: C7 = +1.0e0_WP / 12.0e0_WP
|
|
!
|
|
LOGICAL :: FIRST
|
|
!
|
|
SAVE FIRST,BIGINT,COEF,OMEGA,EPS4,EPS3,REPS3,CUT1,DESET,ELIMIT
|
|
|
|
!
|
|
! COEF(8-i) = bernoulli(2i)/(2i*(2i-1)).
|
|
!
|
|
DATA COEF /C1,C2,C3,C4,C5,C6,C7/
|
|
!
|
|
DATA FIRST /.TRUE./
|
|
!
|
|
! ------------------------------------------------------------------
|
|
!
|
|
IF (FIRST) THEN !
|
|
FIRST = .FALSE. !
|
|
OMEGA = D1MACH(2) !
|
|
EPS3 = D1MACH(3) !
|
|
EPS4 = D1MACH(4) !
|
|
REPS3 = ONE / EPS3 !
|
|
ELIMIT = LOG(OMEGA) !
|
|
CUT1 = LOG(EPS3) !
|
|
BIGINT = I1MACH(9) - 2 !
|
|
IF (I1MACH(10) == 2) THEN !
|
|
DESET = FIVE !
|
|
ELSE !
|
|
DESET = TWO !
|
|
END IF !
|
|
END IF !
|
|
DE0 = DESET !
|
|
DE1 = ZERO !
|
|
Z1 = CARG(1) !
|
|
Z2 = CARG(2) !
|
|
!
|
|
! *** Setting DELTA = estimate of uncertainty level of
|
|
! argument data.
|
|
!
|
|
DELTA = EPS4 * (ABS(Z1) + ABS(Z2)) !
|
|
IF(DELTA == ZERO) DELTA = EPS4 !
|
|
!
|
|
! *** Force sign of imaginary part of ARG to non-negative
|
|
!
|
|
LF1 = 0 !
|
|
IF (Z2 < ZERO) THEN !
|
|
LF1 = 1 !
|
|
Z2 = - Z2 !
|
|
END IF !
|
|
LF2 = 0 !
|
|
IF (Z1 >= ZERO) GO TO 100 !
|
|
!
|
|
! *** Case when real part of ARG is negative
|
|
!
|
|
LF2 = 1 !
|
|
LF1 = LF1 - 1 !
|
|
T1 = AL2P - PI * Z2 !
|
|
T2 = PI * (HALF - Z1) !
|
|
U = - TWOPI * Z2 !
|
|
IF (U < -0.1054E0_WP) THEN !
|
|
A = ZERO !
|
|
!
|
|
! *** If EXP(U) .LE. EPS3, ignore it to save time and to avoid
|
|
! irrelevant underflow
|
|
!
|
|
IF (U > CUT1) THEN !
|
|
A = EXP(U) !
|
|
END IF !
|
|
H1 = ONE - A !
|
|
ELSE !
|
|
U2 = U * U !
|
|
A = - U * (F1 * U2 + F0) !
|
|
H1 = (A + A) /((U2 + G1) * U2 + G0 + A) !
|
|
A = ONE - H1 !
|
|
END IF !
|
|
!
|
|
! Here Z1 is negative.
|
|
!
|
|
IF(Z1 < -BIGINT) THEN !
|
|
CALL DERM1('ZGAM',3,0,'Require CARG(1) >= -BIGINT', & !
|
|
'CARG(1)', Z1, ',') !
|
|
CALL DERV1('-BIGINT',-BIGINT,'.') !
|
|
GO TO 700 !
|
|
END IF !
|
|
!
|
|
! Truncate to integer: ITEMP
|
|
!
|
|
ITEMP = Z1 - HALF !
|
|
B = Z1 - ITEMP !
|
|
H2 = A*SIN(TWOPI * B) !
|
|
B = SIN(PI * B) !
|
|
H1 = H1 + (B + B) * B * A !
|
|
H = ABS(H2) + H1 - TWOPI * A * DELTA !
|
|
IF(H <= ZERO) GO TO 500 !
|
|
DE0 = DE0 + ABS(T1) + T2 !
|
|
DE1 = PI + TWOPI * A / H !
|
|
Z1 = ONE - Z1 !
|
|
!
|
|
! *** CASE when neither real part nor imaginary part of ARG is
|
|
! negative. Define threshold curve to be the broken lines
|
|
! connecting points 10F0*I, 10F4.142*I, 0.1F14.042*I,and
|
|
! 0.1FOMEGA*I
|
|
!
|
|
100 LF3 = 0 !
|
|
Y1 = Z1 - HALF !
|
|
W1 = ZERO !
|
|
W2 = ZERO !
|
|
K = 0 !
|
|
B = MAX(TENTH, MIN(TEN, 14.142E0_WP-Z2)) - Z1 !
|
|
IF(B <= ZERO) GO TO 200 !
|
|
!
|
|
! *** Case when real part of ARG is between 0 and threshold
|
|
!
|
|
LF3 = 1 !
|
|
ZZ1 = Z1 !
|
|
N = B + ONE !
|
|
DN = N !
|
|
Z1 = Z1 + DN !
|
|
A = Z1 * Z1 + Z2 * Z2 !
|
|
V1 = Z1 / A !
|
|
V2 = - Z2 / A !
|
|
!
|
|
! *** Initialize U1+U2*I as the rightmost factor 1-1/(Z+N)
|
|
!
|
|
U1 = ONE - V1 !
|
|
U2 = - V2 !
|
|
K = SIX - Z2*0.6E0_WP - ZZ1 !
|
|
IF(K > 0) THEN !
|
|
!
|
|
! *** Forward assembly of factors (Z+J-1)/(Z+N)
|
|
!
|
|
N = N - K !
|
|
UU1 = (ZZ1 * Z1 + Z2 * Z2) / A !
|
|
UU2 = DN * Z2 / A !
|
|
VV1 = ZERO !
|
|
VV2 = ZERO !
|
|
DO J = 1,K !
|
|
B = U1 * (UU1 + VV1) - U2 * (UU2 + VV2) !
|
|
U2 = U1 * (UU2 + VV2) + U2 * (UU1 + VV1) !
|
|
U1 = B !
|
|
VV1 = VV1 + V1 !
|
|
VV2 = VV2 + V2 !
|
|
END DO !
|
|
END IF !
|
|
IF(N >= 2) THEN !
|
|
!
|
|
! *** Backward assembly of factors 1-J/(Z+N)
|
|
!
|
|
VV1 = V1 !
|
|
VV2 = V2 !
|
|
DO J = 2,N !
|
|
VV1 = VV1 + V1 !
|
|
VV2 = VV2 + V2 !
|
|
B = U1 * (ONE - VV1) + U2 * VV2 !
|
|
U2 = - U1 * VV2 + U2 * (ONE - VV1) !
|
|
U1 = B !
|
|
END DO !
|
|
END IF !
|
|
U = U1 * U1 + U2 * U2 !
|
|
IF(U == ZERO) GO TO 500 !
|
|
IF(MODE /= 0) THEN !
|
|
IF(K <= 0) GO TO 200 !
|
|
END IF !
|
|
AL1 = LOG(U) * HALF !
|
|
IF(MODE == 0) THEN !
|
|
W1 = AL1 !
|
|
W2 = ATAN2(U2,U1) !
|
|
IF(W2 < ZERO) W2 = W2 + TWOPI !
|
|
IF(K <= 0) GO TO 200 !
|
|
END IF !
|
|
A = ZZ1 + Z2 - DELTA !
|
|
IF(A <= ZERO) GO TO 500 !
|
|
DE0 = DE0 - AL1 !
|
|
DE1 = DE1 + TWO + ONE / A !
|
|
!
|
|
! *** CAse when real part of ARG is greater than threshold
|
|
!
|
|
200 A = Z1 * Z1 + Z2 * Z2 !
|
|
AL1 = LOG(A) * HALF !
|
|
AL2 = ATAN2(Z2,Z1) !
|
|
V1 = Y1 * AL1 - Z2 * AL2 !
|
|
V2 = Y1 * AL2 + Z2 * AL1 !
|
|
!
|
|
! *** Evaluate asymptotic terms. Ignore this term,
|
|
! if ABS(ARG)**2 .GT. REPS3, to save time and
|
|
! to avoid irrelevant underflow.
|
|
!
|
|
VV1 = ZERO !
|
|
VV2 = ZERO !
|
|
IF(A > REPS3) GO TO 220 !
|
|
UU1 = Z1 / A !
|
|
UU2 = - Z2 / A !
|
|
UUU1 = UU1 * UU1 - UU2 * UU2 !
|
|
UUU2 = UU1 * UU2 * TWO !
|
|
VV1 = COEF(1) !
|
|
DO J = 2,7 !
|
|
B = VV1 * UUU1 - VV2 * UUU2 !
|
|
VV2 = VV1 * UUU2 + VV2 * UUU1 !
|
|
VV1 = B + COEF(J) !
|
|
END DO !
|
|
B = VV1 * UU1 - VV2 * UU2 !
|
|
VV2 = VV1 * UU2 + VV2 * UU1 !
|
|
VV1 = B !
|
|
220 W1 = (((VV1 + HL2P) - W1) - Z1) + V1 !
|
|
W2 = ((VV2 - W2) - Z2) + V2 !
|
|
DE0 = DE0 + ABS(V1) + ABS(V2) !
|
|
IF (K <= 0) DE1 = DE1 + AL1 !
|
|
!
|
|
! Final assembly
|
|
!
|
|
IF(LF2 == 0) THEN !
|
|
IF(MODE /= 0) THEN !
|
|
IF(W1 > ELIMIT) GO TO 550 !
|
|
A = EXP(W1) !
|
|
W1 = A * COS(W2) !
|
|
W2 = A * SIN(W2) !
|
|
IF(LF3 /= 0) THEN !
|
|
B = (W1 * U1 + W2 * U2) / U !
|
|
W2 = (W2 * U1 - W1 * U2) / U !
|
|
W1 = B !
|
|
END IF !
|
|
END IF !
|
|
GO TO 400 !
|
|
END IF
|
|
H = H1 * H1 + H2 * H2 !
|
|
IF(H == ZERO) GO TO 500 !
|
|
IF(MODE == 0 .OR. H <= 1.0E-2_WP) THEN !
|
|
A = LOG(H) * HALF !
|
|
IF(H <= 1.0E-2_WP) DE0 = DE0 - A !
|
|
IF(MODE == 0) THEN !
|
|
W1 = (T1 - A) - W1 !
|
|
W2 = (T2 - ATAN2(H2,H1)) - W2 !
|
|
GO TO 400 !
|
|
END IF !
|
|
END IF !
|
|
!
|
|
! Here we have MODE .ne. 0 and LF2 .ne. 0.
|
|
!
|
|
T1 = T1 - W1 !
|
|
T2 = T2 - W2 !
|
|
IF(T1 > ELIMIT) GO TO 550 !
|
|
A = EXP(T1) !
|
|
T1 = A * COS(T2) !
|
|
T2 = A * SIN(T2) !
|
|
W1 = (T1 * H1 + T2 * H2) / H !
|
|
W2 = (T2 * H1 - T1 * H2) / H !
|
|
IF(LF3 /= 0) THEN !
|
|
B = W1 * U1 - W2 * U2 !
|
|
W2 = W1 * U2 + W2 * U1 !
|
|
W1 = B !
|
|
END IF !
|
|
400 CONTINUE !
|
|
IF(LF1 /= 0) W2 = -W2 !
|
|
!
|
|
! *** Truncation errest of Stirlings formula is up to EPS3.
|
|
!
|
|
DE1 = DE0 * EPS4 + EPS3 + DE1 * DELTA !
|
|
|
|
!
|
|
! Normal termination.
|
|
!
|
|
! The imaginary part of the log of a complex number is nonunique
|
|
! to within multiples of 2*Pi. We prefer a result for loggamma
|
|
! having its imaginary part .gt. -Pi and .le. +Pi. The result at
|
|
! this point is usually in this range. If not we will move it
|
|
! into this range. -- CLL 11/11/91
|
|
!
|
|
IF(MODE == 0) THEN !
|
|
IF(W2 <= -PI .OR. W2 > PI) THEN !
|
|
W3 = ABS(W2) !
|
|
T1 = W3 /PI + ONE !
|
|
IF(ABS(T1) > BIGINT) THEN !
|
|
CALL DERM1('ZGAM',4,0,'Argument out of range.', & !
|
|
'CARG(1)',CARG(1),',') !
|
|
CALL DERV1('CARG(2)',CARG(2),'.') !
|
|
GO TO 700 !
|
|
END IF !
|
|
T2 = INT(T1) / 2 !
|
|
W3 = W3 - T2 * TWOPI !
|
|
IF(W2 >= ZERO) THEN !
|
|
W2 = W3 !
|
|
ELSE !
|
|
W2 = - W3 !
|
|
END IF !
|
|
IF(W2 <= -PI) THEN !
|
|
W2 = W2 + TWOPI !
|
|
ELSE IF(W2 > PI) THEN !
|
|
W2 = W2 - TWOPI !
|
|
END IF !
|
|
END IF !
|
|
END IF !
|
|
CANS(1) = W1 !
|
|
CANS(2) = W2 !
|
|
ERREST = DE1 !
|
|
RETURN !
|
|
!
|
|
! Error termination.
|
|
!
|
|
! *** Case when argument is too close to a singularity
|
|
!
|
|
500 CONTINUE !
|
|
CALL DERM1('ZGAM',1,0,'Z TOO CLOSE TO A SINGULARITY', & !
|
|
'Z(1)',CARG(1),',') !
|
|
CALL DERV1('Z(2)',CARG(2),'.') !
|
|
GO TO 700 !
|
|
!
|
|
550 CONTINUE !
|
|
CALL DERM1('ZGAM',2,0,'ARG TOO LARGE. EXP FUNCTION OVERFLOW',&!
|
|
'Z(1)',CARG(1),',') !
|
|
CALL DERV1('Z(2)',CARG(2),'.') !
|
|
700 CONTINUE !
|
|
CANS(1) = OMEGA !
|
|
CANS(2) = OMEGA !
|
|
ERREST = OMEGA !
|
|
!
|
|
RETURN !
|
|
!
|
|
END SUBROUTINE ZGAM
|
|
!
|
|
END MODULE GAMMA_FUNCTION
|