! !======================================================================= ! MODULE CONFLUENT_HYPGEOM_REAL ! ! This module provides several subroutines to compute ! the Gauss hypergeometric function ! ! 2F1(a,b,c;x) ! ! ! --> <-- ! --> x real <-- ! --> <-- ! ! ! ! 1) SUBROUTINE HYGFX(A,B,C,X,HF) ! ! 2) SUBROUTINE HYP(Z,A,B,C,RE,IM) ! ! ! USE ACCURACY_REAL ! CONTAINS ! !======================================================================= ! SUBROUTINE HYGFX(A,B,C,X,HF) ! ! HYGFX computes the hypergeometric function F(a,b,c,x). ! ! 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: ! ! 04 April 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 hypergeometric function F(a,b,c,x) ! ! Input : A --- Parameter ! B --- Parameter ! C --- Parameter, C <> 0,-1,-2,... ! X --- Argument (X < 1) ! ! Output: HF --- F(A,B,C,X) ! ! Routines called: ! (1) GAMMA for computing gamma function ! (2) PSI for computing psi function ! ! ========================================================== ! ! ! Last modified (DS) : 1 Sep 2020 ! ! USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,HALF USE PI_ETC, ONLY : PI USE GAMMA_FUNCTION, ONLY : GAMMA USE DIGAMMA_FUNCTION, ONLY : PSI ! IMPLICIT NONE ! INTEGER :: J,K,M,NM ! REAL (WP), INTENT(IN) :: C REAL (WP) :: A,B,X REAL (WP), INTENT(OUT) :: HF ! REAL (WP) :: C0 REAL (WP) :: EPS REAL (WP) :: G0,G1,G2,G3 REAL (WP) :: GC,R REAL (WP) :: A0,AA,BB,C1 REAL (WP) :: F0,F1 REAL (WP) :: GA,GABC,GAM,GB,GBM,GCA,GCAB,GCB,GM REAL (WP) :: HW REAL (WP) :: PA,PB,R1,RM,RP REAL (WP) :: SM,SP,SP0 REAL (WP) :: R0,X1 ! REAL, PARAMETER :: EL = 0.5772156649015329E+00_WP ! LOGICAL :: L0,L1,L2,L3,L4,L5 ! L0 = C == INT(C) .AND. C < ZERO ! L1 = ONE - X < 1.0E-15_WP .AND. C - A - B <= ZERO ! L2 = A == INT(A) .AND. A < ZERO ! L3 = B == INT(B) .AND. B < ZERO ! L4 = C - A == INT(C - A) .AND. C - A <= ZERO ! L5 = C - B == INT(C - B) .AND. C - B <= ZERO ! ! IF(L0 .OR. L1) THEN ! WRITE(6,110) ! WRITE(6,111) ! WRITE(6,112) ! STOP ! END IF ! ! IF(0.95E+00_WP < X) THEN ! EPS = 1.0E-08_WP ! ELSE ! EPS = 1.0E-15_WP ! END IF ! ! IF(X == ZERO .OR. A == ZERO .OR. B == ZERO) THEN ! HF = ONE ! RETURN ! ELSE IF(ONE - X == EPS .AND. ZERO < C - A - B) THEN ! CALL GAMMA(C, GC) ! CALL GAMMA(C - A - B, GCAB) ! CALL GAMMA(C - A, GCA) ! CALL GAMMA(C - B, GCB) ! HF = GC * GCAB / (GCA * GCB) ! RETURN ! ELSE IF(ONE + X <= EPS .AND. & ! DABS(C - A + B -ONE) <= EPS) THEN ! G0 = DSQRT(PI) * TWO ** (- A) ! CALL GAMMA(C, G1) ! CALL GAMMA(ONE + A / TWO - B, G2) ! CALL GAMMA(HALF + HALF * A, G3) ! HF = G0 * G1 / (G2 * G3) ! RETURN ! ELSE IF(L2 .OR. L3) THEN ! IF(L2) THEN ! NM = INT(DABS(A)) ! END IF ! IF(L3) THEN ! NM = INT(DABS(B)) ! END IF ! HF = ONE ! R = ONE ! DO K = 1, NM ! R = R * (A + K - ONE) * (B + K - ONE) / & ! (K * (C + K - ONE)) * X ! HF = HF + R ! END DO ! RETURN ! ELSE IF(L4 .OR. L5) THEN ! IF(L4) THEN ! NM = INT(DABS(C - A)) ! END IF ! IF(L5) THEN ! NM = INT(DABS(C - B)) ! END IF ! HF = ONE ! R = ONE ! DO K = 1, NM ! R = R * (C - A + K - ONE) * (C - B + K - ONE) / & ! (K * (C + K - ONE)) * X ! HF = HF + R ! END DO ! HF = (ONE - X) ** (C - A - B) * HF ! RETURN ! END IF ! ! AA = A ! BB = B ! X1 = X ! ! IF(X < ZERO) THEN ! X = X / (X - ONE) ! IF(A < C .AND. B < A .AND. ZERO < B) THEN ! A = BB ! B = AA ! END IF ! B = C - B ! END IF ! ! IF(0.75E+00_WP <= X) THEN ! GM = ZERO ! IF(DABS(C - A - B - INT(C - A - B)) < 1.0E-15_WP) THEN ! M = INT(C - A - B) ! CALL GAMMA(A, GA) ! CALL GAMMA(B, GB) ! CALL GAMMA(C, GC) ! CALL GAMMA(A + M, GAM) ! CALL GAMMA(B + M, GBM) ! CALL PSI(A, PA) ! CALL PSI(B, PB) ! IF(M .NE. 0) THEN ! GM = ONE ! END IF ! DO J = 1, ABS (M) - 1 ! GM = GM * J ! END DO ! RM = ONE ! DO J = 1, ABS (M) ! RM = RM * J ! END DO ! F0 = ONE ! R0 = ONE ! R1 = ONE ! SP0 = ZERO ! SP = ZERO ! IF(0 <= M) THEN ! C0 = GM * GC / (GAM * GBM) ! C1 = - GC * (X - ONE) ** M / (GA * GB * RM) ! DO K = 1, M - 1 ! R0 = R0 * (A + K - ONE) * (B + K - ONE) / & ! (K * (K - M)) * (ONE - X) ! F0 = F0 + R0 ! END DO ! ! DO K = 1, M ! SP0 = SP0 + ONE / (A + K - ONE) + & ! ONE / (B + K - ONE) - ONE / K ! END DO ! ! F1 = PA + PB + SP0 + TWO * EL + DLOG(ONE - X) ! ! DO K = 1, 250 ! SP = SP + (ONE - A) / (K * (A + K - ONE)) + & ! (ONE - B) / (K * (B + K - ONE)) ! SM = ZERO ! DO J = 1,M ! SM = SM + (ONE - A) / ((J + K) * & ! (A + J + K - ONE)) + ONE / & ! (B + J + K - ONE) ! END DO ! RP = PA + PB + TWO * EL + SP + SM + DLOG(ONE - X) ! R1 = R1 * (A + M + K - ONE) * (B + M + K - ONE) / & ! (K * (M + K)) * (ONE - X) ! F1 = F1 + R1 * RP ! IF(DABS(F1 - HW) < DABS(F1) * EPS) THEN ! GO TO 10 ! END IF ! HW = F1 ! END DO ! ! 10 CONTINUE ! HF = F0 *C0 + F1 * C1 ! ! ELSE IF(M < 0) THEN ! ! M = - M ! C0 = GM * GC / (GA * GB * (ONE - X)**M) ! C1 = - (-1)**M * GC / (GAM * GBM * RM) ! ! DO K = 1,M-1 ! R0 = R0 * (A - M + K - ONE) * & ! (B - M + K - ONE) / & ! (K * (K - M)) * (ONE - X) ! F0 = F0 + R0 ! END DO ! ! DO K = 1,M ! SP0 = SP0 + ONE / K ! END DO ! F1 = PA + PB - SP0 + TWO * EL + DLOG(ONE - X) ! DO K = 1,250 ! SP = SP + (ONE - A) / (K * (A + K - ONE)) + & ! (ONE - B) / (K * (B + K - ONE)) ! SM = ZERO ! DO J = 1,M ! SM = SM+ ONE /(J + K) ! END DO ! RP = PA + PB + TWO * EL + SP - SM + & ! DLOG(ONE - X) ! R1 = R1 * (A + K - ONE) * (B + K - ONE) / & ! (K * (M + K)) * (ONE - X) ! F1 = F1 + R1 * RP ! IF(DABS(F1 - HW) < DABS(F1) * EPS) THEN ! GO TO 20 ! END IF ! HW = F1 ! END DO ! ! 20 CONTINUE ! ! HF = F0 * C0 + F1 * C1 ! END IF ! ELSE ! CALL GAMMA(A,GA) ! CALL GAMMA(B,GB) ! CALL GAMMA(C,GC) ! CALL GAMMA(C-A,GCA) ! CALL GAMMA(C-B,GCB) ! CALL GAMMA(C-A-B,GCAB) ! CALL GAMMA(A+B-C,GABC) ! C0 = GC * GCAB / (GCA * GCB) ! C1 = GC * GABC / (GA * GB) * (ONE - X)**(C - A - B) ! HF = ZERO ! R0 = C0 ! R1 = C1 ! DO K = 1,250 ! R0 = R0 * (A + K - ONE) * (B + K - ONE) / & ! (K * (A + B - C + K)) * (ONE - X) ! R1 = R1 * (C - A + K - ONE) * (C - B + K - ONE) /& ! (K * (C - A - B + K)) * (ONE - X) ! HF = HF + R0 + R1 ! IF(DABS(HF - HW) < DABS(HF) * EPS) THEN ! GO TO 30 ! END IF ! HW = HF ! END DO ! ! 30 CONTINUE ! ! HF = HF + C0 + C1 ! ! END IF ! ELSE ! A0 = ONE ! IF(C > A .AND. C < TWO * A .AND. & ! C > B .AND. C < TWO*B) THEN ! A0 = (ONE - X) ** (C - A - B) ! A = C - A ! B = C - B ! END IF ! HF = ONE ! R = ONE ! DO K = 1,250 ! R = R *(A + K - ONE) * (B + K - ONE) / & ! (K * (C + K - ONE)) * X ! HF = HF + R ! IF(DABS(HF - HW) <= DABS(HF) * EPS) THEN ! GO TO 40 ! END IF ! HW = HF ! END DO ! ! 40 CONTINUE ! ! HF = A0 * HF ! ! END IF ! ! IF(X1 < ZERO) THEN ! X = X1 ! C0 = ONE / (ONE - X) ** AA ! HF = C0 * HF ! END IF ! A = AA ! B = BB ! ! IF(120 < K) THEN ! WRITE(*,115) ! END IF ! ! ! Formats: ! 110 FORMAT(' ') 111 FORMAT('HYGFX - Fatal error!') 112 FORMAT('The hypergeometric series is divergent.') 115 FORMAT('Warning! You should check the accuracy') ! RETURN ! ! END SUBROUTINE HYGFX ! END MODULE CONFLUENT_HYPGEOM_REAL