!> \file mo_functions.f90

!> \brief Special functions such as gamma function.

!> \details This module provides special functions such as the gamma function.

!> \authors Matthias Cuntz
!> \date May 2014
MODULE mo_functions

  ! Provide special functions.

  ! Written  Matthias Cuntz, May 2014
  ! Modified Matthias Cuntz, Dec 2017 - morris
  !          Stephan Thober, Aug 2020 - added beta function

  ! License
  ! -------
  ! This file is part of the JAMS Fortran package, distributed under the MIT License.
  !
  ! Copyright (c) 2014-2017 Matthias Cuntz - mc (at) macu (dot) de
  !
  ! Permission is hereby granted, free of charge, to any person obtaining a copy
  ! of this software and associated documentation files (the "Software"), to deal
  ! in the Software without restriction, including without limitation the rights
  ! to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
  ! copies of the Software, and to permit persons to whom the Software is
  ! furnished to do so, subject to the following conditions:
  !
  ! The above copyright notice and this permission notice shall be included in all
  ! copies or substantial portions of the Software.
  !
  ! THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  ! IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  ! FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  ! AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  ! LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  ! OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  ! SOFTWARE.

  USE mo_kind, ONLY: i4, i8, sp, dp

  IMPLICIT NONE

  PUBLIC :: factln    ! ln(n!)
  PUBLIC :: factorial ! n!
  PUBLIC :: gammln    ! ln(gamma)
  PUBLIC :: gamm      ! gamm
  PUBLIC :: morris    ! elementary effects test function after Morris (1991)
  PUBLIC :: beta      ! beta function

  ! ------------------------------------------------------------------
  !
  !     NAME
  !         factln
  !
  !     PURPOSE
  !         Logarithm of factorial.
  !
  !>        \brief \f$ \ln(n!) \f$.
  !
  !>        \details Elemental function of the logarithm of the factorial:
  !>        \f[ \ln(n!) \f]
  !>        with
  !>        \f[ n! = 1 \dot 2 \dot ... \dot n \f]
  !>
  !>         Uses n! = \f$ \Gamma(n+1) \f$.
  !
  !     INTENT(IN)
  !>        \param[in] "integer(i4/i8) :: n"        input
  !
  !     INTENT(INOUT)
  !         None
  !
  !     INTENT(OUT)
  !         None
  !
  !     INTENT(IN), OPTIONAL
  !         None
  !
  !     INTENT(INOUT), OPTIONAL
  !         None
  !
  !     INTENT(OUT), OPTIONAL
  !         None
  !
  !     RETURNS
  !>       \return     real(dp) :: factln — \f$ \ln(n!) \f$
  !
  !     RESTRICTIONS
  !>       \note return is always double precision.
  !
  !     EXAMPLE
  !         fac = exp(factln(5))
  !         fac -> 120
  !         -> see also example in test directory
  !
  !     HISTORY
  !>        \author Matthias Cuntz
  !>        \date May 2014
  INTERFACE factln
     MODULE PROCEDURE factln_i4, factln_i8
  END INTERFACE factln

  ! ------------------------------------------------------------------
  !
  !     NAME
  !         factorial
  !
  !     PURPOSE
  !         Factorial.
  !
  !>        \brief \f$ n! \f$.
  !
  !>        \details Elemental function of the factorial:
  !>        \f[ n! = 1 \dot 2 \dot ... \dot n \f]
  !>
  !>         Uses n! = \f$ \Gamma(n+1) \f$.
  !
  !     INTENT(IN)
  !>        \param[in] "integer(i4/i8) :: n"        input
  !
  !     INTENT(INOUT)
  !         None
  !
  !     INTENT(OUT)
  !         None
  !
  !     INTENT(IN), OPTIONAL
  !         None
  !
  !     INTENT(INOUT), OPTIONAL
  !         None
  !
  !     INTENT(OUT), OPTIONAL
  !         None
  !
  !     RETURNS
  !>       \return     real(dp) :: factln — \f$ \ln(n!) \f$
  !
  !     RESTRICTIONS
  !>       \note return is always double precision.
  !
  !     EXAMPLE
  !         fac = factorial(5)
  !         fac -> 120
  !         -> see also example in test directory
  !
  !     HISTORY
  !>        \author Matthias Cuntz
  !>        \date Feb 2013
  ! ------------------------------------------------------------------
  INTERFACE factorial
     MODULE PROCEDURE factorial_i4, factorial_i8
  END INTERFACE factorial

  ! ------------------------------------------------------------------
  !
  !     NAME
  !         gamm
  !
  !     PURPOSE
  !         The gamma function.
  !
  !>        \brief \f$ \Gamma(z) \f$.
  !
  !>        \details Elemental function of the gamma function:
  !>        \f[ \Gamma = \Int_0^\Inf t^{z-1} e^{-t} dt \f]
  !>
  !>         Uses Lanczos-type approximation to ln(gamma) for z > 0.
  !>         The function calculates gamma from abs(z).
  !>         Accuracy: About 14 significant digits except for small regions in the vicinity of 1 and 2.
  !
  !
  !     INTENT(IN)
  !>        \param[in] "real(sp/dp) :: z"        input
  !
  !     INTENT(INOUT)
  !         None
  !
  !     INTENT(OUT)
  !         None
  !
  !     INTENT(IN), OPTIONAL
  !         None
  !
  !     INTENT(INOUT), OPTIONAL
  !         None
  !
  !     INTENT(OUT), OPTIONAL
  !         None
  !
  !     RETURNS
  !>       \return     real(sp/dp) :: gamm — \f$ \Gamma(z) \f$
  !
  !     RESTRICTIONS
  !>       \note z must be >0. gammln is calculated from abs(z).
  !
  !     EXAMPLE
  !         vec = (/ 1., 2, 3., -9., 5., 6. /)
  !         gl  = gamm(vec)
  !         -> see also example in test directory
  !
  !     LITERATURE
  !         Lanczos, C. ''A precision approximation of the gamma function'', J. SIAM Numer. Anal., B, 1, 86-96, 1964.
  !
  !     HISTORY
  !>        \author Alan Miller, 1 Creswick Street, Brighton, Vic. 3187, Australia, e-mail: amiller @ bigpond.net.au
  !>        \date Oct 1996
  !         Modified, Matthias Cuntz, May 2014
  INTERFACE gamm
     MODULE PROCEDURE gamm_sp, gamm_dp
  END INTERFACE gamm

  ! ------------------------------------------------------------------
  !
  !     NAME
  !         gammln
  !
  !     PURPOSE
  !         Logarithm of the gamma function.
  !
  !>        \brief \f$ \ln(\Gamma(z)) \f$.
  !
  !>        \details Elemental function of the logarithm of the gamma function:
  !>        \f[ \Gamma = \Int_0^\Inf t^{z-1} e^{-t} dt \f]
  !>
  !>         Uses Lanczos-type approximation to ln(gamma) for z > 0.
  !>         The function calculates ln(gamma) from abs(z).
  !>         Accuracy: About 14 significant digits except for small regions in the vicinity of 1 and 2.
  !
  !
  !     INTENT(IN)
  !>        \param[in] "real(sp/dp) :: z"        input
  !
  !     INTENT(INOUT)
  !         None
  !
  !     INTENT(OUT)
  !         None
  !
  !     INTENT(IN), OPTIONAL
  !         None
  !
  !     INTENT(INOUT), OPTIONAL
  !         None
  !
  !     INTENT(OUT), OPTIONAL
  !         None
  !
  !     RETURNS
  !>       \return     real(sp/dp) :: gammln — \f$ \ln\Gamma(z) \f$
  !
  !     RESTRICTIONS
  !>       \note z must be >0. gammln is calculated from abs(z).
  !
  !     EXAMPLE
  !         vec = (/ 1., 2, 3., -9., 5., 6. /)
  !         gl  = gammln(vec)
  !         -> see also example in test directory
  !
  !     LITERATURE
  !         Lanczos, C. ''A precision approximation of the gamma function'', J. SIAM Numer. Anal., B, 1, 86-96, 1964.
  !
  !     HISTORY
  !>        \author Alan Miller, 1 Creswick Street, Brighton, Vic. 3187, Australia, e-mail: amiller @ bigpond.net.au
  !>        \date Oct 1996
  !         Modified, Matthias Cuntz, May 2014
  INTERFACE gammln
     MODULE PROCEDURE gammln_sp, gammln_dp
  END INTERFACE gammln

  ! ------------------------------------------------------------------
  !
  !     NAME
  !         morris
  !
  !     PURPOSE
  !>        \details 20-dimension test function for elementary effects after Morris (1991).
  !
  !     INTENT(IN)
  !>        \param[in] "real(sp/dp), dimension(20[,npoints]) :: x"        number of points
  !>        \param[in] "real(sp/dp)                          :: beta0"    parameters
  !>        \param[in] "real(sp/dp), dimension(20)           :: beta1"    parameters
  !>        \param[in] "real(sp/dp), dimension(20,20)        :: beta2"    parameters
  !>        \param[in] "real(sp/dp), dimension(20,20,20)     :: beta3"    parameters
  !>        \param[in] "real(sp/dp), dimension(20,20,20,20)  :: beta4"    parameters
  !
  !     INTENT(INOUT)
  !         None
  !
  !     INTENT(OUT)
  !         None
  !
  !     INTENT(IN), OPTIONAL
  !         None
  !
  !     INTENT(INOUT), OPTIONAL
  !         None
  !
  !     INTENT(OUT), OPTIONAL
  !         None
  !
  !     RETURNS
  !>       \return     real(sp/dp)[, dimension(npoints)] :: morris — result of Morris function
  !
  !     RESTRICTIONS
  !         None
  !
  !     EXAMPLE
  !         -> see example in test directory
  !
  !     LITERATURE
  !         Morris (1991), Factorial sampling plans for preliminary computational experiments,
  !         Technometrics 33, 161-174.
  !
  !     HISTORY
  !>        \author Matthias Cuntz, Juliane Mai, Mar 2015 in Python
  !>        \date Mar 2015
  !         Modified, Matthias Cuntz, Dec 2017 - ported to Fortran
  INTERFACE morris
     MODULE PROCEDURE morris_0d_dp, morris_1d_dp, &
          morris_0d_sp, morris_1d_sp
  END INTERFACE morris

  ! ------------------------------------------------------------------
  !
  !     NAME
  !         beta
  !
  !     PURPOSE
  !>        \details calculates beta function
  !
  !     INTENT(IN)
  !>        \param[in] "real(sp/dp)                          :: alpha"    parameters
  !>        \param[in] "real(sp/dp)                          :: beta"     parameters
  !
  !     INTENT(INOUT)
  !         None
  !
  !     INTENT(OUT)
  !         None
  !
  !     INTENT(IN), OPTIONAL
  !         None
  !
  !     INTENT(INOUT), OPTIONAL
  !         None
  !
  !     INTENT(OUT), OPTIONAL
  !         None
  !
  !     RETURNS
  !>       \return     real(sp/dp)[, dimension(npoints)] :: beta — result of beta function
  !
  !     RESTRICTIONS
  !         None
  !
  !     EXAMPLE
  !         -> see example in test directory
  !
  !     LITERATURE
  !         https://en.wikipedia.org/wiki/Beta_function
  !
  !     HISTORY
  !>        \author Stephan Thober
  !>        \date Aug 2020
  !         Modified
  INTERFACE beta
     MODULE PROCEDURE beta_sp, beta_dp
  END INTERFACE beta

  ! ------------------------------------------------------------------

  PRIVATE

  ! ------------------------------------------------------------------

CONTAINS

  ! ------------------------------------------------------------------

  ELEMENTAL PURE FUNCTION factln_i4(n)

    IMPLICIT NONE

    INTEGER(i4), INTENT(IN) :: n
    REAL(dp)                :: factln_i4

    factln_i4 = gammln(real(n,dp)+1.0_dp)

  end function factln_i4

  ELEMENTAL PURE FUNCTION factln_i8(n)

    IMPLICIT NONE

    INTEGER(i8), INTENT(IN) :: n
    REAL(dp)                :: factln_i8

    factln_i8 = gammln(real(n,dp)+1.0_dp)

  end function factln_i8

  ! ------------------------------------------------------------------

  elemental pure function factorial_i4(n)
    ! Returns the factorial n!
    IMPLICIT NONE

    INTEGER(i4), INTENT(IN) :: n
    INTEGER(i4)             :: factorial_i4

    factorial_i4 = nint(exp(factln(n)),i4)

  end function factorial_i4

  elemental pure function factorial_i8(n)
    ! Returns the factorial n!
    IMPLICIT NONE

    INTEGER(i8), INTENT(IN) :: n
    INTEGER(i8)             :: factorial_i8

    factorial_i8 = nint(exp(factln(n)),i8)

  end function factorial_i8

  ! ------------------------------------------------------------------

  elemental pure function gamm_dp(z)

    IMPLICIT NONE

    REAL(dp), INTENT(IN) :: z
    REAL(dp)             :: gamm_dp

    gamm_dp = exp(gammln(z))

  end function gamm_dp

  elemental pure function gamm_sp(z)

    IMPLICIT NONE

    REAL(sp), INTENT(IN) :: z
    REAL(sp)             :: gamm_sp

    gamm_sp = exp(gammln(z))

  end function gamm_sp

  ! ------------------------------------------------------------------

  ELEMENTAL PURE FUNCTION gammln_dp(z)
    !  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

    IMPLICIT NONE

    REAL(dp), INTENT(IN) :: z
    REAL(dp)             :: gammln_dp

    ! Local variables
    REAL(dp), parameter :: a(9) = (/ 0.9999999999995183_dp, 676.5203681218835_dp, &
         -1259.139216722289_dp, 771.3234287757674_dp, &
         -176.6150291498386_dp, 12.50734324009056_dp, &
         -0.1385710331296526_dp, 0.9934937113930748E-05_dp, &
         0.1659470187408462E-06_dp /)
    REAL(dp), parameter :: zero = 0.0_dp,   &
         one = 1.0_dp, &
         lnsqrt2pi =  0.9189385332046727_dp, &
         half = 0.5_dp, &
         sixpt5 = 6.5_dp, &
         seven = 7.0_dp
    REAL(dp)  :: tmp
    INTEGER   :: j

    ! if (z <= 0.0_dp) stop 'Error gammln_dp: z <= 0'
    gammln_dp = zero
    tmp = abs(z) + seven
    DO j = 9, 2, -1
       gammln_dp = gammln_dp + a(j)/tmp
       tmp = tmp - one
    END DO
    gammln_dp = gammln_dp + a(1)
    gammln_dp = LOG(gammln_dp) + lnsqrt2pi - (abs(z) + sixpt5) + (abs(z) - half)*LOG(abs(z) + sixpt5)

  END FUNCTION gammln_dp

  ELEMENTAL PURE FUNCTION gammln_sp(z)
    !  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

    IMPLICIT NONE

    REAL(sp), INTENT(IN) :: z
    REAL(sp)             :: gammln_sp

    ! Local variables
    REAL(sp), parameter :: a(9) = (/ 0.9999999999995183_sp, 676.5203681218835_sp, &
         -1259.139216722289_sp, 771.3234287757674_sp, &
         -176.6150291498386_sp, 12.50734324009056_sp, &
         -0.1385710331296526_sp, 0.9934937113930748E-05_sp, &
         0.1659470187408462E-06_sp /)
    REAL(sp), parameter :: zero = 0.0_sp,   &
         one = 1.0_sp, &
         lnsqrt2pi =  0.9189385332046727_sp, &
         half = 0.5_sp, &
         sixpt5 = 6.5_sp, &
         seven = 7.0_sp
    REAL(sp)  :: tmp
    INTEGER   :: j

    ! if (z <= 0.0_sp) stop 'Error gammln_sp: z <= 0'
    gammln_sp = zero
    tmp = abs(z) + seven
    DO j = 9, 2, -1
       gammln_sp = gammln_sp + a(j)/tmp
       tmp = tmp - one
    END DO
    gammln_sp = gammln_sp + a(1)
    gammln_sp = LOG(gammln_sp) + lnsqrt2pi - (abs(z) + sixpt5) + (abs(z) - half)*LOG(abs(z) + sixpt5)

  END FUNCTION gammln_sp

  ! ------------------------------------------------------------------

  FUNCTION morris_0d_dp(x, beta0, beta1, beta2, beta3, beta4)

    use mo_kind, only: dp, i4

    implicit none

    real(dp), dimension(20),          intent(in) :: x
    real(dp),                         intent(in) :: beta0
    real(dp), dimension(20),          intent(in) :: beta1
    real(dp), dimension(20,20),       intent(in) :: beta2
    real(dp), dimension(20,20,20),    intent(in) :: beta3
    real(dp), dimension(20,20,20,20), intent(in) :: beta4
    real(dp)                                     :: morris_0d_dp

    ! local
    real(dp),    dimension(20) :: om
    integer(i4), dimension(3) :: ii
    integer(i4) :: i, j, l, s, nn

    om = 2._dp*(x - 0.5_dp)
    ii = (/2, 4, 6/) + 1 ! +1 Python -> Fortran
    om(ii) = 2._dp*(1.1_dp*x(ii)/(x(ii)+0.1_dp) - 0.5_dp)

    nn = size(x)

    morris_0d_dp = beta0
    do i=1, nn
       morris_0d_dp = morris_0d_dp + beta1(i)*om(i)
       do j=i+1, nn
          morris_0d_dp = morris_0d_dp + beta2(i,j)*om(i)*om(j)
          do l=j+1, nn
             morris_0d_dp = morris_0d_dp + beta3(i,j,l)*om(i)*om(j)*om(l)
             do s=l+1, nn
                morris_0d_dp = morris_0d_dp + beta4(i,j,l,s)*om(i)*om(j)*om(l)*om(s)
             end do
          end do
       end do
    end do

  END FUNCTION morris_0d_dp

  FUNCTION morris_1d_dp(x, beta0, beta1, beta2, beta3, beta4)

    use mo_kind, only: dp, i4

    implicit none

    real(dp), dimension(:,:),         intent(in) :: x
    real(dp),                         intent(in) :: beta0
    real(dp), dimension(20),          intent(in) :: beta1
    real(dp), dimension(20,20),       intent(in) :: beta2
    real(dp), dimension(20,20,20),    intent(in) :: beta3
    real(dp), dimension(20,20,20,20), intent(in) :: beta4
    real(dp), dimension(size(x,2))               :: morris_1d_dp

    ! local
    real(dp),    dimension(20,size(x,2)) :: om
    integer(i4), dimension(3)            :: ii
    integer(i4) :: i, j, l, s, nn

    om = 2._dp*(x - 0.5_dp)
    ii = (/2, 4, 6/)
    om(ii,:) = 2._dp*(1.1_dp*x(ii,:)/(x(ii,:)+0.1_dp) - 0.5_dp)

    nn = size(x)

    morris_1d_dp(:) = beta0
    do i=1, nn
       morris_1d_dp(:) = morris_1d_dp(:) + beta1(i)*om(i,:)
       do j=i+1, nn
          morris_1d_dp(:) = morris_1d_dp(:) + beta2(i,j)*om(i,:)*om(j,:)
          do l=j+1, nn
             morris_1d_dp(:) = morris_1d_dp(:) + beta3(i,j,l)*om(i,:)*om(j,:)*om(l,:)
             do s=l+1, nn
                morris_1d_dp(:) = morris_1d_dp(:) + beta4(i,j,l,s)*om(i,:)*om(j,:)*om(l,:)*om(s,:)
             end do
          end do
       end do
    end do

  END FUNCTION morris_1d_dp

  FUNCTION morris_0d_sp(x, beta0, beta1, beta2, beta3, beta4)

    use mo_kind, only: sp, i4

    implicit none

    real(sp), dimension(20),          intent(in) :: x
    real(sp),                         intent(in) :: beta0
    real(sp), dimension(20),          intent(in) :: beta1
    real(sp), dimension(20,20),       intent(in) :: beta2
    real(sp), dimension(20,20,20),    intent(in) :: beta3
    real(sp), dimension(20,20,20,20), intent(in) :: beta4
    real(sp)                                     :: morris_0d_sp

    ! local
    real(sp),    dimension(20) :: om
    integer(i4), dimension(3) :: ii
    integer(i4) :: i, j, l, s, nn

    om = 2._sp*(x - 0.5_sp)
    ii = (/2, 4, 6/)
    om(ii) = 2._sp*(1.1_sp*x(ii)/(x(ii)+0.1_sp) - 0.5_sp)

    nn = size(x)

    morris_0d_sp = beta0
    do i=1, nn
       morris_0d_sp = morris_0d_sp + beta1(i)*om(i)
       do j=i+1, nn
          morris_0d_sp = morris_0d_sp + beta2(i,j)*om(i)*om(j)
          do l=j+1, nn
             morris_0d_sp = morris_0d_sp + beta3(i,j,l)*om(i)*om(j)*om(l)
             do s=l+1, nn
                morris_0d_sp = morris_0d_sp + beta4(i,j,l,s)*om(i)*om(j)*om(l)*om(s)
             end do
          end do
       end do
    end do

  END FUNCTION morris_0d_sp

  FUNCTION morris_1d_sp(x, beta0, beta1, beta2, beta3, beta4)

    use mo_kind, only: sp, i4

    implicit none

    real(sp), dimension(:,:),         intent(in) :: x
    real(sp),                         intent(in) :: beta0
    real(sp), dimension(20),          intent(in) :: beta1
    real(sp), dimension(20,20),       intent(in) :: beta2
    real(sp), dimension(20,20,20),    intent(in) :: beta3
    real(sp), dimension(20,20,20,20), intent(in) :: beta4
    real(sp), dimension(size(x,2))               :: morris_1d_sp

    ! local
    real(sp),    dimension(20,size(x,2)) :: om
    integer(i4), dimension(3)            :: ii
    integer(i4) :: i, j, l, s, nn

    om = 2._sp*(x - 0.5_sp)
    ii = (/2, 4, 6/)
    om(ii,:) = 2._sp*(1.1_sp*x(ii,:)/(x(ii,:)+0.1_sp) - 0.5_sp)

    nn = size(x)

    morris_1d_sp(:) = beta0
    do i=1, nn
       morris_1d_sp(:) = morris_1d_sp(:) + beta1(i)*om(i,:)
       do j=i+1, nn
          morris_1d_sp(:) = morris_1d_sp(:) + beta2(i,j)*om(i,:)*om(j,:)
          do l=j+1, nn
             morris_1d_sp(:) = morris_1d_sp(:) + beta3(i,j,l)*om(i,:)*om(j,:)*om(l,:)
             do s=l+1, nn
                morris_1d_sp(:) = morris_1d_sp(:) + beta4(i,j,l,s)*om(i,:)*om(j,:)*om(l,:)*om(s,:)
             end do
          end do
       end do
    end do

  END FUNCTION morris_1d_sp

  ! ------------------------------------------------------------------

  elemental pure function beta_sp(alpha, beta)

    use mo_kind, only: sp

    real(sp), intent(in) :: alpha
    real(sp), intent(in) :: beta
    real(sp)             :: beta_sp

    beta_sp = (gamm(alpha) * gamm(beta)) / gamm(alpha + beta)

  end function beta_sp

  elemental pure function beta_dp(alpha, beta)

    use mo_kind, only: dp

    real(dp), intent(in) :: alpha
    real(dp), intent(in) :: beta
    real(dp)             :: beta_dp

    beta_dp = (gamm(alpha) * gamm(beta)) / gamm(alpha + beta)

  end function beta_dp

END MODULE mo_functions


      program gather_vector
      include 'mpif.h'
      integer ndims,xmax,ymax,nnodes,myid,totelem
      parameter(ndims=2)
      parameter(xmax=100,ymax=100)
      parameter(niters=10)
      parameter (totelem=xmax*ymax)
      integer comm,ierr
      integer status(MPI_STATUS_SIZE)

      double precision,allocatable,dimension(:,:) :: A,gA
      double precision,allocatable,dimension(:)   :: V,dindex1,dindex2,gV
      integer,allocatable,dimension(:)            :: index1,index2
      integer,allocatable,dimension(:)            :: lindex1,lindex2

!distribute each array into nnodes processors except gV and index1 and index2
! these last 3 arrays are global arrays. gv will hold the all local V's
! index1 and index2 will hold all the local lindex1's and lindex2's
! respectively

      integer xb,yb,i,j,nitems,xbv

      comm=MPI_COMM_WORLD

      call MPI_init(ierr)
      call MPI_COMM_RANK(comm,myid,ierr)
      call MPI_COMM_SIZE(comm,nnodes,ierr)

!initialize the input matrixes A and allocate necessary spaces for A,B
!partition the matrix a in (block ,*) way

      xb  = xmax/nnodes
      xbv = totelem/nnodes
!allocate necessary arrays

      allocate(A(xb,ymax))
      allocate(gA(xmax,ymax))
      allocate(V(xbv))
      allocate(gV(totelem))
      allocate(index1(totelem))
      allocate(index2(totelem))
      allocate(dindex1(totelem))
      allocate(dindex2(totelem))
      allocate(lindex1(xbv))
      allocate(lindex2(xbv))
!last processor is  generating random index vectors index1 and index2
! and partition them onto processors and send to correspoding processor
!also last processor is generating random data vector V for each processor

      if (myid == nnodes -1) then
          call random_number(dindex1)
          call random_number(dindex2)
          index1 = xmax*dindex1 + 1
          index2 = ymax*dindex2 + 1
          do np = 0,nnodes-1
            call random_number(A)
            A = 1000000.0*A
            if (np < nnodes-1) then
              call MPI_SEND(A,xb*ymax,MPI_DOUBLE_PRECISION,np,0,comm,ierr)
              call MPI_SEND(index1(xbv*np+1),xbv,MPI_INTEGER,np,0,comm,ierr)
              call MPI_SEND(index1(xbv*np+1),xbv,MPI_INTEGER,np,0,comm,ierr)
            endif
          enddo
          lindex1 = index1((nnodes-1)*xbv+1:totelem)
          lindex2 = index2((nnodes-1)*xbv+1:totelem)
      else
          call MPI_RECV(A,xb*ymax,MPI_DOUBLE_PRECISION,nnodes-1,0,comm,&
              status,ierr)
          call MPI_RECV(lindex1,xbv,MPI_INTEGER,nnodes-1,0,comm,status,ierr)
          call MPI_RECV(lindex1,xbv,MPI_INTEGER,nnodes-1,0,comm,status,ierr)
      endif

!start timer .....
      time_begin =  MPI_Wtime()
      do iter = 1,niters
!collect all the local A's in gA
        call  all_to_all_float(myid,nnodes,comm,A,gA,xb,xmax,ymax)
!collect all the local arrays index1's and index2's in index1 and index2

        call  all_to_all_int(myid,nnodes,comm,lindex1,index1,xbv,totelem)
        call  all_to_all_int(myid,nnodes,comm,lindex2,index2,xbv,totelem)
        ilb = myid*xbv+1
        iub = (myid+1)*xbv
        do i=1,totelem

!If I am holding the vector index 'i' in my local array
!I will get the gA(index1(i),index2(i))
          if ((i.ge.ilb).and.(i.le.iub)) then
             V(i-ilb+1) = gA(index1(i),index2(i))
          endif
        enddo

      enddo
! Stop timer

      time_end =  MPI_Wtime()

      if (myid == 0) then
        print *,'Elapsed time ',niters,'iterations for scatter'
        print *,'For matrix with dimensions',xmax,ymax ,'is'
        print *,time_end-time_begin ,'seconds'
       endif

      deallocate(a)
      deallocate(v)
      deallocate(gv)
      deallocate(index1)
      deallocate(index2)
      deallocate(lindex1)
      deallocate(lindex2)
      deallocate(dindex1)
      deallocate(dindex2)

      call MPI_FINALIZE(ierr)

      end

    SUBROUTINE all_to_all_float(myid,nnodes,comm,fx,global_fx,xb,xmax,ymax)
    integer xb,xmax,ymax
    integer fx(xb,ymax),global_fx(xmax,ymax)
    integer myid,nnodes,comm

    include 'mpif.h'
    integer dest,source,nproc,dest_id,ierr
    integer status(MPI_STATUS_SIZE)

    global_fx(xb*myid+1:xb*(myid+1),:) = fx
    nproc = nnodes
    kcnt = myid
    dest   = mod(myid+1,nproc)
    source = mod(myid-1+nproc,nproc)

    do i=1,nproc-1
      if (mod (myid,2) .eq. 0) then
         call MPI_SEND(global_fx(kcnt*xb+1:(kcnt+1)*xb,:),xb,&
         MPI_INTEGER,dest,0,comm,ierr)
      else
         ikcnt = mod(kcnt-1+nproc,nproc)
         call MPI_RECV(global_fx(ikcnt*xb+1:(ikcnt+1)*xb,:),xb, &
           MPI_INTEGER,source,0,comm,status,ierr)
      endif

     if (mod (myid,2) .eq. 1) then
        call MPI_SEND(global_fx(kcnt*xb+1:(kcnt+1)*xb,:),xb,&
         MPI_INTEGER,dest,0,comm,ierr)
     else
        ikcnt = mod(kcnt-1+nproc,nproc)
        call MPI_RECV(global_fx(ikcnt*xb+1:(ikcnt+1)*xb,:),xb, &
           MPI_INTEGER,source,0,comm,status,ierr)
     endif
     kcnt = ikcnt
   enddo

   return
   end

    SUBROUTINE all_to_all_int(myprocid,nnodes,comm,fx,global_fx,xbv,totelem)
    integer xbv,totelem
    integer fx(xbv),global_fx(totelem)
    integer myprocid,nnodes,comm

    include 'mpif.h'
    integer dest,source,nproc,dest_id,ierr
    integer status(MPI_STATUS_SIZE)

    do j=1,xbv
      global_fx(xbv*myprocid+1+j) = fx(j)
    enddo

    nproc = nnodes
    kcnt = myprocid
    dest   = mod(myprocid+1,nproc)
    source = mod(myprocid-1+nproc,nproc)

    do i=1,nproc-1
      if (mod (myprocid,2) .eq. 0) then
         call MPI_SEND(global_fx(kcnt*xbv+1),xbv,&
         MPI_INTEGER,dest,0,comm,ierr)
      else
         ikcnt = mod(kcnt-1+nproc,nproc)
         call MPI_RECV(global_fx(ikcnt*xbv+1),xbv, &
           MPI_INTEGER,source,0,comm,status,ierr)
      endif

     if (mod (myprocid,2) .eq. 1) then
        call MPI_SEND(global_fx(kcnt*xbv+1),xbv,&
         MPI_INTEGER,dest,0,comm,ierr)
     else
        ikcnt = mod(kcnt-1+nproc,nproc)
        call MPI_RECV(global_fx(ikcnt*xbv+1),xbv, &
           MPI_INTEGER,source,0,comm,status,ierr)
     endif
     kcnt = ikcnt
   enddo

   return
   end


c	Calculate coefficients for a Chebyshev polynomial that approximates
c	k(T,P). Actually the fitting is for log10(k(T,P)) as a fucntion of
c	log10(P) and 1/T. The fitting is done by direct calculation of the
c	coefficients rather than least-squares fitting. This requires k(T,P)
c	be known at the Gauss-Chebyshev values of T,P (calculated in cdgets.f).
c
c	pey 4/6/04
c
	subroutine chebyshev(iwell,iprod)
c	calculate the chebyshev coefficents and store them in the common array, chebcoeffs

	implicit none
        include 'cdparams.fh'
	include 'cdcheb.fh'
	include 'cdrange.fh'
	include 'cdrates.fh'

	integer iwell, iprod, i, j, m, n
	real*8 amn, factor, phi, logk(mxTPts,mxPPts)
c	end of declarations

c	calculate log10(k) and store
	do i=1,ntemps
		do j=1,npres
			logk(i,j) = log10(RK(iwell,iprod,i,j))
		enddo
	enddo

c	calculate the chebyshev coefficients
	factor = 4.0/(ntemps*npres)

	do i=1,nchebT
		do j=1,nchebP
			amn = 0.0
			do m=1,ntemps
				do n=1,npres
				 amn = amn + logk(m,n)*phi(i,tcheb(m))*phi(j,pcheb(n))
				enddo
			enddo
			chebcoeffs(i,j) = factor*amn
		enddo
	enddo

c	correct factor
	do i=1,nchebT
		chebcoeffs(i,1) = chebcoeffs(i,1)/2.0
	enddo

	do j=1,nchebP
		chebcoeffs(1,j) = chebcoeffs(1,j)/2.0
	enddo

	return
	end
c ***
c ***
c ***
c ***
	real*8 function phi(i,x)
c	calculate the ith order Chebyshev basis function
	implicit none
	real*8 x
	integer i

	phi = cos(float(i-1)*acos(x))

	return
	end