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