module fitting
contains

  function polyfit(vx, vy, d)
    implicit none
    integer, intent(in)                   :: d
    integer, parameter                    :: dp = selected_real_kind(15, 307)
    real(dp), dimension(d+1)              :: polyfit
    real(dp), dimension(:), intent(in)    :: vx, vy

    real(dp), dimension(:,:), allocatable :: X
    real(dp), dimension(:,:), allocatable :: XT
    real(dp), dimension(:,:), allocatable :: XTX

    integer :: i, j

    integer     :: n, lda, lwork
    integer :: info
    integer, dimension(:), allocatable :: ipiv
    real(dp), dimension(:), allocatable :: work

    n = d+1
    lda = n
    lwork = n

    allocate(ipiv(n))
    allocate(work(lwork))
    allocate(XT(n, size(vx)))
    allocate(X(size(vx), n))
    allocate(XTX(n, n))

    ! prepare the matrix
    do i = 0, d
       do j = 1, size(vx)
          X(j, i+1) = vx(j)**i
       end do
    end do

    XT  = transpose(X)
    XTX = matmul(XT, X)

    ! calls to LAPACK subs DGETRF and DGETRI
    call DGETRF(n, n, XTX, lda, ipiv, info)
    if ( info /= 0 ) then
       print *, "problem"
       return
    end if
    call DGETRI(n, XTX, lda, ipiv, work, lwork, info)
    if ( info /= 0 ) then
       print *, "problem"
       return
    end if

    polyfit = matmul( matmul(XTX, XT), vy)

    deallocate(ipiv)
    deallocate(work)
    deallocate(X)
    deallocate(XT)
    deallocate(XTX)

  end function

end module


program sum_of_odds

! sum_of_odds.f90 - calculate sum of odd integers

  implicit none

  real :: version__ = 1.1
  character(10) :: date__ = "2021-01-15"

  integer, parameter :: up_to = 170

  integer :: sum = 0
  integer :: number_of_odds = 0
  integer :: last_odd = 0
  integer i

  do i = 0, up_to
    if (is_odd(i) .eqv. .TRUE.) then
      sum = sum + i
      number_of_odds = number_of_odds + 1
      last_odd = i
    end if
  end do

  if (sum == number_of_odds ** 2) then
    if (number_of_odds == 0) then
      continue
    else if (number_of_odds < 7) then
      print '(i0)', sum
    else
      print '("1 + 3 + 5 + ... + ", i0, " + ", i0, &
          & " = ", i0)', last_odd - 1, last_odd, sum
    end if
  else
    write(0, '(a, i0)'), 'Unexpected error: ', sum
    write(0, '(f3.1)'), version__
    write(0, '(a)'), date__
  end if

  stop

contains

logical function is_odd(x)
  implicit none

  integer x, remainder

  remainder = mod(x, 2)
  if (remainder == 0) then
    is_odd = .FALSE.
  else
    is_odd = .TRUE.
  end if

end function

end


PROGRAM main

  IMPLICIT NONE

  REAL :: x_min, x_max, dx, scale_fac
  REAL, PARAMETER :: pi = 3.14159
  REAL, DIMENSION(:), ALLOCATABLE :: sin_x, x
  INTEGER :: i, n_bins

  n_bins = 1000

  ! ALLOCATE the axis and data array
  ! You don't have to use produce this axis, but I chose to
  ALLOCATE(x(n_bins), sin_x(n_bins))

  ! Using a variable for this is clearer, and slightly more efficient
  scale_fac = 2.0 * pi

  ! We can make the x-axis several ways.
  ! I chose to pre-fill it
  x_min = 0.0
  x_max = 1.0
  dx = (x_max - x_min) / REAL(n_bins + 1)

  DO i = 1, n_bins
    x(i) = (x_min + dx * i) * scale_fac
    sin_x(i) = SIN(x(i))
  END DO

  ! Find the changes of sign
  DO i = 1, n_bins-1
    !A few ways to find the relative sign-
    ! Multiply the values. What happens if they're very small? Is this OK?
    ! Use the SIGN function to transfer sign without risking underflows
    ! Do the explicit comparisons (a < 0 and b > 0  or ... Beware of operator order!)
    IF(sin_x(i) * sin_x(i+1) < 0) THEN
      PRINT*, "Sign change at ", x(i)/pi, " pi"
    END IF
  END DO

END PROGRAM


      SUBROUTINE jacobi(N,A,B)
      INTEGER N,T,I

      REAL*8 A(N),B(N)

      DO 10, T=1,100
         DO 20, I=2,N-1
            B(I)=0.25D0*(A(I-1)+A(I+1))+0.5D0*A(I)
 20      CONTINUE
         DO 30, I=2,N-1
            A(I) = B(I)
 30      CONTINUE
 10   CONTINUE

      END


subroutine apply_pde_operator(t, q, output)

! For the PDE q_t = g(q), calculates g(q).
!
! Args:
!   t: Time at which the operator is evaluated.
!   q: PDE solution at time t.
!   output: g(q), calculated here.

    !$ use omp_lib
    implicit none

    integer :: mx, my, mbc, meqn
    double precision :: x_lower, y_lower, dx, dy
    common /claw_config/ mx, my, mbc, x_lower, y_lower, dx, dy, meqn

    double precision :: beta, kappa, delta, mu, right_film_height
    common /surfactant_config/ beta, kappa, delta, mu, right_film_height

    double precision, intent(in) :: t
    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn), intent(in) :: q
    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn), intent(out) :: output

    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc) :: h_laplacian, surface_tension
    double precision, dimension(1-mbc:mx+mbc, 1-mbc:my+mbc, meqn) :: x_flux, y_flux
    integer :: ix, iy, ieqn
    double precision, dimension(2) :: lower_flux, upper_flux
    double precision :: h_face, h_x, h_laplacian_x, g_face, g_x, surface_tension_x
    double precision :: h_y, h_laplacian_y, g_y, surface_tension_y

    call get_laplacian(q(:,:,1), h_laplacian)
    call compute_surface_tension(mx+2*mbc, my+2*mbc, q(:, :, 2), surface_tension)

    !$omp parallel do private(ix, h_face, h_x, h_laplacian_x, g_face, g_x, surface_tension_x)
    do iy = 1, my
        do ix = 1, mx+1
            h_face = (q(ix-1, iy, 1) + q(ix, iy, 1)) / 2.d0
            h_x = (q(ix, iy, 1) - q(ix-1, iy, 1)) / dx
            h_laplacian_x = (h_laplacian(ix, iy) - h_laplacian(ix-1, iy)) / dx

            g_face = (q(ix, iy, 2) + q(ix-1, iy, 2)) / 2.d0
            g_x = (q(ix, iy, 2) - q(ix-1, iy, 2)) / dx
            surface_tension_x = (surface_tension(ix, iy) - surface_tension(ix-1, iy)) / dx

            x_flux(ix, iy, 1) = h_face**3 / 3.d0 * (-beta * h_x + kappa * h_laplacian_x)  &
              + h_face**2 / 2.d0 * surface_tension_x

            x_flux(ix, iy, 2) = h_face * g_face * surface_tension_x - delta * g_x  &
              + kappa * h_face**2 / 2.d0 * h_laplacian_x * g_face
        end do
    end do

    !$omp parallel do private(ix, h_face, h_y, h_laplacian_y, g_face, g_y, surface_tension_y)
    do iy = 1, my+1
        do ix = 1, mx
            h_face = (q(ix, iy-1, 1) + q(ix, iy, 1)) / 2.d0
            h_y = (q(ix, iy, 1) - q(ix, iy-1, 1)) / dy
            h_laplacian_y = (h_laplacian(ix, iy) - h_laplacian(ix, iy-1)) / dy

            g_face = (q(ix, iy, 2) + q(ix, iy-1, 2)) / 2.d0
            g_y = (q(ix, iy, 2) - q(ix, iy-1, 2)) / dy
            surface_tension_y = (surface_tension(ix, iy) - surface_tension(ix, iy-1)) / dy

            y_flux(ix, iy, 1) = h_face**3 / 3.d0 * (-beta * h_y + kappa * h_laplacian_y)  &
              + h_face**2 / 2.d0 * surface_tension_y

            y_flux(ix, iy, 2) = h_face * g_face * surface_tension_y - delta * g_y  &
              + kappa * h_face**2 / 2.d0 * h_laplacian_y * g_face
       end do
    end do

    do ieqn = 1, meqn
        !$omp parallel do private(ix)
        do iy = 1, my
            do ix = 1, mx
                output(ix, iy, ieqn) = - (x_flux(ix+1, iy, ieqn) - x_flux(ix, iy, ieqn)) / dx  &
                    - (y_flux(ix, iy+1, ieqn) - y_flux(ix, iy, ieqn)) / dy
            end do
        end do
    end do

end subroutine apply_pde_operator


subroutine househ(a, b, deter)
  real, dimension(:,:), intent(inout) :: a
  real, dimension(:), intent(inout) :: b
  real, intent(out) :: deter

  integer :: n, i, j, k
  integer :: sigma

  real :: alpha, beta, p, q

  n = size(b)

  deter = 1

  sigma = 1

  do k=1, n-1
    alpha = 0

    do i = k, n
      alpha = alpha + a(i,k)*a(i,k)
    end do

    alpha = sqrt(alpha)

    alpha = -sign(1.,a(k,k))*alpha

    beta = alpha*(alpha - a(k,k))

    a(k,k) = a(k,k) - alpha

    deter = deter*a(k,k) !hai que cambiar signo

    do j= k+1, n
      q = 0

      do i=k, n
        q = q + a(i,k)*a(i,j)
      end do

      p = q/beta

      do i= k, n
        a(i,j) = a(i,j) - p*a(i,k)
      end do
    end do

    q = 0

    do i=k,n
      q = q + a(i,k)*b(i)
    end do

    p = q/beta

    do i=k,n
      b(i) = b(i) - p*a(i,k)
    end do

    a(k,k) = alpha

    sigma = sigma * (-1)

    print*, 'A matriz A e: '

    do i=1,n
      print*, a(i,:)
    end do

end do

  deter = deter*sigma

end subroutine


MODULE poly_zeroes
IMPLICIT NONE
PRIVATE :: aberth, newton, start, cnvex, cmerge, left, right, ctest
PUBLIC  :: polzeros
INTEGER, PARAMETER     :: dp = SELECTED_REAL_KIND(15, 60)

CONTAINS

!************************************************************************
!    NUMERICAL COMPUTATION OF THE ROOTS OF A POLYNOMIAL HAVING          *
!        COMPLEX COEFFICIENTS, BASED ON ABERTH'S METHOD.                *
!                      Version 1.4, June   1996                         *
!    (D. Bini, Dipartimento di Matematica, Universita' di Pisa)         *
!                         (bini@dm.unipi.it)                            *
!
!  ***************************************************************************
!  * All the software  contained in this library  is protected by copyright. *
!  * Permission  to use, copy, modify, and  distribute this software for any *
!  * purpose without fee is hereby granted, provided that this entire notice *
!  * is included  in all copies  of any software which is or includes a copy *
!  * or modification  of this software  and in all copies  of the supporting *
!  * documentation for such software.                                        *
!  ***************************************************************************
!  * THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR IMPLIED *
!  * WARRANTY. IN NO EVENT, NEITHER  THE AUTHORS, NOR THE PUBLISHER, NOR ANY *
!  * MEMBER  OF THE EDITORIAL BOARD OF  THE JOURNAL  "NUMERICAL ALGORITHMS", *
!  * NOR ITS EDITOR-IN-CHIEF, BE  LIABLE FOR ANY ERROR  IN THE SOFTWARE, ANY *
!  * MISUSE  OF IT  OR ANY DAMAGE ARISING OUT OF ITS USE. THE ENTIRE RISK OF *
!  * USING THE SOFTWARE LIES WITH THE PARTY DOING SO.                        *
!  ***************************************************************************
!  * ANY USE  OF THE SOFTWARE  CONSTITUTES  ACCEPTANCE  OF THE TERMS  OF THE *
!  * ABOVE STATEMENT.                                                        *
!  ***************************************************************************
!
!   AUTHOR:
!
!       DARIO ANDREA BINI
!       UNIVERSITY OF PISA, ITALY
!       E-MAIL: bini@dm.unipi.it
!
!   REFERENCE:
!
!    -  NUMERICAL COMPUTATION OF POLYNOMIAL ZEROS BY MEANS OF
!       ABERTH'S METHOD
!       NUMERICAL ALGORITHMS, 13 (1996), PP. 179-200
!
!   This version, which is compatible with Lahey's free ELF90 compiler
!   by Alan Miller, CSIRO Mathematical & Information Sciences,
!   Private Bag 10, Clayton South MDC, Victoria, Australia 3169.
!   amiller @ bigpond.net.au     http://users.bigpond.net.au/amiller
!   Latest revision of ELF90 version - 5 May 1997
!
!************************************************************************
! Work performed under the support of the ESPRIT BRA project 6846 POSSO *
!************************************************************************
!**********         SUBROUTINES AND FUNCTIONS                 ***********
!************************************************************************
!  The following routines/functions are listed:                         *
!  POLZEROS  :  computes polynomial roots by means of Aberth's method   *
!    ABERTH  :  computes the Aberth correction                          *
!    NEWTON  :  computes p(x)/p'(x) by means of Ruffini-Horner's rule   *
!    START   :  Selects N starting points by means of Rouche's theorem  *
!    CNVEX   :  Computes the convex hull, used by START                 *
!    CMERGE  :  Used by CNVEX                                           *
!    LEFT    :  Used by CMERGE                                          *
!    RIGHT   :  Used by CMERGE                                          *
!    CTEST   :  Convexity test, Used by CMERGE                          *
!************************************************************************
!                                                                       *
!                                                                       *
!************************************************************************
!********************** SUBROUTINE POLZEROS *****************************
!************************************************************************
!                        GENERAL COMMENTS                               *
!************************************************************************
!  This routine approximates the roots of   the  polynomial             *
!  p(x)=a(n+1)x^n+a(n)x^(n-1)+...+a(1), a(j)=cr(j)+I ci(j), I**2=-1,    *
!  where a(1) and a(n+1) are nonzero.                                   *
!  The coefficients are complex*16 numbers. The routine is fast, robust *
!  against overflow, and allows to deal with polynomials of any degree. *
!  Overflow situations are very unlikely and may occurr if there exist  *
!  simultaneously coefficients of moduli close to BIG and close to      *
!  SMALL, i.e., the greatest and the smallest positive real*8 numbers,  *
!  respectively. In this limit situation the program outputs a warning  *
!  message. The computation can be speeded up by performing some side   *
!  computations in single precision, thus slightly reducing the         *
!  robustness of the program (see the comments in the routine ABERTH).  *
!  Besides a set of approximations to the roots, the program delivers a *
!  set of a-posteriori error bounds which are guaranteed in the most    *
!  part of cases. In the situation where underflow does not allow to    *
!  compute a guaranteed bound, the program outputs a warning message    *
!  and sets the bound to 0. In the situation where the root cannot be   *
!  represented as a complex*16 number the error bound is set to -1.     *
!************************************************************************
!  The computation is performed by means of Aberth's method             *
!  according to the formula                                             *
!           x(i)=x(i)-newt/(1-newt*abcorr), i=1,...,n             (1)   *
!  where newt=p(x(i))/p'(x(i)) is the Newton correction and abcorr=     *
!  =1/(x(i)-x(1))+...+1/(x(i)-x(i-1))+1/(x(i)-x(i+1))+...+1/(x(i)-x(n)) *
!  is the Aberth correction to the Newton method.                       *
!************************************************************************
!  The value of the Newton correction is computed by means of the       *
!  synthetic division algorithm (Ruffini-Horner's rule) if |x|<=1,      *
!  otherwise the following more robust (with respect to overflow)       *
!  formula is applied:                                                  *
!                    newt=1/(n*y-y**2 R'(y)/R(y))                 (2)   *
!  where                                                                *
!                    y=1/x                                              *
!                    R(y)=a(1)*y**n+...+a(n)*y+a(n+1)            (2')   *
!  This computation is performed by the routine NEWTON.                 *
!************************************************************************
!  The starting approximations are complex numbers that are             *
!  equispaced on circles of suitable radii. The radius of each          *
!  circle, as well as the number of roots on each circle and the        *
!  number of circles, is determined by applying Rouche's theorem        *
!  to the functions a(k+1)*x**k and p(x)-a(k+1)*x**k, k=0,...,n.        *
!  This computation is performed by the routine START.                  *
!************************************************************************
!                              STOP CONDITION                           *
!************************************************************************
! If the condition                                                      *
!                     |p(x(j))|<EPS s(|x(j)|)                      (3)  *
! is satisfied,    where      s(x)=s(1)+x*s(2)+...+x**n * s(n+1),       *
! s(i)=|a(i)|*(1+3.8*(i-1)),  EPS is the machine precision (EPS=2**-53  *
! for the IEEE arithmetic), then the approximation x(j) is not updated  *
! and the subsequent iterations (1)  for i=j are skipped.               *
! The program stops if the condition (3) is satisfied for j=1,...,n,    *
! or if the maximum number NITMAX of  iterations   has   been reached.  *
! The condition (3) is motivated by a backward rounding error analysis  *
! of the Ruffini-Horner rule, moreover the condition (3) guarantees     *
! that the computed approximation x(j) is an exact root of a slightly   *
! perturbed polynomial.                                                 *
!************************************************************************
!             INCLUSION DISKS, A-POSTERIORI ERROR BOUNDS                *
!************************************************************************
! For each approximation x of a root, an a-posteriori absolute error    *
! bound r is computed according to the formula                          *
!                   r=n(|p(x)|+EPS s(|x|))/|p'(x)|                 (4)  *
! This provides an inclusion disk of center x and radius r containing a *
! root.                                                                 *
!************************************************************************
!************************************************************************
!*************       MEANING OF THE INPUT VARIABLES         *************
!************************************************************************
!************************************************************************
!                                                                       *
!  -- N     : degree of the polynomial.                                 *
!  -- POLY  : complex vector of N+1 components, POLY(i) is the          *
!           coefficient of x**(i-1), i=1,...,N+1 of the polynomial p(x) *
!  -- EPS   : machine precision of the floating point arithmetic used   *
!            by the computer, EPS=2**(-53)  for the IEEE standard.      *
!  -- BIG   : the max real*8, BIG=2**1023 for the IEEE standard.        *
!  -- SMALL : the min positive real*8, SMALL=2**(-1074) for the IEEE.   *
!  -- NITMAX: the max number of allowed iterations.                     *
!************************************************************************
!************************************************************************
!*************      MEANING OF THE OUTPUT VARIABLES         *************
!************************************************************************
!************************************************************************
!  ROOT   : complex vector of N components, containing the              *
!           approximations to the roots of p(x).                        *
!  RADIUS : real vector of N components, containing the error bounds to *
!           the approximations of the roots, i.e. the disk of center    *
!           ROOT(i) and radius RADIUS(i) contains a root of p(x), for   *
!           i=1,...,N. RADIUS(i) is set to -1 if the corresponding root *
!           cannot be represented as floating point due to overflow or  *
!           underflow.                                                  *
!  ERR    : vector of (N+1) components detecting an error condition;    *
!           ERR(j)=.TRUE. if after NITMAX iterations the stop condition *
!                         (3) is not satisfied for x(j)=ROOT(j);        *
!           ERR(j)=.FALSE.  otherwise, i.e., the root is reliable,      *
!                         i.e., it can be viewed as an exact root of a  *
!                         slightly perturbed polynomial.                *
!           The vector ERR is used also in the routine convex hull for  *
!           storing the abscissae of the vertices of the convex hull.   *
!           ERR(N+1) is only used for the convex hull.                  *
!  ITER   : number of iterations peformed.                              *
!************************************************************************
!************************************************************************
!************    MEANING OF THE AUXILIARY VARIABLES         *************
!************************************************************************
!************************************************************************
!  APOLY  : real vector of N+1 components used to store the moduli of   *
!           the coefficients of p(x) and the coefficients of s(x) used  *
!           to test the stop condition (3).                             *
!  APOLYR : real vector of N+1 components used to test the stop         *
!           condition                                                   *
!************************************************************************
!*****         WARNING:   2 is the output unit                    *******
!************************************************************************
SUBROUTINE polzeros (n, poly, eps, big, small, nitmax, root, radius, err, &
                     iter)
IMPLICIT NONE
INTEGER, INTENT(IN)            :: n, nitmax
INTEGER, INTENT(OUT)           :: iter
COMPLEX (KIND=dp), INTENT(IN)  :: poly(:)
COMPLEX (KIND=dp), INTENT(OUT) :: root(:)
REAL (KIND=dp), INTENT(OUT)    :: radius(:)
REAL (KIND=dp), INTENT(IN)     :: eps, small, big
LOGICAL, INTENT(OUT)           :: err(:)

! Local variables
INTEGER                   :: i, nzeros
COMPLEX (KIND=dp)         :: corr, abcorr
REAL (KIND=dp)            :: amax, apoly(n+1), apolyr(n+1)
REAL (KIND=dp), PARAMETER :: zero = 0.0_dp

! Check consistency of data
IF (ABS(poly(n+1)) == zero)THEN
  WRITE(*,*)'Inconsistent data: the leading coefficient is zero'
  STOP
END IF
IF (ABS(poly(1)) == zero) THEN
  WRITE(*,*)'The constant term is zero: deflate the polynomial'
  STOP
END IF

! Compute the moduli of the coefficients
amax = 0
DO i = 1, n+1
  apoly(i) = ABS(poly(i))
  amax = MAX(amax, apoly(i))
  apolyr(i) = apoly(i)
END DO
IF((amax) >= (big/(n+1))) THEN
  WRITE(*,*)'WARNING: COEFFICIENTS TOO BIG, OVERFLOW IS LIKELY'
  WRITE(2,*)'WARNING: COEFFICIENTS TOO BIG, OVERFLOW IS LIKELY'
END IF
! Initialize
DO i = 1, n
  radius(i) = zero
  err(i) = .true.
END DO

! Select the starting points
CALL start(n, apolyr, root, radius, nzeros, small, big, err)

! Compute the coefficients of the backward-error polynomial
DO i = 1, n+1
  apolyr(n-i+2) = eps*apoly(i)*(3.8*(n-i+1) + 1)
  apoly(i) = eps*apoly(i)*(3.8*(i-1) + 1)
END DO
IF((apoly(1) == 0).OR.(apoly(n+1) == 0)) THEN
  WRITE(*,*)'WARNING: THE COMPUTATION OF SOME INCLUSION RADIUS'
  WRITE(*,*)'MAY FAIL. THIS IS REPORTED BY RADIUS = 0'
  WRITE(2,*)'WARNING: THE COMPUTATION OF SOME INCLUSION RADIUS'
  WRITE(2,*)'MAY FAIL. THIS IS REPORTED BY RADIUS = 0'
END IF
DO i = 1,n
  err(i) = .true.
  IF(radius(i) == -1) err(i) = .false.
END DO

! Starts Aberth's iterations
DO iter = 1, nitmax
  DO i = 1, n
    IF (err(i)) THEN
      CALL newton(n, poly, apoly, apolyr, root(i), small, radius(i), corr, &
                  err(i))
      IF (err(i)) THEN
        CALL aberth(n, i, root, abcorr)
        root(i) = root(i) - corr/(1 - corr*abcorr)
      ELSE
        nzeros = nzeros + 1
        IF (nzeros == n) RETURN
      END IF
    END IF
  END DO
END DO
RETURN
END SUBROUTINE polzeros

!************************************************************************
!                             SUBROUTINE NEWTON                         *
!************************************************************************
! Compute  the Newton's correction, the inclusion radius (4) and checks *
! the stop condition (3)                                                *
!************************************************************************
! Input variables:                                                      *
!     N     : degree of the polynomial p(x)                             *
!     POLY  : coefficients of the polynomial p(x)                       *
!     APOLY : upper bounds on the backward perturbations on the         *
!             coefficients of p(x) when applying Ruffini-Horner's rule  *
!     APOLYR: upper bounds on the backward perturbations on the         *
!             coefficients of p(x) when applying (2), (2')              *
!     Z     : value at which the Newton correction is computed          *
!     SMALL : the min positive REAL (KIND=dp) ::, SMALL=2**(-1074) for the IEEE.   *
!************************************************************************
! Output variables:                                                     *
!     RADIUS: upper bound to the distance of Z from the closest root of *
!             the polynomial computed according to (4).                 *
!     CORR  : Newton's correction                                       *
!     AGAIN : this variable is .true. if the computed value p(z) is     *
!             reliable, i.e., (3) is not satisfied in Z. AGAIN is       *
!             .false., otherwise.                                       *
!************************************************************************
SUBROUTINE newton(n, poly, apoly, apolyr, z, small, radius, corr, again)
IMPLICIT NONE
INTEGER, INTENT(IN)            :: n
COMPLEX (KIND=dp), INTENT(IN)  :: poly(:), z
COMPLEX (KIND=dp), INTENT(OUT) :: corr
REAL (KIND=dp), INTENT(IN)     :: apoly(:), apolyr(:), small
REAL (KIND=dp), INTENT(OUT)    :: radius
LOGICAL, INTENT(OUT)           :: again

! Local variables
INTEGER           :: i
COMPLEX (KIND=dp) :: p, p1, zi, den, ppsp
REAL (KIND=dp)    :: ap, az, azi, absp

az = ABS(z)
! If |z|<=1 then apply Ruffini-Horner's rule for p(z)/p'(z)
! and for the computation of the inclusion radius
IF(az <= 1)THEN
  p = poly(n+1)
  ap = apoly(n+1)
  p1 = p
  DO i = n, 2, -1
    p = p*z + poly(i)
    p1 = p1*z + p
    ap = ap*az + apoly(i)
  END DO
  p = p*z + poly(1)
  ap = ap*az + apoly(1)
  corr = p/p1
  absp = ABS(p)
  ap = ap
  again = (absp > (small + ap))
  IF(.NOT.again) radius = n*(absp + ap)/ABS(p1)
  RETURN
ELSE
! If |z| > 1 then apply Ruffini-Horner's rule to the reversed polynomial
! and use formula (2) for p(z)/p'(z). Analogously do for the inclusion radius.
  zi = 1/z
  azi = 1/az
  p = poly(1)
  p1 = p
  ap = apolyr(n+1)
  DO i = n, 2, -1
    p = p*zi + poly(n-i+2)
    p1 = p1*zi + p
    ap = ap*azi + apolyr(i)
  END DO
  p = p*zi + poly(n+1)
  ap = ap*azi + apolyr(1)
  absp = ABS(p)
  again = (absp > (small+ap))
  ppsp = (p*z)/p1
  den = n*ppsp - 1
  corr = z*(ppsp/den)
  IF(again)RETURN
  radius = ABS(ppsp) + (ap*az)/ABS(p1)
  radius = n*radius/ABS(den)
  radius = radius*az
END IF
RETURN
END SUBROUTINE newton

!************************************************************************
!                             SUBROUTINE ABERTH                         *
!************************************************************************
! Compute  the Aberth correction. To save time, the reciprocation of    *
! ROOT(J)-ROOT(I) could be performed in single precision (complex*8)    *
! In principle this might cause overflow if both ROOT(J) and ROOT(I)    *
! have too small moduli.                                                *
!************************************************************************
! Input variables:                                                      *
!     N     : degree of the polynomial                                  *
!     ROOT  : vector containing the current approximations to the roots *
!     J     : index of the component of ROOT with respect to which the  *
!             Aberth correction is computed                             *
!************************************************************************
! Output variable:                                                      *
!     ABCORR: Aberth's correction (compare (1))                         *
!************************************************************************
SUBROUTINE aberth(n, j, root, abcorr)
IMPLICIT NONE
INTEGER, INTENT(IN)            :: n, j
COMPLEX (KIND=dp), INTENT(IN)  :: root(:)
COMPLEX (KIND=dp), INTENT(OUT) :: abcorr

! Local variables
INTEGER                   :: i
COMPLEX (KIND=dp)         :: z, zj
REAL (KIND=dp), PARAMETER :: zero = 0.0_dp

abcorr = CMPLX(zero, zero, KIND=dp)
zj = root(j)
DO i = 1, j-1
  z = zj - root(i)
  abcorr = abcorr + 1/z
END DO
DO i = j+1, n
  z = zj - root(i)
  abcorr = abcorr + 1/z
END DO
RETURN
END SUBROUTINE aberth

!************************************************************************
!                             SUBROUTINE START                          *
!************************************************************************
! Compute  the starting approximations of the roots                     *
!************************************************************************
! Input variables:                                                      *
!     N     :  number of the coefficients of the polynomial             *
!     A     :  moduli of the coefficients of the polynomial             *
!     SMALL : the min positive REAL (KIND=dp) ::, SMALL=2**(-1074) for the IEEE.   *
!     BIG   : the max REAL (KIND=dp) ::, BIG=2**1023 for the IEEE standard.        *
! Output variables:                                                     *
!     Y     :  starting approximations                                  *
!     RADIUS:  if a component is -1 then the corresponding root has a   *
!              too big or too small modulus in order to be represented  *
!              as double float with no overflow/underflow               *
!     NZ    :  number of roots which cannot be represented without      *
!              overflow/underflow                                       *
! Auxiliary variables:                                                  *
!     H     :  needed for the computation of the convex hull            *
!************************************************************************
! This routines selects starting approximations along circles center at *
! 0 and having suitable radii. The computation of the number of circles *
! and of the corresponding radii is performed by computing the upper    *
! convex hull of the set (i,log(A(i))), i=1,...,n+1.                    *
!************************************************************************
SUBROUTINE start(n, a, y, radius, nz, small, big, h)
IMPLICIT NONE
INTEGER, INTENT(IN)            :: n
INTEGER, INTENT(OUT)           :: nz
LOGICAL, INTENT(OUT)           :: h(:)
COMPLEX (KIND=dp), INTENT(OUT) :: y(:)
REAL (KIND=dp), INTENT(IN)     :: small, big
REAL (KIND=dp), INTENT(IN OUT) :: a(:)
REAL (KIND=dp), INTENT(OUT)    :: radius(:)

! Local variables
INTEGER                   :: i, iold, nzeros, j, jj
REAL (KIND=dp)            :: r, th, ang, temp, xsmall, xbig
REAL (KIND=dp), PARAMETER :: pi2 = 6.2831853071796, sigma = 0.7

xsmall = LOG(small)
xbig = LOG(big)
nz = 0
! Compute the logarithm A(I) of the moduli of the coefficients of
! the polynomial and then the upper covex hull of the set (A(I),I)
DO i = 1, n+1
  IF(a(i) /= 0) THEN
    a(i) = LOG(a(i))
  ELSE
    a(i) = -1.d30
  END IF
END DO
CALL cnvex(n+1, a, h)
! Given the upper convex hull of the set (A(I),I) compute the moduli
! of the starting approximations by means of Rouche's theorem
iold = 1
th = pi2/n
DO i = 2, n+1
  IF (h(i)) THEN
    nzeros = i - iold
    temp = (a(iold) - a(i))/nzeros
! Check if the modulus is too small
    IF((temp < -xbig).AND.(temp >= xsmall))THEN
      WRITE(*,*)'WARNING:',nzeros,' ZERO(S) ARE TOO SMALL TO'
      WRITE(*,*)'REPRESENT THEIR INVERSES AS COMPLEX (KIND=dp) ::, THEY'
      WRITE(*,*)'ARE REPLACED BY SMALL NUMBERS, THE CORRESPONDING'
      WRITE(*,*)'RADII ARE SET TO -1'
      WRITE(2,*)'WARNING:',nzeros,' ZERO(S) ARE TOO SMALL TO '
      WRITE(2,*)'REPRESENT THEIR INVERSES AS COMPLEX (KIND=dp) ::, THEY'
      WRITE(2,*)'ARE REPLACED BY SMALL NUMBERS, THE CORRESPONDING'
      WRITE(2,*)'RADII ARE SET TO -1'
      nz = nz + nzeros
      r = 1.0D0/big
    END IF
    IF(temp < xsmall)THEN
      nz = nz + nzeros
      WRITE(*,*)'WARNING: ',nzeros,' ZERO(S) ARE TOO SMALL TO BE'
      WRITE(*,*)'REPRESENTED AS COMPLEX (KIND=dp) ::, THEY ARE SET TO 0'
      WRITE(*,*)'THE CORRESPONDING RADII ARE SET TO -1'
      WRITE(2,*)'WARNING: ',nzeros,' ZERO(S) ARE TOO SMALL TO BE'
      WRITE(2,*)'REPRESENTED AS COMPLEX (KIND=dp) ::, THEY ARE SET 0'
      WRITE(2,*)'THE CORRESPONDING RADII ARE SET TO -1'
    END IF
! Check if the modulus is too big
    IF(temp > xbig)THEN
      r = big
      nz = nz + nzeros
      WRITE(*,*)'WARNING: ', nzeros, ' ZEROS(S) ARE TOO BIG TO BE'
      WRITE(*,*)'REPRESENTED AS COMPLEX (KIND=dp) ::,'
      WRITE(*,*)'THE CORRESPONDING RADII ARE SET TO -1'
      WRITE(2,*)'WARNING: ',nzeros, ' ZERO(S) ARE TOO BIG TO BE'
      WRITE(2,*)'REPRESENTED AS COMPLEX (KIND=dp) ::,'
      WRITE(2,*)'THE CORRESPONDING RADII ARE SET TO -1'
    END IF
    IF((temp <= xbig).AND.(temp > MAX(-xbig, xsmall)))THEN
      r = EXP(temp)
    END IF
! Compute NZEROS approximations equally distributed in the disk of
! radius R
    ang = pi2/nzeros
    DO j = iold, i-1
      jj = j-iold+1
      IF((r <= (1.0D0/big)).OR.(r == big)) radius(j) = -1
      y(j) = r*(COS(ang*jj + th*i + sigma) + (0,1)*SIN(ang*jj + th*i + sigma))
    END DO
    iold = i
  END IF
END DO
RETURN
END SUBROUTINE start

!************************************************************************
!                             SUBROUTINE CNVEX                          *
!************************************************************************
! Compute  the upper convex hull of the set (i,a(i)), i.e., the set of  *
! vertices (i_k,a(i_k)), k=1,2,...,m, such that the points (i,a(i)) lie *
! below the straight lines passing through two consecutive vertices.    *
! The abscissae of the vertices of the convex hull equal the indices of *
! the TRUE  components of the logical output vector H.                  *
! The used method requires O(nlog n) comparisons and is based on a      *
! divide-and-conquer technique. Once the upper convex hull of two       *
! contiguous sets  (say, {(1,a(1)),(2,a(2)),...,(k,a(k))} and           *
! {(k,a(k)), (k+1,a(k+1)),...,(q,a(q))}) have been computed, then       *
! the upper convex hull of their union is provided by the subroutine    *
! CMERGE. The program starts with sets made up by two consecutive       *
! points, which trivially constitute a convex hull, then obtains sets   *
! of 3,5,9... points,  up to  arrive at the entire set.                 *
! The program uses the subroutine  CMERGE; the subroutine CMERGE uses   *
! the subroutines LEFT, RIGHT and CTEST. The latter tests the convexity *
! of the angle formed by the points (i,a(i)), (j,a(j)), (k,a(k)) in the *
! vertex (j,a(j)) up to within a given tolerance TOLER, where i<j<k.    *
!************************************************************************
SUBROUTINE cnvex(n, a, h)
IMPLICIT NONE
INTEGER, INTENT(IN)        :: n
LOGICAL, INTENT(OUT)       :: h(:)
REAL (KIND=dp), INTENT(IN) :: a(:)

! Local variables
INTEGER :: i, j, k, m, nj, jc

h(1:n) = .true.

! compute K such that N-2 <= 2**K < N-1
k = INT(LOG(n-2.0D0)/LOG(2.0D0))
IF(2**(k+1) <= (n-2)) k = k+1

! For each M=1,2,4,8,...,2**K, consider the NJ pairs of consecutive
! sets made up by M+1 points having the common vertex
! (JC,A(JC)), where JC=M*(2*J+1)+1 and J=0,...,NJ,
! NJ = MAX(0, INT((N-2-M)/(M+M))).
! Compute the upper convex hull of their union by means of subroutine CMERGE
m = 1
DO i = 0, k
  nj = MAX(0, INT((n-2-m)/(m+m)))
  DO j = 0, nj
    jc = (j+j+1)*m+1
    CALL cmerge(n, a, jc, m, h)
  END DO
  m = m+m
END DO
RETURN
END SUBROUTINE cnvex

!************************************************************************
!                             SUBROUTINE LEFT                           *
!************************************************************************
! Given as input the integer I and the vector H of logical, compute the *
! the maximum integer IL such that IL<I and H(IL) is TRUE.              *
!************************************************************************
! Input variables:                                                      *
!     H   : vector of logical                                           *
!     I   : integer                                                     *
!************************************************************************
! Output variable:                                                      *
!     IL  : maximum integer such that IL<I, H(IL)=.TRUE.                *
!************************************************************************
SUBROUTINE left(h, i, il)
IMPLICIT NONE
INTEGER, INTENT(IN)  :: i
INTEGER, INTENT(OUT) :: il
LOGICAL, INTENT(IN)  :: h(:)

DO il = i-1, 0, -1
  IF (h(il)) RETURN
END DO
RETURN
END SUBROUTINE left

!************************************************************************
!                             SUBROUTINE RIGHT                          *
!************************************************************************
!************************************************************************
! Given as input the integer I and the vector H of logical, compute the *
! the minimum integer IR such that IR>I and H(IL) is TRUE.              *
!************************************************************************
!************************************************************************
! Input variables:                                                      *
!     N   : length of the vector H                                      *
!     H   : vector of logical                                           *
!     I   : integer                                                     *
!************************************************************************
! Output variable:                                                      *
!     IR  : minimum integer such that IR>I, H(IR)=.TRUE.                *
!************************************************************************
SUBROUTINE right(n, h, i, ir)
IMPLICIT NONE
INTEGER, INTENT(IN)  :: n, i
INTEGER, INTENT(OUT) :: ir
LOGICAL, INTENT(IN)  :: h(:)

DO ir = i+1, n
  IF (h(ir)) RETURN
END DO
RETURN
END SUBROUTINE right

!************************************************************************
!                             SUBROUTINE CMERGE                         *
!************************************************************************
! Given the upper convex hulls of two consecutive sets of pairs         *
! (j,A(j)), compute the upper convex hull of their union                *
!************************************************************************
! Input variables:                                                      *
!     N    : length of the vector A                                     *
!     A    : vector defining the points (j,A(j))                        *
!     I    : abscissa of the common vertex of the two sets              *
!     M    : the number of elements of each set is M+1                  *
!************************************************************************
! Input/Output variable:                                                *
!     H    : vector defining the vertices of the convex hull, i.e.,     *
!            H(j) is .TRUE. if (j,A(j)) is a vertex of the convex hull  *
!            This vector is used also as output.                        *
!************************************************************************
SUBROUTINE cmerge(n, a, i, m, h)
IMPLICIT NONE
INTEGER, INTENT(IN)        :: n, m, i
LOGICAL, INTENT(IN OUT)    :: h(:)
REAL (KIND=dp), INTENT(IN) :: a(:)

! Local variables
INTEGER :: ir, il, irr, ill
LOGICAL :: tstl, tstr

! at the left and the right of the common vertex (I,A(I)) determine
! the abscissae IL,IR, of the closest vertices of the upper convex
! hull of the left and right sets, respectively
CALL left(h, i, il)
CALL right(n, h, i, ir)

! check the convexity of the angle formed by IL,I,IR
IF (ctest(a, il, i, ir)) THEN
  RETURN
ELSE
! continue the search of a pair of vertices in the left and right
! sets which yield the upper convex hull
  h(i) = .false.
  DO
    IF (il == (i-m)) THEN
      tstl = .true.
    ELSE
      CALL left(h, il, ill)
      tstl = ctest(a, ill, il, ir)
    END IF
    IF (ir == MIN(n, i+m)) THEN
      tstr = .true.
    ELSE
      CALL right(n, h, ir, irr)
      tstr = ctest(a, il, ir, irr)
    END IF
    h(il) = tstl
    h(ir) = tstr
    IF (tstl.AND.tstr) RETURN
    IF(.NOT.tstl) il = ill
    IF(.NOT.tstr) ir = irr
  END DO
END IF

RETURN
END SUBROUTINE cmerge

!************************************************************************
!                             FUNCTION CTEST                            *
!************************************************************************
! Test the convexity of the angle formed by (IL,A(IL)), (I,A(I)),       *
! (IR,A(IR)) at the vertex (I,A(I)), up to within the tolerance         *
! TOLER. If convexity holds then the function is set to .TRUE.,         *
! otherwise CTEST=.FALSE. The parameter TOLER is set to 0.4 by default. *
!************************************************************************
! Input variables:                                                      *
!     A       : vector of double                                        *
!     IL,I,IR : integers such that IL < I < IR                          *
!************************************************************************
! Output:                                                               *
!     .TRUE. if the angle formed by (IL,A(IL)), (I,A(I)), (IR,A(IR)) at *
!            the vertex (I,A(I)), is convex up to within the tolerance  *
!            TOLER, i.e., if                                            *
!            (A(I)-A(IL))*(IR-I)-(A(IR)-A(I))*(I-IL)>TOLER.             *
!     .FALSE.,  otherwise.                                              *
!************************************************************************
FUNCTION ctest(a, il, i, ir) RESULT(OK)
IMPLICIT NONE
INTEGER, INTENT(IN)        :: i, il, ir
REAL (KIND=dp), INTENT(IN) :: a(:)
LOGICAL                    :: OK

! Local variables
REAL (KIND=dp)            :: s1, s2
REAL (KIND=dp), PARAMETER :: toler = 0.4D0

s1 = a(i) - a(il)
s2 = a(ir) - a(i)
s1 = s1*(ir-i)
s2 = s2*(i-il)
OK = .false.
IF(s1 > (s2+toler)) OK = .true.
RETURN
END FUNCTION ctest

END MODULE poly_zeroes


module fft_2based_class
    use,intrinsic :: iso_fortran_env
    implicit none
    real(real64),parameter:: pi = acos(-1d0), pi2 = 2d0*pi
    private
    public:: fft_2based, fft, ifft
    type:: fft_2based
        integer(int32):: l, hl, n, bit_len
        real(real64),allocatable:: wr(:),wi(:)
    contains
        procedure,private:: set_w
        procedure,private:: calc
        procedure:: fft,ifft
    end type
    interface fft_2based
        module procedure:: init_fft_calc
    end interface
contains
    function init_fft_calc(array_len) result(fftc)
        integer(int32),intent(in):: array_len
        type(fft_2based):: fftc

        fftc%l = array_len
        fftc%hl = fftc%l/2
        fftc%bit_len = 0
        do while(shiftl(1,fftc%bit_len) < fftc%l)
            fftc%bit_len = fftc%bit_len + 1
        end do

        fftc%n = shiftl(1,fftc%bit_len)
        ! print*, fftc%l, fftc%hl, fftc%n, fftc%bit_len
        call fftc%set_w()
    end function

    subroutine set_w(fftc)
        class(fft_2based):: fftc
        real(real64):: theta
        integer(int32):: i,hn

        if (allocated(fftc%wr)) deallocate(fftc%wr)
        if (allocated(fftc%wi)) deallocate(fftc%wi)
        hn = shiftr(fftc%n,1)
        allocate(fftc%wr(0:hn-1), fftc%wi(0:hn-1))

        theta = -pi2/real(fftc%n, kind=real64)
        do i=0,hn-1
            fftc%wr(i) = cos(theta*i)
            fftc%wi(i) = sin(theta*i)
        end do
        call bit_rev(fftc%wr, fftc%wi, hn, fftc%bit_len-1)
    end subroutine

    subroutine bit_rev(ar, ai, n, bit_len)
        integer(int32)::i,j,n,bit_len
        real(real64):: ar(1:n), ai(1:n)

        do i=0,n-1
            j = calc_rev(i, bit_len)
            ! print"(2b16."//char(bit_len+ichar("0"))//")",i,j
            if (i < j)then
                call swap(i+1,j+1)
            end if
        end do
    contains
        subroutine swap(i,j)
            integer(int32),intent(in):: i,j
            real(real64):: t1r,t1i,t2r,t2i

            t1r=ar(i)
            t2r=ar(j)
            t1i=ai(i)
            t2i=ai(j)
            ar(j)=t1r
            ar(i)=t2r
            ai(j)=t1i
            ai(i)=t2i
        end subroutine
    end subroutine

    function calc_rev(x, bit_len) result(revx)
        integer(int32),intent(in):: x
        integer(int32):: revx,i,t,bit_len
        revx=0
            do i=0,bit_len-1
                ! print*, k,h-k-1,h,n
                t = iand(1, shiftr(x,i))
                revx = ieor(revx, shiftl(t, bit_len-1-i))
            end do
    end function

    subroutine fft(fftc,ar,ai)
        class(fft_2based),intent(inout):: fftc
        real(real64):: ar(fftc%n),ai(fftc%n)

        call bit_rev(ar,ai,fftc%n,fftc%bit_len)
        call fftc%calc(ar,ai,.false.)
    end subroutine

    subroutine ifft(fftc,ar,ai)
        class(fft_2based),intent(inout):: fftc
        real(real64):: ar(fftc%n),ai(fftc%n)

        call bit_rev(ar,ai,fftc%n,fftc%bit_len)
        call fftc%calc(ar,ai,.true.)
        ar(:) = ar(:)/dble(fftc%n)
        ai(:) = ai(:)/dble(fftc%n)
    end subroutine

    subroutine calc(fftc, ar, ai, inv)
        class(fft_2based),intent(inout):: fftc
        real(real64):: ar(fftc%n), ai(fftc%n)
        real(real64):: xr,xi,wkr,wki
        integer(int32):: m, hm, k, i,hi, j, t
        logical:: inv

        hm = 1
        m = shiftl(hm,1)
        t=0
        do while(m <= fftc%n)
            t=t+1
            do i=0, fftc%n-1, m
                hi = shiftr(i,t)

                wkr = fftc%wr(hi)
                wki = fftc%wi(hi)
                if (inv) wki=-wki
                do j=i+1, hm+i
                    k = j+hm
                    xr = ar(j) - ar(k)
                    xi = ai(j) - ai(k)
                    ar(j) = ar(j) + ar(k)
                    ai(j) = ai(j) + ai(k)
                    ar(k) = wkr*xr - wki*xi
                    ai(k) = wkr*xi + wki*xr
                end do
            end do
            hm = m
            m = shiftl(hm,1)
        end do
    end subroutine
end module

module fft_mod
    use,intrinsic :: iso_fortran_env
    use fft_2based_class
    implicit none
    type(fft_2based):: fftc
    private
    public:: init_fft, init_conv, init_corr, init_acf
    public:: fft2, ifft2
    public:: convolution, liner_convolution
    public:: correlation, liner_correlation
    public:: auto_correlation_function
    public:: get_fft_len

contains
    subroutine init_fft(array_size)
        integer(int32),intent(in):: array_size

        fftc = fft_2based(array_size)
    end subroutine

    subroutine init_conv(array_size)
        integer(int32),intent(in):: array_size

        fftc = fft_2based(array_size*2)
    end subroutine

    subroutine init_corr(array_size)
        integer(int32),intent(in):: array_size

        fftc = fft_2based(array_size*2)
    end subroutine

    subroutine init_acf(array_size)
        integer(int32),intent(in):: array_size

        fftc = fft_2based(array_size*2)
    end subroutine

    subroutine fft2(ar,ai)
        real(real64):: ar(fftc%n),ai(fftc%n)

        call fftc%fft(ar,ai)
    end subroutine

    subroutine ifft2(ar,ai)
        real(real64):: ar(fftc%n),ai(fftc%n)

        call fftc%ifft(ar,ai)
    end subroutine

    subroutine convolution(fr,gr,xr)
        real(real64), intent(inout):: fr(fftc%n),gr(fftc%n),xr(fftc%n)
        real(real64):: fi(fftc%n), gi(fftc%n), xi(fftc%n)

        call fftc%fft(fr,fi)
        call fftc%fft(gr,gi)
        xr(1:fftc%n) = fr(1:fftc%n)*gr(1:fftc%n) - fi(1:fftc%n)*gi(1:fftc%n)
        xi(1:fftc%n) = fr(1:fftc%n)*gi(1:fftc%n) + fi(1:fftc%n)*gr(1:fftc%n)
        call fftc%ifft(xr,xi)
    end subroutine

    subroutine liner_convolution(fr,gr,xr)
        real(real64), intent(in):: fr(fftc%hl),gr(fftc%hl)
        real(real64), intent(out):: xr(fftc%hl)
        real(real64):: fr2(fftc%n), gr2(fftc%n), xr2(fftc%n)

        fr2(1:fftc%hl) = fr(1:fftc%hl); fr2(fftc%hl+1:fftc%n) = 0d0
        gr2(1:fftc%hl) = gr(1:fftc%hl); gr2(fftc%hl+1:fftc%n) = 0d0
        call convolution(fr2,gr2,xr2)
        xr(1:fftc%hl) = xr2(1:fftc%hl)
    end subroutine

    subroutine correlation(fr,gr,xr)
        real(real64), intent(inout):: fr(fftc%n),gr(fftc%n)
        real(real64), intent(out):: xr(fftc%n)
        real(real64):: fi(fftc%n),gi(fftc%n),xi(fftc%n)

        call fftc%fft(fr,fi)
        call fftc%fft(gr,gi)
        xr(1:fftc%n) = fr(1:fftc%n)*gr(1:fftc%n) + fi(1:fftc%n)*gi(1:fftc%n)
        xi(1:fftc%n) = fr(1:fftc%n)*gi(1:fftc%n) - fi(1:fftc%n)*gr(1:fftc%n)
        call fftc%ifft(xr,xi)
    end subroutine

    subroutine liner_correlation(fr,gr,xr)
        real(real64), intent(in):: fr(fftc%hl),gr(fftc%hl)
        real(real64), intent(out):: xr(fftc%hl)
        real(real64):: fr2(fftc%n), gr2(fftc%n), xr2(fftc%n)

        fr2(1:fftc%hl) = fr(1:fftc%hl); fr2(fftc%hl+1:fftc%n) = 0d0
        gr2(1:fftc%hl) = gr(1:fftc%hl); gr2(fftc%hl+1:fftc%n) = 0d0
        call correlation(fr2,gr2,xr2)
        xr(1:fftc%hl) = xr2(1:fftc%hl)
    end subroutine

    function auto_correlation_function(ar) result(xr)
        real(real64),intent(in):: ar(fftc%hl)
        real(real64):: xr(fftc%hl), ar2(fftc%n), ai2(fftc%n)

        ar2(1:fftc%hl) = ar(1:fftc%hl); ar2(fftc%hl+1:fftc%n) = 0d0
        ai2(1:fftc%n) = 0d0
        call fftc%fft(ar2, ai2)
        ar2(1:fftc%n) = ar2(1:fftc%n)*ar2(1:fftc%n) + ai2(1:fftc%n)*ai2(1:fftc%n)
        ai2(1:fftc%n) = 0d0
        call fftc%ifft(ar2, ai2)
        xr(:) = ar2(1:fftc%hl)
    end function

    function get_fft_len() result(fft_len)
        integer(int32):: fft_len

        fft_len = fftc%n
    end function
end module fft_mod


C FUNCTION AGAUSS             (NEXT)
      FUNCTION AGAUSS (XFUNCT, H2)
C
C     AGAUSS - GAUSSIAN INTEGRATION IN WHICH 48 ABSCISSAS AND WEIGHT
C        FACTORS ARE USED.  XFUNCT IS THE FUNCTION TO BE INTEGRATED AND
C        H2 IS THE ELEMENT LENGTH WHICH DETERMINES THE INTEGRATION
C        LIMITS.
C     SEE ABRAMOWITZ AND STEGUN, HANDBOOK OF MATHEMATICAL FUNCTIONS,
C     P 887 (EQU 25.4.30), P917 (WEIGHT AND ABSCISSA VALUES).
C     THE WEIGHTS AND ABSCISSAS ARE IN COMMON /WEIGHT/ AND ARE SET
C     IN SUBROUTINE GAIN IN A DATA STATEMENT.
C
      COMMON /WAITS /HH (48), XI (48)
C
      EXTERNAL XFUNCT
C
C
C.....INITIALIZE, INTEGRATE, AND TEST...................................
      DATA TESTD / 5.0E-08/
      M = 1
      ANS = 0.0
      CHECK = 1000.0
      IF (H2 .EQ. 0.0) GO TO 125
 100  AGAUSS = 0.0
      IF (M .LT. 1) GO TO 130
      DO 110 L = 1, M
      FL = L
      FM = M
      BOLIM = - H2 + 2.0 * H2 * (FL - 1.0) / FM
      UPLIM = - H2 + 2.0 * H2 * FL / FM
      SUM = 0.0
      DO 105 I = 1, 48
      S = 0.5 * ((UPLIM - BOLIM) * XI (I) + UPLIM + BOLIM)
 105  SUM = SUM + HH (I) * XFUNCT (S)
      SUM = 0.5 * (UPLIM - BOLIM) * SUM
 110  AGAUSS = AGAUSS + SUM
 130  CONTINUE
      TEST = ABS ((AGAUSS - ANS) / AGAUSS)
      IF (TEST .GT. 0.0005) GO TO 115
      IF (TEST .LE. TESTD) GO TO 125
 115  IF (M .GE. 10) GO TO 120
      CHECK = TEST - TESTD
      M = M + 1
      ANS = AGAUSS
      GO TO 100
 120  IF (CHECK .GE. TEST) GO TO 125
      AGAUSS = ANS
 125  RETURN
      END


*DECK SEPX4
      SUBROUTINE SEPX4 (IORDER, A, B, M, MBDCND, BDA, ALPHA, BDB, BETA,
     +   C, D, N, NBDCND, BDC, BDD, COFX, GRHS, USOL, IDMN, W, PERTRB,
     +   IERROR)
C***BEGIN PROLOGUE  SEPX4
C***PURPOSE  Solve for either the second or fourth order finite
C            difference approximation to the solution of a separable
C            elliptic partial differential equation on a rectangle.
C            Any combination of periodic or mixed boundary conditions is
C            allowed.
C***LIBRARY   SLATEC (FISHPACK)
C***CATEGORY  I2B1A2
C***TYPE      SINGLE PRECISION (SEPX4-S)
C***KEYWORDS  ELLIPTIC, FISHPACK, HELMHOLTZ, PDE, SEPARABLE
C***AUTHOR  Adams, J., (NCAR)
C           Swarztrauber, P. N., (NCAR)
C           Sweet, R., (NCAR)
C***DESCRIPTION
C
C Purpose                SEPX4 solves for either the second-order
C                        finite difference approximation or a
C                        fourth-order approximation  to the
C                        solution of a separable elliptic equation
C                             AF(X)*UXX+BF(X)*UX+CF(X)*U+UYY = G(X,Y)
C
C                        on a rectangle (X greater than or equal to A
C                        and less than or equal to B; Y greater than
C                        or equal to C and less than or equal to D).
C                        Any combination of periodic or mixed boundary
C                        conditions is allowed.
C                        If boundary conditions in the X direction
C                        are periodic (see MBDCND=0 below) then the
C                        coefficients must satisfy
C                        AF(X)=C1,BF(X)=0,CF(X)=C2 for all X.
C                        Here C1,C2 are constants, C1.GT.0.
C
C                        The possible boundary conditions are
C                        in the X-direction:
C                         (0) Periodic, U(X+B-A,Y)=U(X,Y) for all Y,X
C                         (1) U(A,Y), U(B,Y) are specified for all Y
C                         (2) U(A,Y), dU(B,Y)/dX+BETA*U(B,Y) are
C                             specified for all Y
C                         (3) dU(A,Y)/dX+ALPHA*U(A,Y),dU(B,Y)/dX+
C                             BETA*U(B,Y) are specified for all Y
C                         (4) dU(A,Y)/dX+ALPHA*U(A,Y),U(B,Y) are
C                             specified for all Y
C
C                        In the Y-direction:
C                         (0) Periodic, U(X,Y+D-C)=U(X,Y) for all X,Y
C                         (1) U(X,C),U(X,D) are specified for all X
C                         (2) U(X,C),dU(X,D)/dY are specified for all X
C                         (3) dU(X,C)/DY,dU(X,D)/dY are specified for
C                            all X
C                        (4) dU(X,C)/DY,U(X,D) are specified for all X
C
C Usage                  Call SEPX4(IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,
C                                  BETA,C,D,N,NBDCND,BDC,BDD,COFX,
C                                  GRHS,USOL,IDMN,W,PERTRB,IERROR)
C
C Arguments
C
C                        IORDER
C                          = 2 If a second-order approximation is sought
C                          = 4 If a fourth-order approximation is sought
C
C                        A,B
C                          The range of the X-independent variable;
C                          i.e., X is greater than or equal to A and
C                          less than or equal to B.  A must be less than
C                          B.
C
C                        M
C                          The number of panels into which the interval
C                          [A,B] is subdivided.  Hence, there will be
C                          M+1 grid points in the X-direction given by
C                          XI=A+(I-1)*DLX for I=1,2,...,M+1 where
C                          DLX=(B-A)/M is the panel width.  M must be
C                          less than IDMN and greater than 5.
C
C                        MBDCND
C                          Indicates the type of boundary condition at
C                          X=A and X=B
C                          = 0 If the solution is periodic in X; i.e.,
C                              U(X+B-A,Y)=U(X,Y) for all Y,X
C                          = 1 If the solution is specified at X=A and
C                              X=B; i.e., U(A,Y) and U(B,Y) are
C                              specified for all Y
C                          = 2 If the solution is specified at X=A and
C                              the boundary condition is mixed at X=B;
C                              i.e., U(A,Y) and dU(B,Y)/dX+BETA*U(B,Y)
C                              are specified for all Y
C                          = 3 If the boundary conditions at X=A and X=B
C                              are mixed; i.e., dU(A,Y)/dX+ALPHA*U(A,Y)
C                              and dU(B,Y)/dX+BETA*U(B,Y) are specified
C                              for all Y
C                          = 4 If the boundary condition at X=A is mixed
C                              and the solution is specified at X=B;
C                              i.e., dU(A,Y)/dX+ALPHA*U(A,Y) and U(B,Y)
C                              are specified for all Y
C
C                        BDA
C                          A one-dimensional array of length N+1 that
C                          specifies the values of dU(A,Y)/dX+
C                          ALPHA*U(A,Y) at X=A, when MBDCND=3 or 4.
C                               BDA(J) = dU(A,YJ)/dX+ALPHA*U(A,YJ);
C                               J=1,2,...,N+1
C                          When MBDCND has any other value, BDA is a
C                          dummy parameter.
C
C On Input               ALPHA
C                          The scalar multiplying the solution in case
C                          of a mixed boundary condition AT X=A (see
C                          argument BDA).  If MBDCND = 3,4 then ALPHA is
C                          a dummy parameter.
C
C                        BDB
C                          A one-dimensional array of length N+1 that
C                          specifies the values of dU(B,Y)/dX+
C                          BETA*U(B,Y) at X=B.  when MBDCND=2 or 3
C                               BDB(J) = dU(B,YJ)/dX+BETA*U(B,YJ);
C                               J=1,2,...,N+1
C                          When MBDCND has any other value, BDB is a
C                          dummy parameter.
C
C                        BETA
C                          The scalar multiplying the solution in case
C                          of a mixed boundary condition at X=B (see
C                          argument BDB).  If MBDCND=2,3 then BETA is a
C                          dummy parameter.
C
C                        C,D
C                          The range of the Y-independent variable;
C                          i.e., Y is greater than or equal to C and
C                          less than or equal to D.  C must be less than
C                          D.
C
C                        N
C                          The number of panels into which the interval
C                          [C,D] is subdivided.  Hence, there will be
C                          N+1 grid points in the Y-direction given by
C                          YJ=C+(J-1)*DLY for J=1,2,...,N+1 where
C                          DLY=(D-C)/N is the panel width.  In addition,
C                          N must be greater than 4.
C
C                        NBDCND
C                          Indicates the types of boundary conditions at
C                          Y=C and Y=D
C                          = 0 If the solution is periodic in Y; i.e.,
C                              U(X,Y+D-C)=U(X,Y) for all X,Y
C                          = 1 If the solution is specified at Y=C and
C                              Y = D, i.e., U(X,C) and U(X,D) are
C                              specified for all X
C                          = 2 If the solution is specified at Y=C and
C                              the boundary condition is mixed at Y=D;
C                              i.e., dU(X,C)/dY and U(X,D)
C                              are specified for all X
C                          = 3 If the boundary conditions are mixed at
C                              Y= C and Y=D i.e., dU(X,D)/DY
C                              and dU(X,D)/dY are specified
C                              for all X
C                          = 4 If the boundary condition is mixed at Y=C
C                              and the solution is specified at Y=D;
C                              i.e. dU(X,C)/dY+GAMA*U(X,C) and U(X,D)
C                              are specified for all X
C
C                        BDC
C                          A one-dimensional array of length M+1 that
C                          specifies the value dU(X,C)/DY
C                          at Y=C.  When NBDCND=3 or 4
C                            BDC(I) = dU(XI,C)/DY
C                             I=1,2,...,M+1.
C                          When NBDCND has any other value, BDC is a
C                          dummy parameter.
C
C
C                        BDD
C                          A one-dimensional array of length M+1 that
C                          specifies the value of dU(X,D)/DY
C                          at Y=D.  When NBDCND=2 or 3
C                            BDD(I)=dU(XI,D)/DY
C                             I=1,2,...,M+1.
C                          When NBDCND has any other value, BDD is a
C                          dummy parameter.
C
C
C                        COFX
C                          A user-supplied subprogram with
C                          parameters X, AFUN, BFUN, CFUN which
C                          returns the values of the X-dependent
C                          coefficients AF(X), BF(X), CF(X) in
C                          the elliptic equation at X.
C                          If boundary conditions in the X direction
C                          are periodic then the coefficients
C                          must satisfy AF(X)=C1,BF(X)=0,CF(X)=C2 for
C                          all X.  Here C1.GT.0 and C2 are constants.
C
C                          Note that COFX must be declared external
C                          in the calling routine.
C
C                        GRHS
C                          A two-dimensional array that specifies the
C                          values of the right-hand side of the elliptic
C                          equation; i.e., GRHS(I,J)=G(XI,YI), for
C                          I=2,...,M; J=2,...,N.  At the boundaries,
C                          GRHS is defined by
C
C                          MBDCND   GRHS(1,J)   GRHS(M+1,J)
C                          ------   ---------   -----------
C                            0      G(A,YJ)     G(B,YJ)
C                            1         *           *
C                            2         *        G(B,YJ)  J=1,2,...,N+1
C                            3      G(A,YJ)     G(B,YJ)
C                            4      G(A,YJ)        *
C
C                          NBDCND   GRHS(I,1)   GRHS(I,N+1)
C                          ------   ---------   -----------
C                            0      G(XI,C)     G(XI,D)
C                            1         *           *
C                            2         *        G(XI,D)  I=1,2,...,M+1
C                            3      G(XI,C)     G(XI,D)
C                            4      G(XI,C)        *
C
C                          where * means these quantities are not used.
C                          GRHS should be dimensioned IDMN by at least
C                          N+1 in the calling routine.
C
C                        USOL
C                          A two-dimensional array that specifies the
C                          values of the solution along the boundaries.
C                          At the boundaries, USOL is defined by
C
C                          MBDCND   USOL(1,J)   USOL(M+1,J)
C                          ------   ---------   -----------
C                            0         *           *
C                            1      U(A,YJ)     U(B,YJ)
C                            2      U(A,YJ)        *     J=1,2,...,N+1
C                            3         *           *
C                            4         *        U(B,YJ)
C
C                          NBDCND   USOL(I,1)   USOL(I,N+1)
C                          ------   ---------   -----------
C                            0         *           *
C                            1      U(XI,C)     U(XI,D)
C                            2      U(XI,C)        *     I=1,2,...,M+1
C                            3         *           *
C                            4         *        U(XI,D)
C
C                          where * means the quantities are not used in
C                          the solution.
C
C                          If IORDER=2, the user may equivalence GRHS
C                          and USOL to save space.  Note that in this
C                          case the tables specifying the boundaries of
C                          the GRHS and USOL arrays determine the
C                          boundaries uniquely except at the corners.
C                          If the tables call for both G(X,Y) and
C                          U(X,Y) at a corner then the solution must be
C                          chosen.  For example, if MBDCND=2 and
C                          NBDCND=4, then U(A,C), U(A,D), U(B,D) must be
C                          chosen at the corners in addition to G(B,C).
C
C                          If IORDER=4, then the two arrays, USOL and
C                          GRHS, must be distinct.
C
C                          USOL should be dimensioned IDMN by at least
C                          N+1 in the calling routine.
C
C                        IDMN
C                          The row (or first) dimension of the arrays
C                          GRHS and USOL as it appears in the program
C                          calling SEPX4.  This parameter is used to
C                          specify the variable dimension of GRHS and
C                          USOL.  IDMN must be at least 7 and greater
C                          than or equal to M+1.
C
C                        W
C                          A one-dimensional array that must be provided
C                          by the user for work space.
C                          10*N+(16+INT(log2(N)))*(M+1)+23 will suffice
C                          as a length for W.  The actual length of
C                          W in the calling routine must be set in W(1)
C                          (see IERROR=11).
C
C On Output              USOL
C                          Contains the approximate solution to the
C                          elliptic equation.  USOL(I,J) is the
C                          approximation to U(XI,YJ) for I=1,2...,M+1
C                          and J=1,2,...,N+1.  The approximation has
C                          error O(DLX**2+DLY**2) if called with
C                          IORDER=2 and O(DLX**4+DLY**4) if called with
C                          IORDER=4.
C
C                        W
C                          W(1) contains the exact minimal length (in
C                          floating point) required for the work space
C                          (see IERROR=11).
C
C                        PERTRB
C                          If a combination of periodic or derivative
C                          boundary conditions (i.e., ALPHA=BETA=0 if
C                          MBDCND=3) is specified and if CF(X)=0 for all
C                          X, then a solution to the discretized matrix
C                          equation may not exist (reflecting the non-
C                          uniqueness of solutions to the PDE).  PERTRB
C                          is a constant calculated and subtracted from
C                          the right hand side of the matrix equation
C                          insuring the existence of a solution.
C                          SEPX4 computes this solution which is a
C                          weighted minimal least squares solution to
C                          the original problem.  If singularity is
C                          not detected PERTRB=0.0 is returned by
C                          SEPX4.
C
C                        IERROR
C                          An error flag that indicates invalid input
C                          parameters or failure to find a solution
C                          = 0  No error
C                          = 1  If A greater than B or C greater than D
C                          = 2  If MBDCND less than 0 or MBDCND greater
C                               than 4
C                          = 3  If NBDCND less than 0 or NBDCND greater
C                               than 4
C                          = 4  If attempt to find a solution fails.
C                               (the linear system generated is not
C                               diagonally dominant.)
C                          = 5  If IDMN is too small (see discussion of
C                               IDMN)
C                          = 6  If M is too small or too large (see
C                               discussion of M)
C                          = 7  If N is too small (see discussion of N)
C                          = 8  If IORDER is not 2 or 4
C                          = 10 If AFUN is less than or equal to zero
C                               for some interior mesh point XI
C                          = 11 If the work space length input in W(1)
C                               is less than the exact minimal work
C                               space length required output in W(1).
C                          = 12 If MBDCND=0 and AF(X)=CF(X)=constant
C                               or BF(X)=0 for all X is not true.
C
C *Long Description:
C
C Dimension of           BDA(N+1), BDB(N+1), BDC(M+1), BDD(M+1),
C Arguments              USOL(IDMN,N+1), GRHS(IDMN,N+1),
C                        W (see argument list)
C
C Latest Revision        October 1980
C
C Special Conditions     NONE
C
C Common Blocks          SPL4
C
C I/O                    NONE
C
C Precision              Single
C
C Required Library       NONE
C Files
C
C Specialist             John C. Adams, NCAR, Boulder, Colorado  80307
C
C Language               FORTRAN
C
C
C Entry Points           SEPX4,SPELI4,CHKPR4,CHKSN4,ORTHO4,MINSO4,TRIS4,
C                        DEFE4,DX4,DY4
C
C History                SEPX4 was developed by modifying the ULIB
C                        routine SEPELI during October 1978.
C                        It should be used instead of SEPELI whenever
C                        possible.  The increase in speed is at least
C                        a factor of three.
C
C Algorithm              SEPX4 automatically discretizes the separable
C                        elliptic equation which is then solved by a
C                        generalized cyclic reduction algorithm in the
C                        subroutine POIS.  The fourth order solution
C                        is obtained using the technique of
C                        deferred corrections referenced below.
C
C
C References             Keller, H.B., 'Numerical Methods for Two-point
C                          Boundary-value Problems', Blaisdel (1968),
C                          Waltham, Mass.
C
C                        Swarztrauber, P., and R. Sweet (1975):
C                          'Efficient FORTRAN Subprograms For The
C                          Solution of Elliptic Partial Differential
C                          Equations'.  NCAR Technical Note
C                          NCAR-TN/IA-109, pp. 135-137.
C
C***REFERENCES  H. B. Keller, Numerical Methods for Two-point
C                 Boundary-value Problems, Blaisdel, Waltham, Mass.,
C                 1968.
C               P. N. Swarztrauber and R. Sweet, Efficient Fortran
C                 subprograms for the solution of elliptic equations,
C                 NCAR TN/IA-109, July 1975, 138 pp.
C***ROUTINES CALLED  CHKPR4, SPELI4
C***REVISION HISTORY  (YYMMDD)
C   801001  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   920122  Minor corrections and modifications to prologue.  (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  SEPX4
C
      DIMENSION       GRHS(IDMN,*)           ,USOL(IDMN,*)
      DIMENSION       BDA(*)     ,BDB(*)     ,BDC(*)     ,BDD(*)     ,
     1                W(*)
      EXTERNAL COFX
C***FIRST EXECUTABLE STATEMENT  SEPX4
      CALL CHKPR4(IORDER,A,B,M,MBDCND,C,D,N,NBDCND,COFX,IDMN,IERROR)
      IF (IERROR .NE. 0) RETURN
C
C     COMPUTE MINIMUM WORK SPACE AND CHECK WORK SPACE LENGTH INPUT
C
      L = N+1
      IF (NBDCND .EQ. 0) L = N
      K = M+1
      L = N+1
C     ESTIMATE LOG BASE 2 OF N
      LOG2N=INT(LOG(REAL(N+1))/LOG(2.0)+0.5)
      LENGTH=4*(N+1)+(10+LOG2N)*(M+1)
      IERROR = 11
      LINPUT = INT(W(1)+0.5)
      LOUTPT = LENGTH+6*(K+L)+1
      W(1) = LOUTPT
      IF (LOUTPT .GT. LINPUT) RETURN
      IERROR = 0
C
C     SET WORK SPACE INDICES
C
      I1 = LENGTH+2
      I2 = I1+L
      I3 = I2+L
      I4 = I3+L
      I5 = I4+L
      I6 = I5+L
      I7 = I6+L
      I8 = I7+K
      I9 = I8+K
      I10 = I9+K
      I11 = I10+K
      I12 = I11+K
      I13 = 2
      CALL SPELI4(IORDER,A,B,M,MBDCND,BDA,ALPHA,BDB,BETA,C,D,N,
     1NBDCND,BDC,BDD,COFX,W(I1),W(I2),W(I3),
     2             W(I4),W(I5),W(I6),W(I7),W(I8),W(I9),W(I10),W(I11),
     3             W(I12),GRHS,USOL,IDMN,W(I13),PERTRB,IERROR)
      RETURN
      END


      PROGRAM xgaujac
C     driver for routine gaujac
      INTEGER NP
      REAL PIBY2
      PARAMETER(NP=64,PIBY2=1.5707963)
      INTEGER i,n
      REAL func,ak,alf,bet,checkw,checkx,ellf,gammln,xx,x(NP),w(NP)
      alf=-.5
      bet=-.5
1     write(*,*) 'Enter N'
      read(*,*,END=99) n
      call gaujac(x,w,n,alf,bet)
      write(*,'(/1x,t3,a,t10,a,t22,a/)') '#','X(I)','W(I)'
      do 11 i=1,n
        write(*,'(1x,i2,2e14.6)') i,x(i),w(i)
11    continue
      checkx=0.
      checkw=0.
      do 12 i=1,n
        checkx=checkx+x(i)
        checkw=checkw+w(i)
12    continue
      write(*,'(/1x,a,e15.7,a,e15.7)') 'Check value:',checkx,
     *  '  should be:',n*(bet-alf)/(alf+bet+2*n)
      write(*,'(/1x,a,e15.7,a,e15.7)') 'Check value:',checkw,
     *  '  should be:',exp(gammln(1.+alf)+gammln(1.+bet)-
     *     gammln(2.+alf+bet))*2**(alf+bet+1.)
C     demonstrate the use of GAUJAC for an integral
      ak=.5
      xx=0.0
      do 13 i=1,n
        xx=xx+w(i)*func(ak,x(i))
13    continue
      write(*,'(/1x,a,f12.6)') 'Integral from GAUJAC:',xx
      write(*,'(1x,a,f12.6)') 'Actual value:        ',2.*ellf(PIBY2,ak)
      go to 1
99    stop
      END
      REAL FUNCTION func(ak,x)
      REAL ak,x
      func=1./sqrt(1.-ak**2*(1.+x)/2.)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xgaujac.for


module functions

    use omp_lib
    implicit none
    integer :: fevals(0:7), gevals(0:7)
    real(kind=8) :: k, c, d
    save

contains

    real(kind=8) function f(x)
        implicit none
        real(kind=8), intent(in) :: x
        integer thread_num, j, ny
        real(kind=8) :: dy,yj

        ! keep track of number of function evaluations by
        ! each thread:
        thread_num = 0   ! serial mode
        !$ thread_num = omp_get_thread_num()
        fevals(thread_num) = fevals(thread_num) + 1

        ny = 1000
        dy = (d-c) / (ny-1)
        f = 0.5d0 * (g(x,c) + g(x,d))
        do j=2,ny-1
            yj = c + (j-1)*dy
            f = f + g(x, yj)
            enddo

        f = dy * f

    end function f

    real(kind=8) function g(x,y)
        implicit none
        real(kind=8), intent(in) :: x,y
        integer thread_num

        ! keep track of number of function evaluations by
        ! each thread:
        thread_num = 0   ! serial mode
        !$ thread_num = omp_get_thread_num()
        gevals(thread_num) = gevals(thread_num) + 1

        g = sin((x+y))

    end function g

end module functions


!--------------------------------------------------
!PHY2063 Assignment 0
!URN 6309823 - Penguin Lab Group 1B
!October 26th 2015
!--------------------------------------------------

!Please note Unable to compile file and test program on Monday
!26th October due to nagfor error "licence not found"
! - tried multiple computers
!Therefore unable to complete assignment in time.

Program A0
  IMPLICIT NONE

  REAL    ::  h,xdash_s,xdash_mid,x_mid,vdash_s,vdash_mid,v_mid,t_mid,k
  INTEGER ::  i

  REAL, DIMENSION(1:1001) :: t
  REAL, DIMENSION(1:1001) :: x
  REAL, DIMENSION(1:1001) :: v
  REAL, DIMENSION(1:1001) :: error_x
  REAL, DIMENSION(1:1001) :: error_v

  !Open Files to store data

  OPEN(unit=12,file='A0.dat')

  WRITE(6,*) "The values of t,x,v,error_x and error_v are"
  WRITE(6,*) "written to the file A0.dat"

  !k=spring_constant h=step v=velocity x=position

  h=5E-3

  !Define initial BCs

  t(1)=0
  v(1)=2
  x(1)=0
  k=5
  error_x(1)=x(1)-0.1*cos((5**0.5)*t(1))
  error_v(1)=v(1)+0.1*(5**0.5)*sin((5**0.5)*t(1))

  WRITE(12,'(5f9.5)') t(1),x(1),v(1),error_x(1),error_v(1)

  !Euler method for integrating two coupled ODEs simultaneously

  DO i=1,10000

  !Use these values at the midpoint

    vdash_s=-k*x(i)+0.5*cos(2*t(i))
    xdash_s=v(i)

    x_mid=x(i)+0.5*h*xdash_s
    v_mid=v(i)+0.5*h*vdash_s
    t_mid=t(i)+0.5*h

    xdash_mid=v_mid
    vdash_mid=-k*x_mid+0.5*cos(2*t_mid)

    !Input these values into the formulae below

    t(i+1)=t(i)+h
    x(i+1)=x(i)+h*xdash_mid
    v(i+1)=v(i)+h*vdash_mid

    error_x(i+1)=x(i+1)-0.1*cos((5**0.5)*t(i+1))
    error_v(i+1)=v(i+1)+0.1*(5**0.5)*sin((5**0.5)*t(i+1))

    !Write the values in the array to A0.dat

    WRITE(12,'(5f9.5)') t(i+1),x(i+1),v(i+1),error_x(i+1),error_v(i+1)
  END DO

  !Run Program
  !Run gnuplot
  !Write "plot "A0.dat" using 1:2 with lines
  !,-5x+0.5cos(2t)" in the terminal
  !to compare the calculated values with the actual graph

END PROGRAM A0


	SUBROUTINE IPSIZE
     .	(ALPHA,POWER,P0,P1,M,R,CASECTRL,ALT,N,NCOR)
!MS$ATTRIBUTES REFERENCE :: N
!MS$ATTRIBUTES REFERENCE :: NCOR
	IMPLICIT NONE

	REAL*4 ALPHA,POWER,P0,P1,M,R
	INTEGER*4 CASECTRL, ALT
	INTEGER*4 N,NCOR
C
C	SAMPLE SIZE CALCULATIONS FOR INDEPENDENT PROPORTIONS
C	DERIVE SAMPLE SIZE FOR EACH GROUP IN A TRIAL OF TWO TREATMENTS
C	OR A CASE-CONTROL STUDY.
C	NORMAL APPROXIMATION ASSUMED
C
C    References:
C     	Fleiss JL:  "Statistical Methods for Rates and Proportions",
C		2nd Ed. NewYork: John Wiley, 1981:38:46.
C       Schlesselman:  Case-control Studies: Design,
C       Conduct, Analysis.  New York: Oxford U. Press 1982: 144-152.
C
C		FRIEDMAN, FURBERG AND DEMETS:
C		FUNDAMENTALS OF CLINICAL TRIALS. BOSTON: WRIGHT PSG. 1982:75.
C
C       Casagrande, Pike, Smith:  An improved approximate formula for
C		calculating sample sizes for comparing two binomial distributions.
C		Biometrics 1978; 34:483-486.
C
C INPUT:
C	ALPHA	TYPE I ERROR probability (TWO TAILED)
C	POWER	The desired statistical power
C	CASECTRL 1 for case-control studies
C			2 for prospective studies
C	P0		True probability of exposure in control group when CASECTL=1
C			True probability of event in control group when CASECTL=2
C	P1		True probability of exposure in case group when CASECTL=1
C			True probability of event in experimental group when CASECTL=2
C	M		Ratio of control to case
C	R		Odds ratio or relative risk.
C	ALT	=1 if input is two proportions
C		=2 if input is other (odds ration or relative risk)
C
C OUTPUT:
C	N		Number of case patients needed to detect a true odds
C			ratio or relative risk R with power POWER and type I
C			error ALPHA
C	NCOR	Corrected case sample size obtained by using the
C			continuity correction of Casagrande et al.
C
C  Locals
C
	REAL ZALPHA,ZCRVALUE,PBAR
C
C Code:
C
	IF (ALT.EQ.2) THEN
	    IF (CASECTRL.EQ.1) THEN
	    	P1=P0*R/(1.+P0*(R-1.))
		ELSE
	    	P1=P0*R
		END IF
	END IF
C
C  Check input arguments.  If there is an error then divide by
C  zero on purpose to signal an error.
C
	IF ( (ALPHA.LE.0.0 .OR. ALPHA.GE.1.0) .OR.
     .       (POWER.LE.0.0 .OR. POWER.GE.1.0) .OR.
     .       (P0.LE.0.0 .OR. P0.GE.1.0) .OR.
     .       (P1.LE.0.0 .OR. P1.GE.1.0) .OR.
     .       (M.LE.0) .OR.
     .       (P1.EQ.P0) ) THEN
		N=CASECTRL/0.0
	END IF

C
C  Calculate the sample size.
C
	ZALPHA=ZCRVALUE(ALPHA/2.)
	PBAR=(P1+M*P0)/(M+1)
	N= NINT( (ZALPHA*SQRT((1.+1./M)*PBAR*(1.-PBAR))+
     . ZCRVALUE(1.-POWER)*SQRT(P0*(1.-P0)/M+P1*(1.-P1)))**2/(P0-P1)**2)
	NCOR=NINT(
     . (FLOAT(N)/4.)*(1.+SQRT(1.+2.*(M+1.)/(FLOAT(N)*M*ABS(P0-P1))))**2)
	RETURN
	END


      subroutine r8mkbicubw(x,nx,y,ny,f,nf2,
     >   ibcxmin,bcxmin,ibcxmax,bcxmax,
     >   ibcymin,bcymin,ibcymax,bcymax,
     >   wk,nwk,
     >   ilinx,iliny,ier)
C
C  setup a bicubic spline; store coefficients in compact form
C  (as per suggestion of L. Zakharov, PPPL, Feb. 1999)
C     4 coeffs per grid point:  f,fxx,fyy,fxxyy
C
C
C  input:
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER itest,iadfp,isiz1,iadfw,inwk
!============
! idecl:  explicitize implicit REAL declarations:
      REAL*8 hxlast,hylast
!============
      integer nx                        ! length of x vector
      integer ny                        ! length of y vector
      REAL*8 x(nx)                        ! x vector, strict ascending
      REAL*8 y(ny)                        ! y vector, strict ascending
C
      integer nf2                       ! 2nd dimension of f, nf2.ge.nx
C  input/output:
C
      REAL*8 f(4,nf2,ny)                  ! data & spline coefficients
C
C  on input:  f(1,i,j) = f(x(i),y(j))
C  on output:  f(1,i,j) unchanged
C              f(2,i,j) = d2f/dx2(x(i),y(j))
C              f(3,i,j) = d2f/dy2(x(i),y(j))
C              f(4,i,j) = d4f/dx2dy2(x(i),y(j))
C
C  and the interpolation formula for (x,y) in (x(i),x(i+1))^(y(j),y(j+1))
C  is:
C        hx = x(i+1)-x(i)   hy = y(j+1)-y(j)
C        dxp= (x-x(i))/hx   dxm= 1-dxp     dxp,dxm in (0,1)
C        dyp= (x-x(i))/hx   dym= 1-dyp     dyp,dym in (0,1)
C        dx3p = dxp**3-dxp  dx3m = dxm**3-dxm     dxp3,dxm3 in (0,1)
C
C   finterp = dxm*(dym*f(1,i,j)+dyp*f(1,i,j+1))
C            +dxp*(dym*f(1,i+1,j)+dyp*f(1,i+1,j+1))
C     +1/6*hx**2*
C            dx3m*(dym*f(2,i,j)+dyp*f(2,i,j+1))
C           +dx3p*(dym*f(2,i+1,j)+dyp*f(2,i+1,j+1))
C     +1/6*hy**2*
C            dxm*(dy3m*f(3,i,j)+dy3p*f(3,i,j+1))
C           +dxp*(dy3m*f(3,i+1,j)+dy3p*f(3,i+1,j+1))
C     +1/36*hx**2*hy**2*
C            dx3m*(dym*f(4,i,j)+dyp*f(4,i,j+1))
C           +dx3p*(dym*f(4,i+1,j)+dyp*f(4,i+1,j+1))
C
C  where the f(2:4,*,*) are cleverly evaluated to assure
C  (a) finterp is continuous and twice differentiable across all
C      grid cell boundaries, and
C  (b) all boundary conditions are satisfied.
C
C  the boundary conditions specification options are:
C  inputs:
C
      integer ibcxmin                   ! bc flag for x=xmin
      REAL*8 bcxmin(ny)                   ! bc data vs. y at x=xmin
      integer ibcxmax                   ! bc flag for x=xmax
      REAL*8 bcxmax(ny)                   ! bc data vs. y at x=xmax
C
      integer ibcymin                   ! bc flag for y=ymin
      REAL*8 bcymin(nx)                   ! bc data vs. x at y=ymin
      integer ibcymax                   ! bc flag for y=ymax
      REAL*8 bcymax(nx)                   ! bc data vs. x at y=ymax
C
C  with interpretation:
c   ibcxmin -- indicator for boundary condition at x(1):
c    bcxmin(...) -- boundary condition data
c     =-1 -- periodic boundary condition
c     =0 -- use "not a knot"
c     =1 -- match slope, specified at x(1),th(ith) by bcxmin(ith)
c     =2 -- match 2nd derivative, specified at x(1),th(ith) by bcxmin(ith)
c     =3 -- boundary condition is slope=0 (df/dx=0) at x(1), all th(j)
c     =4 -- boundary condition is d2f/dx2=0 at x(1), all th(j)
c     =5 -- match 1st derivative to 1st divided difference
c     =6 -- match 2nd derivative to 2nd divided difference
c     =7 -- match 3rd derivative to 3rd divided difference
c           (for more detailed definition of BCs 5-7, see the
c           comments of subroutine mkspline)
c   NOTE bcxmin(...) referenced ONLY if ibcxmin=1 or ibcxmin=2
c
c   ibcxmax -- indicator for boundary condition at x(nx):
c    bcxmax(...) -- boundary condition data
c     (interpretation as with ibcxmin, bcxmin)
c   NOTE:  if ibcxmin=-1, ibcxmax is ignored! ...and the BC is periodic.
c
C  and analogous interpretation for ibcymin,bcymin,ibcymax,bcymax
C  (df/dy or d2f/dy2 boundary conditions at y=ymin and y=ymax).
C
C  *** workspace ***
C  This FORTRAN-77 routine requires a workspace of
C    nwk = (AT LEAST) 21*nx*ny
C  *** for dynamic allocation of this workspace use subroutine mkbicub
C    which has the same arguments as mkbicubw, except that the workspace
C    does not have to be provided -- mkbicub is FORTRAN-90.
C
C  input:
      integer nwk                       ! size of workspace
C  modified on output:
      REAL*8 wk(nwk)                      ! workspace
C
C  and output arguments
C
      integer ilinx                     ! =1: x grid is "nearly" equally spaced
      integer iliny                     ! =1: y grid is "nearly" equally spaced
C
C  ilinx and iliny are set to zero if corresponding grids are not equally
C  spaced
C
C  and completion code
C
      integer ier                       ! =0 on exit if there is no error.
C
C  if there is an error, ier is set and a message is output on unit 6.
C  these are considered programming errors in the calling routine.
C
C  possible errors:
C    x(...) not strict ascending
C    y(...) not strict ascending
C    nx .lt. 4
C    ny .lt. 4
C    invalid boundary condition flag
C    workspace too small
C
C-----------------------------------------------------
C  local arrays
C
      integer iselect(10)
      integer zvalues(10)
C
      data iselect/-1,0,0,0,0,0,0,0,0,0/
C
C-----------------------------------------------------
C
      itest=21*nx*ny
      if(nwk.lt.itest) then
         write(6,9901) nwk,itest
 9901    format(' ?mkbicubw:  workspace too small:'/
     >          '  user supplied:  nwk=',i7,'; need at least:  ',i7/
     >      '  nwk = at least 21*nx*ny is required.')
         ier=1
         return
      endif
C
      iadfp=1
      isiz1=16*nx*ny
      iadfw=iadfp+isiz1
      inwk = nwk-isiz1
C
      call r8mkbicop(f,nf2,wk(iadfp),nx,ny)
C
C  evaluate 4x4 continuous bicubic spline
C
      call r8bcspline(x,nx,y,ny,wk(iadfp),nx,
     >   ibcxmin,bcxmin,ibcxmax,bcxmax,
     >   ibcymin,bcymin,ibcymax,bcymax,
     >   wk(iadfw),inwk,
     >   ilinx,iliny,ier)
C
      if(ier.ne.0) return
C
C  convert to 4-coefficient (2nd/4th partials form)
C
      hxlast=x(nx)-x(nx-1)
      hylast=y(ny)-y(ny-1)
      call r8mkbicon(f,nf2,wk(iadfp),nx,ny,hxlast,hylast)
C
      return
      end
C
C----------------------------------------------------------------
C  mkbicop -- copy spline function input data
C
      subroutine r8mkbicop(fin,nf2,fwk,nx,ny)
C
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER nx,ny,nf2,iy,ix
!============
      REAL*8 fin(4,nf2,ny)
      REAL*8 fwk(4,4,nx,ny)
C
      do iy=1,ny
         do ix=1,nx
            fwk(1,1,ix,iy)=fin(1,ix,iy)
         enddo
      enddo
C
      return
      end
C----------------------------------------------------------------
C  mkbicon -- create compact spline representation from 4x4
C             (bcspline) representation
C
      subroutine r8mkbicon(fin,nf2,fwk,nx,ny,hxlast,hylast)
C
!============
! idecl:  explicitize implicit INTEGER declarations:
      IMPLICIT NONE
      INTEGER, PARAMETER :: R8=SELECTED_REAL_KIND(12,100)
      INTEGER nx,ny,nf2,iy,ix,iflag,ixuse,iyuse,j
!============
! idecl:  explicitize implicit REAL declarations:
      REAL*8 hxlast,hylast,dxuse,dyuse
!============
      REAL*8 fin(4,nf2,ny)
      REAL*8 fwk(4,4,nx,ny)
C
C-----------------------------------------------------
C  local arrays
C
      integer iselect(10)
      REAL*8 zvalues(10)
C
      data iselect/-1,0,0,0,0,0,0,0,0,0/
C
C-----------------------------------------------------
C
      do iy=1,ny
         do ix=1,nx
C
C  copy derivatives from result.  Special treatment needed for end zones
C
            iflag=0
            dxuse=0.0_r8
            dyuse=0.0_r8
            ixuse=ix
            iyuse=iy
            if(ix.eq.nx) then
               iflag=1
               dxuse=hxlast
               ixuse=ix-1
            endif
            if(iy.eq.ny) then
               iflag=1
               dyuse=hylast
               iyuse=iy-1
            endif
C
            if(iflag.eq.1) then
               call r8bcspevfn(iselect,1,1,zvalues,
     >            ixuse,iyuse,dxuse,dyuse,
     >            fwk,nx,ny)
               do j=2,4
                  fin(j,ix,iy)=zvalues(j)
               enddo
            else
               fin(2,ix,iy)=2.0_r8*fwk(3,1,ix,iy)
               fin(3,ix,iy)=2.0_r8*fwk(1,3,ix,iy)
               fin(4,ix,iy)=4.0_r8*fwk(3,3,ix,iy)
            endif
C
         enddo
      enddo
C
      return
      end