module auxilary_subroutines
implicit none
contains
!
!--------------------------------------------------------
! Combinations:
!-------------------------------------------------------
!
integer(kind=16) function combination_x_of_p(x,p)
implicit none
!
integer(kind=16), intent(in) :: x, p
integer(kind=16) :: diff, aprod, a_fact, i, j, k, a, b, c
integer(kind=16), allocatable, dimension(:) :: prod, x_fact, p_x_fact
integer(kind=16), dimension(13) :: divisors
!
!primes = (/2, 3, 5, 7, 11, 13, 17, 19, 23, 29, 31, 37, 41, 43, 47, 53, &
!   59, 61, 67, 71, 73, 79, 83, 89, 97, 101/)
divisors = (/2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14/)
!
diff = p - x
write(*,*) 'x', x, 'p', p
write(*,*) 'diff', diff
!
!--------------------
! p-x > x :
!--------------------
!
if (diff .ge. x) then
   write(*,*) 'p - x > x'
   !
   !determine the values of the arrays prod and x_fact:
   !
   allocate( prod(x), x_fact(x) )
   !
   do i = 1, x
      prod(i) = diff + i
      !
      x_fact(i) = i
   end do
   !
   !reduce to the smallest common divisor:
   !
   do i = x, 1, -1
      a = prod(i)
      do j = x, 1, -1
         b = x_fact(j)
         do k = 13, 1, -1
            c = divisors(k)
            if (b .ge. c) then
               if (a .ge. c) then
                  if (mod(a,c) == 0) then
                     if (mod(b,c) == 0) then
                        prod(i) = prod(i)/divisors(k)
                        a = prod(i)
                        x_fact(j) = x_fact(j)/divisors(k)
                        b = x_fact(j)
                        write(*,*) 'a, b, c', a, b, c
                        write(*,*) 'mod-a-c', mod(a,c)
                        write(*,*) 'mod-b-c', mod(b,c)
                        write(*,*) 'prod', prod
                        write(*,*) 'x_fact', x_fact
                     end if
                  end if
               end if
            end if
         end do
      end do
   end do
   !
   !determine the number of combinations:
   !
   aprod = 1
   do i = 1, x
      aprod = aprod * prod(i)
      write(*,*) 'prod', prod
   end do
   !
   if (x .ne. 0) then
      a_fact = 1
      do i = 1, x
         a_fact = a_fact * x_fact(i)
      end do
   end if
   if (x .eq. 0) then
      x_fact = 1
   end if
   !
   write(*,*) 'prod', aprod
   write(*,*) 'x_fact', a_fact
   combination_x_of_p = aprod/a_fact
   write(*,*) 'combination x of p', combination_x_of_p
!
!--------------------------
! p-x < x :
!--------------------------
!
else if (diff .lt. x) then
   write(*,*) 'x > p - x'
   !
   !determine the values of the arrays p_x_fact and prod
   !
   allocate( prod(diff), p_x_fact(diff) )
   !
   do i = 1, diff
      prod(i) = x + i
      !
      p_x_fact(i) = i
   end do
   !
   !reduce prod and p_x_fact to the smallest common divisor:
   !
   do i = diff, 1, -1
      a = prod(i)
      do j = diff, 1, -1
         b = p_x_fact(j)
         do k = 13, 1, -1
            c = divisors(k)
            if (b .ge. c) then
               if (a .ge. c) then
                  if (mod(a,c) == 0) then
                     if (mod(b,c) == 0) then
                        prod(i) = prod(i)/divisors(k)
                        a = prod(i)
                        p_x_fact(j) = p_x_fact(j)/divisors(k)
                        b = p_x_fact(j)
                     end if
                  end if
               end if
            end if
         end do
      end do
   end do
   !
   !determine the number of combinations:
   !
   aprod = 1
   do i = 1, diff
      aprod = aprod * prod(i)
   end do
   !
   a_fact = 1
   do i = 1, diff
      a_fact = a_fact * p_x_fact(i)
   end do
   !
   combination_x_of_p = aprod/a_fact
end if
!
!-----------------------------------------------------------------
! example -> x .lt. p-x
!-----------------------------------------------------------------
!
!   p = 8
!   x = 2
!   p - x = 6
!
!   x < p-x
!
!   6! 7 8            p-x+1 p-x+2
! -------------- = --------------------
!   6! 2!               x!
!
!-----------------------------------------------------------------
! example -> x .gt. p=x
!-----------------------------------------------------------------
!
!   p = 8
!   x = 5
!   p - x = 3
!
!   5! 6 7 8        x+1 x+2 x+3
! ------------ = ------------------
!   5! 3!           p - x!
!
!
end function combination_x_of_p
!
!-----------------------------------------------------------------
!Subroutine to generate the distance matrix for a structure:
!-----------------------------------------------------------------
!
subroutine distance_matrix (a_matrix, a_atoms, dist_matrix)
implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)
!
real(dp), allocatable, dimension(:,:), intent(in) :: a_matrix
integer, intent(in) :: a_atoms
real(dp), allocatable, dimension(:,:), intent(out) :: dist_matrix
integer :: i, j
!
allocate(dist_matrix(a_atoms,a_atoms))
do i = 1, a_atoms
  do j = 1, a_atoms
     dist_matrix(i,j) = sqrt( (a_matrix(i,1)-a_matrix(j,1))**(2.) + &
       (a_matrix(i,2)-a_matrix(j,2))**(2.) + &
       (a_matrix(i,3)-a_matrix(j,3))**(2.) )
  end do
end do
!
end subroutine distance_matrix
!
!----------------------------------------------------------------
!Periodic system - read the mass for every atom in the molecule:
!----------------------------------------------------------------
!
subroutine periodic (labels_in, a, masses_out)
Implicit none
integer, parameter :: dp = SELECTED_REAL_KIND(15)
!
character(len=1), allocatable, dimension(:), intent(in) :: labels_in
integer :: a, i, k !number of atoms
real(dp), dimension(2) :: masses
character(len=1), dimension(2) :: atoms
real(dp), allocatable, dimension(:), intent(out) :: masses_out
!
atoms = (/'B', 'V'/)
masses = (/10.81, 50.9415/)
!
allocate ( masses_out(a) )
!
!-----------------------
!Assigning the masses:
!-----------------------
!
do i = 1, a
    do k = 1, 2
        if (labels_in(i) == atoms(k)) then
            masses_out(i) = masses(k)
        end if
    end do
end do
!
end subroutine periodic
!
!---------------------------------------------------------
!Calculate CPU time:
!---------------------------------------------------------
!
subroutine CPU (start, method15)
implicit none
!
integer, parameter :: dp = SELECTED_REAL_KIND(15)
real(dp), intent(in) :: start
character(len=17), intent(in) :: method15
real(dp) :: finish, cputime
!
call CPU_time(finish)
cputime = finish - start
write(25,*)
write(25,'(A18)') method15, ':'
write(25,*) 'CPU time:', cputime
!
end subroutine CPU
!
end module auxilary_subroutines


PROGRAM SELF_SEMQuad_IO

USE SELF_Constants
USE SELF_Lagrange
USE SELF_Mesh
USE SELF_Geometry

  IMPLICIT NONE

  INTEGER, PARAMETER :: N = 7 ! Polynomial degree of solution
  INTEGER, PARAMETER :: quadrature = GAUSS ! Quadrature
  INTEGER, PARAMETER :: M = 15 ! Number of points in the uniform plotting mesh
  INTEGER, PARAMETER :: nXe = 5 ! Number of elements in the x-direction
  INTEGER, PARAMETER :: nYe = 5 ! Number of elements in the x-direction
  INTEGER, PARAMETER :: nvar = 1 ! The number of tracer fields
  REAL(prec), PARAMETER :: Lx = 1.0_prec ! Length of the domain in the x-direction
  REAL(prec), PARAMETER :: Ly = 1.0_prec ! Length of the domain in the x-direction
  REAL(prec), PARAMETER :: tolerance=200.0_prec*epsilon(1.0_prec) ! Error tolerance

  TYPE(Lagrange),TARGET :: interp
  TYPE(Mesh2D),TARGET :: mesh
  TYPE(SEMQuad),TARGET :: geometry
  REAL(prec) :: dxdsExpect(1:2,1:2)
  REAL(prec) :: JExpect
  REAL(prec) :: dxdserror(1:2,1:2)
  REAL(prec) :: Jerror
  INTEGER :: i,j,iSide,row,col,iEl
  LOGICAL :: fail
  CHARACTER(LEN=255) :: SELF_PREFIX

    fail = .FALSE.

    ! Create an interpolant
    CALL interp % Init(N,quadrature,M,UNIFORM)

    ! Create a uniform block mesh
    CALL get_environment_variable("SELF_PREFIX", SELF_PREFIX)
    CALL mesh % Read_HOPr(TRIM(SELF_PREFIX)//"/etc/mesh/Block2D/Block2D_mesh.h5")

    ! Generate geometry (metric terms) from the mesh elements
    CALL geometry % Init(interp,mesh % nElem)
    CALL geometry % GenerateFromMesh(mesh)

    dxdsExpect(1,1) = 0.5_prec*Lx/REAL(nXe,prec)
    dxdsExpect(2,1) = 0.0_prec
    dxdsExpect(1,2) = 0.0_prec
    dxdsExpect(2,2) = 0.5_prec*Ly/REAL(nYe,prec)
    dxdserror = 0.0_prec
    DO iEl = 1, mesh % nElem
      DO j = 0, interp % N
        DO i = 0, interp % N
          DO col = 1, 2
            DO row = 1, 2
              dxdserror(row,col) = MAX(ABS(geometry % dxds % interior % hostData(row,col,i,j,1,iEl)-&
                      dxdsExpect(row,col)),dxdserror(row,col))
            ENDDO
          ENDDO
        ENDDO
      ENDDO
    ENDDO

    1000 FORMAT('Element interior metric term error max(|dxds-exact|) greater than tolerance (',I1,',',I1,'): ',E12.5, ' > ', E12.5)
    DO col = 1, 2
      DO row = 1, 2
        IF( dxdserror(row,col) > tolerance )THEN
          WRITE(*,1000) row, col, dxdserror(row,col), tolerance
          fail=.TRUE.
        ENDIF
      ENDDO
    ENDDO

    dxdserror = 0.0_prec
    DO iEl = 1, mesh % nElem
      DO i = 0, interp % N
        DO col = 1, 2
          DO row = 1, 2
            dxdserror(row,col) = MAX(ABS(geometry % dxds % boundary % hostData(row,col,i,1,1,iEl)-&
                    dxdsExpect(row,col)),dxdserror(row,col))
            dxdserror(row,col) = MAX(ABS(geometry % dxds % boundary % hostData(row,col,i,1,2,iEl)-&
                    dxdsExpect(row,col)),dxdserror(row,col))
            dxdserror(row,col) = MAX(ABS(geometry % dxds % boundary % hostData(row,col,i,1,3,iEl)-&
                    dxdsExpect(row,col)),dxdserror(row,col))
            dxdserror(row,col) = MAX(ABS(geometry % dxds % boundary % hostData(row,col,i,1,4,iEl)-&
                    dxdsExpect(row,col)),dxdserror(row,col))
          ENDDO
        ENDDO
      ENDDO
    ENDDO

    1001 FORMAT('Element boundary metric term error max(|dxds-exact|) greater than tolerance (',I1,',',I1,'): ',E12.5, ' > ', E12.5)
    DO col = 1, 2
      DO row = 1, 2
        IF( dxdserror(row,col) > tolerance )THEN
          WRITE(*,1001) row, col, dxdserror(row,col), tolerance
          fail=.TRUE.
        ENDIF
      ENDDO
    ENDDO

    Jexpect = 0.25_prec*Lx*Ly/REAL(nXe,prec)/REAL(nYe,prec)
    Jerror = 0.0_prec
    DO iEl = 1, mesh % nElem
      DO j = 0, interp % N
        DO i = 0, interp % N
          Jerror = MAX(ABS(geometry % J % interior % hostData(i,j,1,iEl)-&
                      JExpect),Jerror)
        ENDDO
      ENDDO
    ENDDO

    1002 FORMAT('Element interior Jacobian error max(|J-exact|) greater than tolerance : ',E12.5, ' > ', E12.5)
    IF( Jerror > tolerance )THEN
      WRITE(*,1002) Jerror, tolerance
      fail=.TRUE.
    ENDIF

    Jerror = 0.0_prec
    DO iEl = 1, mesh % nElem
      DO iSide = 1,4
        DO i = 0, interp % N
          Jerror = MAX(ABS(geometry % J % boundary % hostData(i,1,iSide,iEl)-&
                      JExpect),Jerror)
        ENDDO
      ENDDO
    ENDDO

    1003 FORMAT('Element boundary Jacobian error max(|J-exact|) greater than tolerance : ',E12.5, ' > ', E12.5)
    IF( Jerror > tolerance )THEN
      WRITE(*,1003) Jerror, tolerance
      fail=.TRUE.
    ENDIF

    CALL geometry % Write()
    CALL geometry % WriteTecplot()

    CALL geometry % Free()
    CALL mesh % Free()
    CALL interp % Free()

    IF( fail )THEN
      STOP 1
    ENDIF

END PROGRAM SELF_SEMQuad_IO


      INCLUDE 'VICMAIN_FOR'
      SUBROUTINE MAIN44

c EXAMPLE # 1
c Purpose: To test the Metropolis algorithm in three dimensions.
c The example below is to fit a circle to 6 data points, two
c of which do not lie on the circle.
c Notice the cost function rewards for including lots of data
c points and is allowed to reject points which fall far from the
c fitted function.
      real*4 range(3),answer(3),array(2,6),array2(1)
      character*80 msg
      external cost
      numten=1000
      limit=3000
      iprint=200
      narg=3
      norm=330
      npts=6
c sample,line pairs...
      data array/10.,50.,30.,50.,10.,70.,30.,70.,80.,30.,80.,40./
c (1)=radius (2)=x_center (3)=y_center
      data answer/30.,60.,50./
      data range/15.,20.,20./
      call xvmessage('Fortran test case 1',' ')

      call metropolis(cost,narg,array,array2,range,numten,answer,
     +                 limit,norm,npts,iprint,ind)
      if(ind.eq.0)then
         write(msg,*)'answer=',(answer(j),j=1,narg)
         call xvmessage(msg,' ')
      else
         call xvmessage('no solution',' ')
      endif
      call xvmessage('solution should be about 14.1 20. 60.',' ')
      call xvmessage(' ',' ')
C
C     The "C" is not portable on all machines and therefore the
C     following:' CALL TZMETROPOLIS ' is commented our of the delivered
C     test procedure
C
C      CALL TZMETROPOLIS
C
      call example2
      end

      subroutine  cost(x,array,array2,n,error,ind)
c Returns the cost function resulting from guessing x (answer).
c This could be any function or logical operation.

c X     is the solution vector.
c ARRAY is an array of N data points if needed.
c ARRAY2 is another array of N elements if needed.
c N      is the number of elements/data points in ARRAY & ARRAY2.
c ERROR is the returned cost.
c IND   is 0 for normal return, 1 for abnormal return.
c        If METROPOLIS senses an indicator of 1 it will generate another
c        guess somewhere else & try again.

c (1)=radius (2)=x_center (3)=y_center
      real*4 array(2,n),array2(n),x(4),dr(10)

      ind=1
      if(x(1).lt.5.)return
      if(x(1).gt.50.)return
      if(x(2).gt.100.)return
      if(x(3).gt.100.)return
      if(x(2).lt.1.)return
      if(x(3).lt.1.)return
      sumdr=0.
      sum=0.
      range=20.
      m=0
      do j=1,n
        dr(j)=abs(x(1)-sqrt((array(1,j)-x(2))**2+(array(2,j)-x(3))**2))
        sum=sum+dr(j)
        if(dr(j).lt.range)then
           m=m+1
           sumdr=sumdr+dr(j)
        endif
      enddo
      if(m.eq.0)then
         error=sum/n + range/n
      else
         error=sumdr/m + range/m
      endif
      ind=0
      return
      end

      subroutine example2
c EXAMPLE # 2
c purpose to test the Metropolis algorithm in one dimension.
c The example below is to find the LOWEST minimum of the
c polynomial expressed by the COST function found at the
c end of this example.
      real*4 range(1),answer(1),array(1),array2(1)
      character*80 msg
      external e2cost
      range(1)=2.0
      numten=500
      answer(1)=3.
      limit=1500
      iprint=200
      narg=1
      norm=200
      npts=0
      call xvmessage('Fortran test case 2',' ')
      call metropolis(e2cost,narg,array,array2,range,numten,answer,
     +                 limit,norm,npts,iprint,ind)
      write(msg,*)'answer=',answer(1)
      call xvmessage(msg,' ')
      call xvmessage('solution should be about -2.9',' ')
      return
      end

      subroutine e2cost(x,array,array2,n,error,ind)
      real*4 array(1),array2(1),x(1)
      ind=0
      error=x(1)**4-16*x(1)**2+5*x(1)
      return
      end


program arrays_01_logical
implicit none
integer :: i, j
logical :: a(3), b(4), c(2, 2)

a(1) = .true.
do i = 2, 3
    a(i) = .not. a(i - 1)
end do
if (.not. a(1)) error stop
if (a(2)) error stop
if (.not. a(3)) error stop

b(1) = .false.
do i = 12, 14
    b(i-10) = .not. b(i - 10 - 1)
end do
if (b(1)) error stop
if (.not. b(2)) error stop
if (b(3)) error stop
if (.not. b(4)) error stop

do i = 1, 3
    b(i) = a(i) .and. .false.
end do
if (b(1)) error stop
if (b(2)) error stop
if (b(3)) error stop

b(4) = b(1) .or. b(2) .or. b(3) .or. a(1)
if (.not. b(4)) error stop

b(4) = a(1)
if (.not. b(4)) error stop

do i = 1, 2
    do j = 1, 2
        if (((i + j) - 2*((i + j)/2)) == 1) then
            c(i, j) = .true.
        else
            c(i, j) = .false.
        end if
    end do
end do
if (c(1, 1)) error stop
if (.not. c(1, 2)) error stop
if (.not. c(2, 1)) error stop
if (c(2, 2)) error stop
end


program test_mo_select_distant_entries

  use mo_kind,                   only: i4, dp
  use mo_ansi_colors, only: color, c_red, c_green
  use mo_select_distant_entries, only: select_distant_entries

  implicit none

  real(dp), dimension(:,:),  allocatable :: distance_matrix        ! square matrix with distance between element i and j
  integer(i4)                            :: n_total                ! total number of elements
  integer(i4)                            :: n_select               ! number of elements to select
  integer(i4), dimension(:), allocatable :: max_entries
  logical                                :: isgood

  isgood = .true.
  n_total  = 5
  n_select = 3

  allocate( distance_matrix(n_total, n_total) )
  allocate( max_entries(n_select) )

  !             1                   2
  !
  !
  !                       5
  !
  !
  !             4                   3

  distance_matrix(1,:) = (/ 0.0_dp, 5.0_dp, 7.0_dp, 5.0_dp, 3.5_dp /)
  distance_matrix(2,:) = (/ 5.0_dp, 0.0_dp, 5.0_dp, 7.0_dp, 3.5_dp /)
  distance_matrix(3,:) = (/ 7.0_dp, 5.0_dp, 0.0_dp, 5.0_dp, 3.5_dp /)
  distance_matrix(4,:) = (/ 5.0_dp, 7.0_dp, 5.0_dp, 0.0_dp, 3.5_dp /)
  distance_matrix(5,:) = (/ 3.5_dp, 3.5_dp, 3.5_dp, 3.5_dp, 0.0_dp /)

  ! selects first pair as the one with overall largest distance
  max_entries = select_distant_entries( distance_matrix, n_select, first=0 )
  write(*,*) 'Elements selected (first pair as the one with overall largest distance): ', max_entries
  if ( .not. all(max_entries .eq. (/1,2,3/)) ) isgood = .false.

  ! selects first pair randomly
  max_entries = select_distant_entries( distance_matrix, n_select, first=1, seed=12345_i4 )
  write(*,*) 'Elements selected (first pair randomly):                                 ', max_entries
  if ( .not. all(max_entries .eq. (/2,4,5/)) ) isgood = .false.

  if (isgood) then
     write(*,*) 'mo_select_distant_entries: ', color('o.k.', c_green)
  else
     write(*,*) 'mo_select_distant_entries: ', color('failed!', c_red)
  endif

end program test_mo_select_distant_entries


! { dg-do  run }
! { dg-additional-options "-ffrontend-optimize -fdump-tree-optimized" }
! PR fortran/66176 - inline conjg for matml.
program main
  complex, dimension(3,2) :: a
  complex, dimension(2,4) :: b, b2
  complex, dimension(3,4) :: c,c2
  complex, dimension(3,4) :: res1, res2, res3

  data a/(2.,-3.),(-5.,-7.),(11.,-13.),(-17.,-19.),(23.,-29.),(-31.,-37.) /
  data b/(41.,-43.),(-47.,-53.),(59.,-61.),(-67.,-71.),(73.,-79.),&
       & (-83.,-89.),(97.,-101.), (-103.,-107.)/

  data res1 /  (-255.,1585.),(-3124.,72.),(-612.,2376.),(-275.,2181.), &
       & (-4322.,202.),(-694.,3242.),(-371.,2713.),( -5408.,244.),(-944.,4012.),&
       & (-391.,3283.),(-6664.,352.),(-1012.,4756.)/

  data res2 / (2017.,-45.),(552.,2080.),(4428.,36.),(2789.,11.),(650.,2858.),&
       & (6146.,182.),(3485.,3.),(860.,3548.),(7696.,232.),(4281.,49.),&
       & (956.,4264.),(9532.,344.)/

  c = matmul(a,b)
  if (any(res1 /= c)) STOP 1
  b2 = conjg(b)
  c = matmul(a,conjg(b2))
  if (any(res1 /= c)) STOP 2
  c = matmul(a,conjg(b))
  if (any(res2 /= c)) STOP 3
  c = matmul(conjg(a), b)
  if (any(conjg(c) /= res2)) STOP 4
end program main
! { dg-final { scan-tree-dump-times "_gfortran_matmul" 0 "optimized" } }


module bessel
    use wigner
    contains
    !-------------------------------------------------------------------------------
    function BesselF1(y,np,n,bigL)
        implicit none

        INTEGER, INTENT(IN) :: np,n,bigL
        REAL(kind=8),INTENT(IN) :: y
        REAL(kind=8) :: BesselF1

        BesselF1 = 2.0**(dble(bigL)) / exp(logdoublefac(2*bigL+1)) &
            * y**(bigL/2.d0) &
            * exp(-y) * sqrt(EXP(logfac(np-1)+logfac(n-1)))

    end function BesselF1

    !-------------------------------------------------------------------------------
    function BesselF1_plusminus(y,np,n,bigL)
        implicit none

        INTEGER, INTENT(IN) :: np,n,bigL
        REAL(kind=8),INTENT(IN) :: y
        REAL(kind=8) :: BesselF1_plusminus

        BesselF1_plusminus = 2**(dble(bigL)-1.0) / exp(logdoublefac(2*bigL+1)) &
            * y**((dble(bigL)-1.0)/2.d0) &
            * exp(-y) * sqrt (EXP(logfac(np-1)+logfac(n-1)))

    end function BesselF1_plusminus

    !-------------------------------------------------------------------------------
    function BesselF2(np,lp,n,l)
      implicit none
      INTEGER, INTENT(IN) :: np,lp,n,l
      REAL(kind=8) :: BesselF2

      BesselF2 = sqrt(gamma(np+lp+0.5d0) * gamma(n+l+0.5d0))

    end function BesselF2

    !-------------------------------------------------------------------------------
    function BesselF3(y,np,lp,n,l,bigL)
        implicit none

        INTEGER, INTENT(IN) :: np,lp,n,l, bigL
        REAL(kind=8),INTENT(IN) :: y
        INTEGER :: m,mp!ip, i, m, mp
        REAL(kind=8) :: BesselF3

        BesselF3 = 0.0d0

        do m = 0, n-1
            do mp = 0, np-1
                BesselF3 = BesselF3 + Summand1(m,mp,n,np) &
                    * Gammas_regular(m,mp,l,lp,bigL) * CHGF_regular(y,m,mp,l,lp,bigL)
            end do
        end do

    end function BesselF3

    !-------------------------------------------------------------------------------
    function BesselF3_minus(y,np,lp,n,l,bigL)
        implicit none

        INTEGER, INTENT(IN) :: np,lp,n,l, bigL
        REAL(kind=8),INTENT(IN) :: y
        INTEGER :: mp, m
        REAL(kind=8) :: BesselF3_minus

        BesselF3_minus = 0.d0

        do m = 0, n-1
            do mp = 0, np-1
                BesselF3_minus = BesselF3_minus + Summand1(m,mp,n,np) &
                    * Gammas_plusminus(m,mp,l,lp,bigL) * CHGF_minus(y,m,mp,l,lp,bigL)
            end do
        end do

    end function BesselF3_minus

    !-------------------------------------------------------------------------------
    function BesselF3_plus(y,np,lp,n,l,bigL)
        implicit none

        INTEGER, INTENT(IN) :: np,lp,n,l, bigL
        REAL(kind=8),INTENT(IN) :: y
        INTEGER :: mp, m
        REAL(kind=8) :: BesselF3_plus

        BesselF3_plus = 0.d0

        do m = 0, n-1
            do mp = 0, np-1
                BesselF3_plus = BesselF3_plus + Summand1(m,mp,n,np) &
                    * Gammas_plusminus(m,mp,l,lp,bigL) * CHGF_plus(y,m,mp,l,lp,bigL)
            end do
        end do

    end function BesselF3_plus

    !-------------------------------------------------------------------------------
    function BesselElement(y,np,lp,n,l,bigL)

        implicit none

        INTEGER, INTENT(IN) :: np,lp,n,l, bigL
        REAL(kind=8),INTENT(IN) :: y
        REAL(kind=8) :: BesselElement

        BesselElement = BesselF1(y,np,n,bigL) &
            * BesselF2(np,lp,n,l) * BesselF3(y,np,lp,n,l,bigL)

    end function BesselElement

    !-------------------------------------------------------------------------------
    function BesselElementminus(y,np,lp,n,l,bigL)

        implicit none

        INTEGER, INTENT(IN) :: np,lp,n,l, bigL
        REAL(kind=8),INTENT(IN) :: y
        REAL(kind=8) :: BesselElementminus

        BesselElementminus = BesselF1_plusminus(y,np,n,bigL) &
            * BesselF2(np,lp,n,l) * BesselF3_minus(y,np,lp,n,l,bigL)

    end function BesselElementminus

    !-------------------------------------------------------------------------------
    function BesselElementplus(y,np,lp,n,l,bigL)

        implicit none

        INTEGER, INTENT(IN) :: np,lp,n,l, bigL
        REAL(kind=8),INTENT(IN) :: y
        REAL(kind=8) :: BesselElementplus

        BesselElementplus = BesselF1_plusminus(y,np,n,bigL) &
            * BesselF2(np,lp,n,l) * BesselF3_plus(y,np,lp,n,l,bigL)

    end function BesselElementplus

    !-------------------------------------------------------------------------------
    function Summand1(m,mp,n,np)
        implicit none
        INTEGER, INTENT(IN) :: m, mp, n, np
        REAL(kind=8) :: Summand1

        Summand1 = (-1)**(m+mp) / exp(logfac(m)+logfac(mp) &
            + logfac(n-1-m)+logfac(np-1-mp))

    end function Summand1

    !-------------------------------------------------------------------------------
    function Gammas_regular(m,mp,l,lp,bigL)
        implicit none
        INTEGER, INTENT(IN) :: m, mp, l, lp,bigL
        REAL(kind=8) :: Gammas_regular

        Gammas_regular = GAMMA((l+lp+bigL+2*m+2*mp+3.d0)/2.d0) &
            / GAMMA(l+m+3.d0/2.d0) / GAMMA(lp+mp+3.d0/2.d0)

    end function Gammas_regular

    !-------------------------------------------------------------------------------
    function Gammas_plusminus(m,mp,l,lp,bigL)
        implicit none
        INTEGER, INTENT(IN) :: m, mp, l, lp, bigL
        REAL(kind=8) :: Gammas_plusminus

        Gammas_plusminus =  GAMMA((l+lp+bigL+2*m+2*mp+2.d0)/2.d0) &
            / GAMMA(l+m+3.d0/2.d0) / GAMMA(lp+mp+3.d0/2.d0)

    end function Gammas_plusminus

    !-------------------------------------------------------------------------------
    function CHGF_regular(y,m,mp,l,lp,bigL)
        implicit none
        INTEGER, INTENT(IN) :: m, mp, l, lp,bigL
        REAL(kind=8), INTENT(IN) :: y
        REAL(kind=8) :: a, b
        REAL(kind=8) :: CHGF_regular

        a = dble(bigL-lp-l-2*mp-2*m)/2.d0
        b = dble(bigL)+3.d0/2.d0

        !  CHGF_regular = chg(a, b, y)
        call chgm(a,b,y,CHGF_regular)

    end function CHGF_regular

    !-------------------------------------------------------------------------------
    function CHGF_minus(y,m,mp,l,lp,bigL)
        implicit none
        INTEGER, INTENT(IN) :: m, mp, l, lp, bigL
        REAL(kind=8), INTENT(IN) :: y
        REAL(kind=8) :: a, b, ap,hg1,hg2
        REAL(kind=8) :: CHGF_minus

        a = (bigL-lp-l-2*mp-2*m-1.d0)/2.d0
        ap= (bigL-lp-l-2*mp-2*m+1.d0)/2.d0
        b = bigL+3.d0/2.d0

        call chgm(a,b,y,hg1)
        call chgm(ap,b,y,hg2)

        ! CHGF_minus = -(l+lp+bigL+2*m+2*mp+2.d0)/2.d0*chg(a, b, y)+2*m*chg(ap,b,y)
        CHGF_minus = -(l+lp+bigL+2*m+2*mp+2.d0)/2.d0*hg1+2*m*hg2

    end function CHGF_minus

    !-------------------------------------------------------------------------------
    function CHGF_plus(y,m,mp,l,lp,bigL)
        implicit none

        INTEGER, INTENT(IN) :: m, mp, l, lp, bigL
        REAL(kind=8), INTENT(IN) :: y
        REAL(kind=8) :: a, b, ap,hg1,hg2
        REAL(kind=8) :: CHGF_plus

        a = (bigL-lp-l-2*mp-2*m-1.d0)/2.d0
        ap= (bigL-lp-l-2*mp-2*m+1.d0)/2.d0
        b = bigL+3.d0/2.d0

        call chgm(a,b,y,hg1)
        call chgm(ap,b,y,hg2)

        ! CHGF_plus = -(l+lp+bigL+2*m+2*mp+2.d0)/2.d0*chg(a, b, y)+(2*l+2*m+1.d0)*chg(ap,b,y)
        CHGF_plus = -(l+lp+bigL+2*m+2*mp+2.d0)/2.d0*hg1+(2*l+2*m+1.d0)*hg2

    end function CHGF_plus

end module bessel


Real Function pipp1(srt)
  Save
  pmass = 0.14
  pmass1 = 0.938
  pipp1 = 0.0001
  If (srt<=1.22) Return
  plab = sqrt(((srt**2-pmass**2-pmass1**2)/(2.*pmass1))**2-pmass**2)
  pmin = 0.3
  pmax = 25.0
  If (plab>pmax) Then
    pipp1 = 20./10.
    Return
  End If
  If (plab<pmin) Then
    pipp1 = 0.
    Return
  End If
  a = 26.6
  b = -7.18
  c = 0.327
  an = -1.86
  d = -2.81
  pipp1 = a + b*(plab**an) + c*(alog(plab))**2 + d*alog(plab)
  If (pipp1<=0) pipp1 = 0
  pipp1 = pipp1/10.
  Return
End Function pipp1