! !======================================================================= ! 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