145 lines
5.1 KiB
Fortran
145 lines
5.1 KiB
Fortran
|
!
|
||
|
|
!=======================================================================
|
||
|
|
!
|
||
|
|
MODULE DIGAMMA_FUNCTION
|
||
|
|
!
|
||
|
|
! This module provides different subroutine/functions
|
||
|
|
! to compute the Digamma function, namely:
|
||
|
|
!
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! 3) SUBROUTINE PSI(X,PS) <-- x real
|
||
|
|
!
|
||
|
|
!
|
||
|
|
USE ACCURACY_REAL
|
||
|
|
!
|
||
|
|
CONTAINS
|
||
|
|
!
|
||
|
|
!=======================================================================
|
||
|
|
!
|
||
|
|
SUBROUTINE PSI(X,PS)
|
||
|
|
!
|
||
|
|
!*********************************************************************72
|
||
|
|
!
|
||
|
|
! PSI computes the Psi 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:
|
||
|
|
!
|
||
|
|
! 22 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 Psi function
|
||
|
|
!
|
||
|
|
! Input : X --- Argument of psi(x)
|
||
|
|
!
|
||
|
|
! Output: PS --- psi(x)
|
||
|
|
!
|
||
|
|
! ============================================
|
||
|
|
!
|
||
|
|
!
|
||
|
|
! Last modified (DS) : 1 Sep 2020
|
||
|
|
!
|
||
|
|
!
|
||
|
|
USE REAL_NUMBERS, ONLY : ZERO,ONE,TWO,TEN, &
|
||
|
|
HALF,INF
|
||
|
|
USE PI_ETC, ONLY : PI
|
||
|
|
!
|
||
|
|
IMPLICIT NONE
|
||
|
|
!
|
||
|
|
INTEGER :: K,N
|
||
|
|
!
|
||
|
|
REAL (WP), INTENT(IN) :: X
|
||
|
|
!
|
||
|
|
REAL (WP), INTENT(OUT) :: PS
|
||
|
|
!
|
||
|
|
REAL (WP) :: A1,A2,A3,A4,A5,A6,A7,A8
|
||
|
|
REAL (WP) :: S,X2,XA
|
||
|
|
!
|
||
|
|
REAL (WP), PARAMETER :: EL = 0.5772156649015329E+00_WP
|
||
|
|
!
|
||
|
|
XA = DABS(X) !
|
||
|
|
S = ZERO !
|
||
|
|
!
|
||
|
|
IF(X == INT(X) .AND. X <= ZERO) THEN !
|
||
|
|
!
|
||
|
|
PS = INF !
|
||
|
|
RETURN !
|
||
|
|
!
|
||
|
|
ELSE IF(XA == INT(XA)) THEN !
|
||
|
|
!
|
||
|
|
N = INT(XA) !
|
||
|
|
DO K = 1, N - 1 !
|
||
|
|
S = S + ONE / K !
|
||
|
|
END DO !
|
||
|
|
PS = - EL + S !
|
||
|
|
!
|
||
|
|
ELSE IF(XA + HALF == INT(XA + HALF)) THEN !
|
||
|
|
!
|
||
|
|
N = INT(XA - HALF) !
|
||
|
|
DO K = 1, N !
|
||
|
|
S = S + ONE / (TWO * K - ONE) !
|
||
|
|
END DO
|
||
|
|
PS = - EL + TWO * S - 1.386294361119891E+00_WP !
|
||
|
|
!
|
||
|
|
ELSE !
|
||
|
|
!
|
||
|
|
IF(XA < TEN) THEN !
|
||
|
|
N = 10 - INT(XA) !
|
||
|
|
DO K = 0, N - 1 !
|
||
|
|
S = S + ONE / (XA + K) !
|
||
|
|
END DO !
|
||
|
|
XA = XA + N !
|
||
|
|
END IF !
|
||
|
|
!
|
||
|
|
X2 = ONE / (XA * XA) !
|
||
|
|
A1 = -0.8333333333333E-01_WP !
|
||
|
|
A2 = 0.83333333333333333E-02_WP !
|
||
|
|
A3 = -0.39682539682539683E-02_WP !
|
||
|
|
A4 = 0.41666666666666667E-02_WP !
|
||
|
|
A5 = -0.75757575757575758E-02_WP !
|
||
|
|
A6 = 0.21092796092796093E-01_WP !
|
||
|
|
A7 = -0.83333333333333333E-01_WP !
|
||
|
|
A8 = 0.4432598039215686E+00_WP !
|
||
|
|
!
|
||
|
|
PS = DLOG(XA) - HALF / XA + X2 * ((((((( & !
|
||
|
|
A8 * X2 & !
|
||
|
|
+ A7) * X2 & !
|
||
|
|
+ A6) * X2 & !
|
||
|
|
+ A5) * X2 & !
|
||
|
|
+ A4) * X2 & !
|
||
|
|
+ A3) * X2 & !
|
||
|
|
+ A2) * X2 & !
|
||
|
|
+ A1) !
|
||
|
|
PS = PS - S !
|
||
|
|
!
|
||
|
|
END IF !
|
||
|
|
!
|
||
|
|
IF(X < ZERO) THEN !
|
||
|
|
PS = PS - PI * DCOS(PI * X) / DSIN(PI * X) - ONE / X !
|
||
|
|
END IF !
|
||
|
|
!
|
||
|
|
RETURN !
|
||
|
|
!
|
||
|
|
END SUBROUTINE PSI
|
||
|
|
!
|
||
|
|
END MODULE DIGAMMA_FUNCTION
|