module stdlib_quadrature
    !! ([Specification](../page/specs/stdlib_quadrature.html#description))
    use stdlib_kinds, only: sp, dp, qp

    implicit none

    private

    ! array integration
    public :: trapz
    public :: trapz_weights
    public :: simps
    public :: simps_weights
    public :: gauss_legendre
    public :: gauss_legendre_lobatto

    interface trapz
        !! version: experimental
        !!
        !! Integrates sampled values using trapezoidal rule
        !! ([Specification](../page/specs/stdlib_quadrature.html#description))
        pure module function trapz_dx_sp(y, dx) result(integral)
          real(sp), dimension(:), intent(in) :: y
          real(sp), intent(in) :: dx
          real(sp) :: integral
        end function trapz_dx_sp
        pure module function trapz_dx_dp(y, dx) result(integral)
          real(dp), dimension(:), intent(in) :: y
          real(dp), intent(in) :: dx
          real(dp) :: integral
        end function trapz_dx_dp
        pure module function trapz_dx_qp(y, dx) result(integral)
          real(qp), dimension(:), intent(in) :: y
          real(qp), intent(in) :: dx
          real(qp) :: integral
        end function trapz_dx_qp
        module function trapz_x_sp(y, x) result(integral)
            real(sp), dimension(:), intent(in) :: y
            real(sp), dimension(:), intent(in) :: x
            real(sp) :: integral
        end function trapz_x_sp
        module function trapz_x_dp(y, x) result(integral)
            real(dp), dimension(:), intent(in) :: y
            real(dp), dimension(:), intent(in) :: x
            real(dp) :: integral
        end function trapz_x_dp
        module function trapz_x_qp(y, x) result(integral)
            real(qp), dimension(:), intent(in) :: y
            real(qp), dimension(:), intent(in) :: x
            real(qp) :: integral
        end function trapz_x_qp
    end interface trapz

    interface trapz_weights
        !! version: experimental
        !!
        !! Integrates sampled values using trapezoidal rule weights for given abscissas
        !! ([Specification](../page/specs/stdlib_quadrature.html#description_1))
        pure module function trapz_weights_sp(x) result(w)
            real(sp), dimension(:), intent(in) :: x
            real(sp), dimension(size(x)) :: w
        end function trapz_weights_sp
        pure module function trapz_weights_dp(x) result(w)
            real(dp), dimension(:), intent(in) :: x
            real(dp), dimension(size(x)) :: w
        end function trapz_weights_dp
        pure module function trapz_weights_qp(x) result(w)
            real(qp), dimension(:), intent(in) :: x
            real(qp), dimension(size(x)) :: w
        end function trapz_weights_qp
    end interface trapz_weights

    interface simps
        !! version: experimental
        !!
        !! Integrates sampled values using Simpson's rule
        !! ([Specification](../page/specs/stdlib_quadrature.html#description_3))
        ! "recursive" is an implementation detail
        pure recursive module function simps_dx_sp(y, dx, even) result(integral)
            real(sp), dimension(:), intent(in) :: y
            real(sp), intent(in) :: dx
            integer, intent(in), optional :: even
            real(sp) :: integral
        end function simps_dx_sp
        pure recursive module function simps_dx_dp(y, dx, even) result(integral)
            real(dp), dimension(:), intent(in) :: y
            real(dp), intent(in) :: dx
            integer, intent(in), optional :: even
            real(dp) :: integral
        end function simps_dx_dp
        pure recursive module function simps_dx_qp(y, dx, even) result(integral)
            real(qp), dimension(:), intent(in) :: y
            real(qp), intent(in) :: dx
            integer, intent(in), optional :: even
            real(qp) :: integral
        end function simps_dx_qp
        recursive module function simps_x_sp(y, x, even) result(integral)
            real(sp), dimension(:), intent(in) :: y
            real(sp), dimension(:), intent(in) :: x
            integer, intent(in), optional :: even
            real(sp) :: integral
        end function simps_x_sp
        recursive module function simps_x_dp(y, x, even) result(integral)
            real(dp), dimension(:), intent(in) :: y
            real(dp), dimension(:), intent(in) :: x
            integer, intent(in), optional :: even
            real(dp) :: integral
        end function simps_x_dp
        recursive module function simps_x_qp(y, x, even) result(integral)
            real(qp), dimension(:), intent(in) :: y
            real(qp), dimension(:), intent(in) :: x
            integer, intent(in), optional :: even
            real(qp) :: integral
        end function simps_x_qp
    end interface simps

    interface simps_weights
        !! version: experimental
        !!
        !! Integrates sampled values using trapezoidal rule weights for given abscissas
        !! ([Specification](../page/specs/stdlib_quadrature.html#description_3))
        pure recursive module function simps_weights_sp(x, even) result(w)
            real(sp), dimension(:), intent(in) :: x
            integer, intent(in), optional :: even
            real(sp), dimension(size(x)) :: w
        end function simps_weights_sp
        pure recursive module function simps_weights_dp(x, even) result(w)
            real(dp), dimension(:), intent(in) :: x
            integer, intent(in), optional :: even
            real(dp), dimension(size(x)) :: w
        end function simps_weights_dp
        pure recursive module function simps_weights_qp(x, even) result(w)
            real(qp), dimension(:), intent(in) :: x
            integer, intent(in), optional :: even
            real(qp), dimension(size(x)) :: w
        end function simps_weights_qp
    end interface simps_weights

    interface gauss_legendre
        !! version: experimental
        !!
        !! Computes Gauss-Legendre quadrature nodes and weights.
        pure module subroutine gauss_legendre_fp64 (x, w, interval)
            real(dp), intent(out) :: x(:), w(:)
            real(dp), intent(in), optional :: interval(2)
        end subroutine
    end interface gauss_legendre

    interface gauss_legendre_lobatto
        !! version: experimental
        !!
        !! Computes Gauss-Legendre-Lobatto quadrature nodes and weights.
        pure module subroutine gauss_legendre_lobatto_fp64 (x, w, interval)
            real(dp), intent(out) :: x(:), w(:)
            real(dp), intent(in), optional :: interval(2)
        end subroutine
    end interface gauss_legendre_lobatto

    ! Interface for a simple f(x)-style integrand function.
    ! Could become fancier as we learn about the performance
    ! ramifications of different ways to do callbacks.
    abstract interface
        pure function integrand_sp(x) result(f)
            import :: sp
            real(sp), intent(in) :: x
            real(sp) :: f
        end function integrand_sp
        pure function integrand_dp(x) result(f)
            import :: dp
            real(dp), intent(in) :: x
            real(dp) :: f
        end function integrand_dp
        pure function integrand_qp(x) result(f)
            import :: qp
            real(qp), intent(in) :: x
            real(qp) :: f
        end function integrand_qp
    end interface

end module stdlib_quadrature


!
!     CalculiX - A 3-dimensional finite element program
!              Copyright (C) 1998-2021 Guido Dhondt
!
!     This program is free software; you can redistribute it and/or
!     modify it under the terms of the GNU General Public License as
!     published by the Free Software Foundation(version 2);
!
!
!     This program is distributed in the hope that it will be useful,
!     but WITHOUT ANY WARRANTY; without even the implied warranty of
!     MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
!     GNU General Public License for more details.
!
!     You should have received a copy of the GNU General Public License
!     along with this program; if not, write to the Free Software
!     Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
!
      subroutine cubic(a0,a1,a2,solreal,solimag,n)
!
!     solves the cubic equation x**3+a2*x**2+a1*x+a0=0
!     (analytical solution)
!     there are three solutions in C (complex plane)
!     the real part of the solutions is stored in solreal(1..3),
!     the imaginary part in solimag(1..3). The real solutions have
!     the lower indices, their number is n
!
!     Reference: Abramowitz, M. and Stegun, I., Handbook of
!     Mathematical Functions (10th printing, 1972 p 17)
!
      implicit none
!
      integer n
!
      real*8 a0,a1,a2,solreal(3),solimag(3),q,r,d,s1,s2,
     &  a,phi,s1r,s1i
!
      write(30,*) 'a2,a1,a0 ',a2,a1,a0
      q=a1/3.d0-a2*a2/9.d0
      r=(a1*a2-3.d0*a0)/6.d0-(a2**3)/27.d0
!
      d=q**3+r*r
      write(30,*) 'q,r,d ',q,r,d
!
      if(d.gt.0) then
!
!        one real solution, two complex conjugate complex
!        solutions
!
         n=1
         s1=(r+dsqrt(d))**(1.d0/3.d0)
         s2=(r-dsqrt(d))
         if(s2.gt.0.d0) then
            s2=s2**(1.d0/3.d0)
         else
            s2=-(-s2)**(1.d0/3.d0)
         endif
        write(30,*) 'd>0 s1,s2 ',s1,s2
!
         solreal(1)=(s1+s2)-a2/3.d0
         solreal(2)=-(s1+s2)/2.d0-a2/3.d0
         solreal(3)=solreal(2)
!
         solimag(1)=0.d0
         solimag(2)=(s1-s2)*dsqrt(3.d0)/2.d0
         solimag(3)=-solimag(2)
      else
!
!        three real solutions
!
         n=3
!
!        amplitude and phase of s1
!
         a=(r*r-d)**(1.d0/6.d0)
         phi=(datan2(dsqrt(-d),r))/3.d0
c         phi=(datan(dsqrt(-d)/r))/3.d0
        write(30,*) 'd <=0 a,phi ',a,phi
!
!        real and imaginary part of s1
!
         s1r=a*dcos(phi)
         s1i=a*dsin(phi)
        write(30,*) 'd >=0 s1r,s1i ',s1r,s1i
!
         solreal(1)=2.d0*s1r-a2/3.d0
         solreal(2)=-s1r-a2/3.d0-s1i*dsqrt(3.d0)
         solreal(3)=-s1r-a2/3.d0+s1i*dsqrt(3.d0)
!
         solimag(1)=0.d0
         solimag(2)=0.d0
         solimag(3)=0.d0
      endif
!
      return
      end


!> @brief This function returns the linearly interpolated y value between the two supplied points.
!>
!> @param[in] x1 The first x value.
!>
!> @param[in] x2 The second x value.
!>
!> @param[in] y1 The first y value.
!>
!> @param[in] y2 The second y value.
!>
!> @param[in] x The x value where the y value is desired.
!>

ELEMENTAL FUNCTION func_interpolate_REAL32_points(x1, x2, y1, y2, x) RESULT(ans)
    USE ISO_FORTRAN_ENV

    IMPLICIT NONE

    ! Declare input variables ...
    REAL(kind = REAL32), INTENT(in)                                             :: x
    REAL(kind = REAL32), INTENT(in)                                             :: x1
    REAL(kind = REAL32), INTENT(in)                                             :: x2
    REAL(kind = REAL32), INTENT(in)                                             :: y1
    REAL(kind = REAL32), INTENT(in)                                             :: y2

    ! Declare output variables ...
    REAL(kind = REAL32)                                                         :: ans

    ! Calculate value ...
    ans = (y1 * (x2 - x) + y2 * (x - x1)) / (x2 - x1)
END FUNCTION func_interpolate_REAL32_points


module greatcircle
  !!Author   : Masashi Ogiso (masashi.ogiso@gmail.com)
  !!Copyright: (c) Masashi Ogiso 2020
  !!License  : MIT License https://opensource.org/licenses/MIT
  private
  public :: greatcircle_dist, latctog, latgtoc

  contains

  subroutine greatcircle_dist(lat0, lon0, lat1, lon1, delta_out, distance, azimuth, backazimuth)
    use nrtype, only : fp
    use constants, only : pi, r_earth, r2r1, deg2rad, rad2deg
    implicit none

    !!Calculate distance, azimuth, backazimuth using Vincenty (1975, Survey review)
    !!Input: (lat0, lon0) (point A) , (lat1, lon1) (point B)
    !!output: delta(rad), dist(km), az(rad, point A -> point B), baz(rad, point B -> point A)

    real(kind = fp), intent(in) :: lat0, lon0, lat1, lon1
    real(kind = fp), intent(out), optional :: delta_out, distance, azimuth, backazimuth

    real(kind = fp) :: c, b, delta, lat_0, lat_1, sin_lat0, cos_lat0, sin_lat1, cos_lat1, lon_diff, &
    &                  cos_ldiff, sin_ldiff

    !!geographical latitude to geocentral latitude
    call latgtoc(lat0, lat_0)
    call latgtoc(lat1, lat_1)

    sin_lat0 = sin(lat_0)
    cos_lat0 = cos(lat_0)
    sin_lat1 = sin(lat_1)
    cos_lat1 = cos(lat_1)
    lon_diff = (lon1 - lon0) * deg2rad
    cos_ldiff = cos(lon_diff)
    sin_ldiff = sin(lon_diff)
    delta = atan2(sqrt(cos_lat1 * sin_ldiff * cos_lat1 * sin_ldiff &
    &                  + (cos_lat0 * sin_lat1 - sin_lat0 * cos_lat1 * cos_ldiff) &
    &                  * (cos_lat0 * sin_lat1 - sin_lat0 * cos_lat1 * cos_ldiff)), &
    &                  (sin_lat0 * sin_lat1 + cos_lat0 * cos_lat1 * cos_ldiff))

    c = atan2(cos_lat1 * sin_ldiff, cos_lat0 * sin_lat1 - sin_lat0 * cos_lat1 * cos_ldiff)
    if(c .lt. 0.0_fp) c = c + 2.0_fp * pi
    b = pi + atan2(cos_lat0 * sin_ldiff, -sin_lat0 * cos_lat1 + cos_lat0 * sin_lat1 * cos_ldiff)
    if(b .ge. 2.0_fp * pi) b = b - 2.0_fp * pi

    if(present(delta_out)) delta_out = delta
    if(present(distance)) distance = r_earth * delta
    if(present(azimuth)) azimuth = c
    if(present(backazimuth)) backazimuth = b

    return
  end subroutine greatcircle_dist

  subroutine latgtoc(lat_in, lat_out)
    use nrtype, only : fp
    use constants, only : r2r1, deg2rad
    real(kind = fp), intent(in) :: lat_in    !!degree
    real(kind = fp), intent(out) :: lat_out  !!radian

    lat_out = atan(r2r1 * r2r1 * tan(lat_in * deg2rad))
    return
  end subroutine latgtoc

  subroutine latctog(lat_in, lat_out)
    use nrtype, only : fp
    use constants, only : r2r1, deg2rad, rad2deg
    real(kind = fp), intent(in) :: lat_in    !!radian
    real(kind = fp), intent(out) :: lat_out  !!degree

    lat_out = atan(tan(lat_in) / (r2r1 * r2r1)) * rad2deg
    return
  end subroutine latctog

end module greatcircle


      SUBROUTINE lendeg( alat, amlat, amlong)
!     lendeg returns the length, in meters, of a degree of latitude
! and longitude, given the latitude.  The formula is taken from pg. 5
! of Nathaniel Bowditch's "American Practical Navigator", Vol II., 1981
! It is based on the WGS72 ellipsoid.  Note that it's Volume TWO.
! Read the preface of the book, it's worth the time.
! This routine gets different answers from Bowditch on different
! computers, try your computer and insert the results here!
! Use a latitude of 45.0 degrees.
! Bowditch gets lat meters = 111132, long meters = 78847
! Casio fx-450 calculator  = 111132.92           = 78847.306
! Masscomp 5400 (68020)    = 111132              = 78840.3
!
! Paul Henkart, March 1991
! mod 14 Aug 07 - g95 ca't declare and set in same statement,
!
      REAL alat, amlat, amlong
      REAL*8 pi
      DATA pi/3.141592654/
      REAL*8 alatrads
!
      alatrads = ABS(alat) * pi / 180.D0
      amlat = 111132.92D0 - 559.82D0 * DCOS(2.D0*alatrads)
     &      + 1.175D0 * DCOS(4.D0*alatrads)
     &      - 0.0023D0 * DCOS(6.D0*alatrads)
      amlong = 111412.84D0 * DCOS(alatrads)
     &       - 93.5D0 * DCOS(3.D0*alatrads)
     &       + 0.118D0 * DCOS(5.D0*alatrads)
      RETURN
      END
!
!
!
      SUBROUTINE dlendeg( dlat, dmlat, dmlong)
! REAL*8 arguments
      REAL*8 dlat, dmlat, dmlong
      REAL*8 pi
      DATA pi/3.141592654/
      REAL*8 dlatrads
!
      dlatrads = DABS(dlat) * pi / 180.D0
      dmlat = 111132.92D0 - 559.82D0 * DCOS(2.D0*dlatrads)
     &      + 1.175D0 * DCOS(4.D0*dlatrads)
     &      - 0.0023D0 * DCOS(6.D0*dlatrads)
      dmlong = 111412.84D0 * DCOS(dlatrads)
     &       - 93.5D0 * DCOS(3.D0*dlatrads)
     &       + 0.118D0 * DCOS(5.D0*dlatrads)
      RETURN
      END


subroutine linspace(xmin, xmax, n, x)
  ! Outputs n linearly spaced points between xmin and xmax.
  !
  ! Parameters
  ! ---------
  ! xmin : float
  !   Minimum x value.
  ! xmax : float
  !   Maximum x value.
  ! n : int
  !   Number of points.
  !
  ! Returns
  ! -------
  ! x : array
  !   Linearly space points.

  implicit none

  integer, parameter :: dp = kind(1.d0)

  integer, intent(in) :: n
  real(kind=dp), intent(in) :: xmin, xmax
  real(kind=dp), intent(out) :: x(n)

  integer :: i
  real(kind=dp) :: dx

  dx = (xmax-xmin)/(n-1)

  x(1) = xmin

  do i = 2, n
    x(i) = xmin + (i-1)*dx
  end do

end subroutine linspace

subroutine midpoint(x, n, xmid)
  ! Outputs the midpoints of array x
  !
  ! Parameters
  ! ---------
  ! x : array
  !   array values.
  ! n : int
  !   Number of points in x.
  !
  ! Returns
  ! -------
  ! xmid : array
  !   Midpoint of two adjacent points in x.

  implicit none

  integer, parameter :: dp = kind(1.d0)

  integer, intent(in) :: n
  real(kind=dp), intent(in) :: x(n)
  real(kind=dp), intent(out) :: xmid(n-1)

  integer :: i

  do i = 1, n-1
    xmid(i) = 0.5*(x(i) + x(i+1))
  end do

end subroutine midpoint


module spherical_mod
    !!
    !! Useful routines for computation on sphere
    !!
    use global_mod, only: dp, ip, radius_earth, force_double, pi
    implicit none

    real(dp), parameter :: DEG2RAD = pi /180.0_dp
    !! Convert degrees to radians
    real(dp), parameter :: EARTH_ANGULAR_FREQ = 2.0_dp * pi / (3600.0_dp * 24.0_dp)
    !! Radians/second of earth rotation

    contains

    elemental function area_lonlat_rectangle(lon1, lat1, dlon, dlat, flat) result (area_sp)
        !! Compute the area on a sphere of a 'rectangle' bounded by lines of
        !! constant latitude and longitude, defined by lon1, lon1+dlon, lat1, lat1+dlat.
        !! Here lon1, lat1 must be the lower-left corner.
        !!
        !! The input parameters are in degrees, with latitude ranging from -90 to 90.
        !!
        !! Solution is explained here
        !! http://mathforum.org/library/drmath/view/63767.html
        !!
        !! Note similarity with area = R^2 cos(lat) * dlat * dlon.
        !! The equation here is similar if we note [sin(lat+dlat)-sin(lat)]/dlat = cos(lat)
        !! as dlat --> 0.
        !! If flat=.true. then we use the 'cos' formula, but if flat=.FALSE. (default) we do not.
        real(dp), intent(in):: lon1, lat1, dlon, dlat
        logical, optional, intent(in):: flat
        real(dp) :: area_sp
        logical:: flat_flag
        real(force_double):: sin1, sin2

        if(present(flat)) then
            flat_flag = flat
        else
            flat_flag = .FALSE.
        end if

        if(flat_flag) then
            area_sp = radius_earth * radius_earth * &
                cos((lat1 + 0.5_dp*dlat)*DEG2RAD) * abs(dlat) * DEG2RAD *&
                mod(abs(dlon), 360.0_dp)*DEG2RAD
        else
            ! Here with single precision, we make an effort to avoid
            ! cancellation in the diff(sin) term. Otherwise in the unit-tests,
            ! we would need different error tol's for single and double dp
            sin1 = sin(real(lat1, force_double)*real(DEG2RAD, force_double))
            sin2 = sin((real(lat1, force_double) + real(dlat, force_double)) * real(DEG2RAD, force_double))
            area_sp = radius_earth * radius_earth * &
                abs( sin1 - sin2 ) * &
                mod(abs(dlon), 360.0_dp)*DEG2RAD
        end if

    end function

    subroutine test_spherical_mod()
        !! Unit tests
        real(dp):: lon1, lon2, lat1, lat2, area
        real(dp):: ans
        ! the test cases assume this radius
        real(dp), parameter:: test_radius = 6378137.0_dp
        real(dp), parameter:: radius_adjustment_factor = (test_radius/radius_earth)**2

        !! Test 1
        ans = 12391399902.0_dp
        lon1 = 0.0_dp
        lon2 = 1.0_dp
        lat1 = 0.0_dp
        lat2 = 1.0_dp

        area = area_lonlat_rectangle(lon1, lat1, 1.0_dp, 1.0_dp)

        if(abs(area*radius_adjustment_factor - ans) < 1.0e-06_dp * ans ) then
            print*, 'PASS'
        else
            print*, 'FAIL'
        end if

        ! Test 1.5 -- 'flat' case
        ans = radius_earth * radius_earth * cos(0.5_dp * DEG2RAD) * 1.0_dp * DEG2RAD * 1.0_dp * DEG2RAD
        area = area_lonlat_rectangle(lon1, lat1, 1.0_dp, 1.0_dp, .TRUE.)
        if(abs(area - ans) < 1.0e-06_dp * ans) then
            print*, 'PASS'
        else
            print*, 'FAIL'
        end if

        !! Test 2
        ans = 3379082.32316_dp
        lon1 = 108.0_dp
        lon2 = 108.0_dp + 1.0_dp/60.0_dp
        lat1 = -11.0_dp
        lat2 = -11.0_dp + 1.0_dp/60.0_dp

        area = area_lonlat_rectangle(lon1, lat1, 1.0_dp/60.0_dp, 1.0_dp/60.0_dp)

        if(abs(area*radius_adjustment_factor - ans) < 1.0e-06_dp * ans) then
            print*, 'PASS'
        else
            print*, 'FAIL', area * radius_adjustment_factor, ans
        end if

        !! Test 3
        ans = 1689517.29722_dp
        lon1 = 108.0_dp
        lon2 = 108.0_dp + 1.0_dp/60.0_dp
        lat1 = -11.0_dp
        lat2 = -11.0_dp + 1.0_dp/120.0_dp

        area = area_lonlat_rectangle(lon1, lat1, 1.0_dp/60.0_dp, 1.0_dp/120.0_dp)

        if(abs(area*radius_adjustment_factor - ans) < 1.0e-06_dp * ans) then
            print*, 'PASS'
        else
            print*, 'FAIL', area * radius_adjustment_factor, ans
        end if

    end subroutine

end module


C ****************************************************************************
C  FILE: mpi_pi_send.f
C  DESCRIPTION:
C    MPI pi Calculation Example - Fortran Version
C    Point-to-Point Communication example
C    This program calculates pi using a "dartboard" algorithm.  See
C    Fox et al.(1988) Solving Problems on Concurrent Processors, vol.1
C    page 207.  All processes contribute to the calculation, with the
C    master averaging the values for pi. SPMD Version:  Conditional
C    statements check if the process is the master or a worker.
C    This version uses low level sends and receives to collect results
C    Note: Requires Fortran90 compiler due to random_number() function
C  AUTHOR: Blaise Barney. Adapted from Ros Leibensperger, Cornell Theory
C   Center. Converted to MPI: George L. Gusciora, MHPCC (1/95)
C  LAST REVISED: 06/13/13 Blaise Barney
C ****************************************************************************
C Explanation of constants and variables used in this program:
C   DARTS          = number of throws at dartboard
C   ROUNDS         = number of times "DARTS" is iterated
C   MASTER         = task ID of master task
C   taskid         = task ID of current task
C   numtasks       = number of tasks
C   homepi         = value of pi calculated by current task
C   pi             = average of pi for this iteration
C   avepi          = average pi value for all iterations
C   pirecv         = pi received from worker
C   pisum          = sum of workers' pi values
C   seednum        = seed number - based on taskid
C   source         = source of incoming message
C   mtype          = message type
C   i, n           = misc

      program pi_send
      include 'mpif.h'

      integer DARTS, ROUNDS, MASTER
      parameter(DARTS = 100000)
      parameter(ROUNDS = 1000)
      parameter(MASTER = 0)

      integer 	taskid, numtasks, source, mtype, i, n,
     &          status(MPI_STATUS_SIZE)
      real*4	seednum
      real*8 	homepi, pi, avepi, pirecv, pisum, dboard

C     Obtain number of tasks and task ID
      call MPI_INIT( ierr )
      call MPI_COMM_RANK( MPI_COMM_WORLD, taskid, ierr )
      call MPI_COMM_SIZE( MPI_COMM_WORLD, numtasks, ierr )
      write(*,*)'task ID = ', taskid

      avepi = 0

      do 40 i = 1, ROUNDS
C     Calculate pi using dartboard algorithm
      homepi = dboard(DARTS)

C     ******************** start of worker section ***************************
C     All workers send result to master.  Steps include:
C     -set message type equal to this round number
C     -set message size to 8 bytes (size of real8)
C     -send local value of pi (homepi) to master task
      if (taskid .ne. MASTER) then
        mtype = i
        sbytes = 8
        call MPI_SEND( homepi, 1, MPI_DOUBLE_PRECISION, MASTER, i,
     &                 MPI_COMM_WORLD, ierr )

C     ******************** end of worker section *****************************
      else
C     ******************** start of master section **************************
C     Master receives messages from all workers.  Steps include:
C     -set message type equal to this round
C     -set message size to 8 bytes (size of real8)
C     -receive any message of type mytpe
C     -keep running total of pi in pisum
C     Master then calculates the average value of pi for this iteration
C     Master also calculates and prints the average value of pi over all
C     iterations
        mtype = i
        sbytes = 8
        pisum = 0
        do 30 n = 1, numtasks-1
          call MPI_RECV( pirecv, 1, MPI_DOUBLE_PRECISION,
     &       MPI_ANY_SOURCE, mtype, MPI_COMM_WORLD, status, ierr )
          pisum = pisum + pirecv
 30     continue
        pi = (pisum + homepi)/numtasks
        avepi = ((avepi*(i-1)) + pi) / i
!        write(*,32) DARTS*i, avepi
! 32     format('   After ',i9,' throws, average value of pi = ',f10.8)
C    ********************* end of master section ****************************
      endif
 40   continue

      if (taskid .eq. MASTER) then
        print *, ' '
        print *,'Real value of PI: 3.1415926535897'
        print *, ' '
      endif

      call MPI_FINALIZE(ierr)

      end

C *****************************************************************************
C function dboard.f
C DESCRIPTION:
C   Used in pi calculation example codes.
C   See mpi_pi_send.f and mpi_pi_reduce.f
C   Throw darts at board.  Done by generating random numbers
C   between 0 and 1 and converting them to values for x and y
C   coordinates and then testing to see if they "land" in
C   the circle."  If so, score is incremented.  After throwing the
C   specified number of darts, pi is calculated.  The computed value
C   of pi is returned as the value of this function, dboard.
C   Note: Requires Fortran90 compiler due to random_number() function
C
C Explanation of constants and variables used in this function:
C   darts    	= number of throws at dartboard
C   score	= number of darts that hit circle
C   n		= index variable
C   r  		= random number between 0 and 1
C   x_coord	= x coordinate, between -1 and 1
C   x_sqr	= square of x coordinate
C   y_coord	= y coordinate, between -1 and 1
C   y_sqr	= square of y coordinate
C   pi		= computed value of pi
C **************************************************************************/

      real*8    function dboard(darts)
      integer   darts, score, n
      real*4	r
      real*8	x_coord, x_sqr, y_coord, y_sqr, pi

      score = 0

C     "throw darts at the board"
      do 10 n = 1, darts
C     generate random numbers for x and y coordinates
        call random_number(r)
        x_coord = (2.0 * r) - 1.0
	x_sqr = x_coord * x_coord

        call random_number(r)
        y_coord = (2.0 * r) - 1.0
	y_sqr = y_coord * y_coord

C       if dart lands in circle, increment score
	if ((x_sqr + y_sqr) .le. 1.0) then
	  score = score + 1
        endif

 10   continue

C     calculate pi
      pi = 4.0 * score / darts
      dboard = pi
      end


!*********************************************************
!>
! A number of constants used in math and physics
!

module nfConstants
  implicit none

  integer, parameter :: sp = selected_real_kind(6, 37)
  integer, parameter :: dp = selected_real_kind(15, 307)
  integer, parameter :: qp = selected_real_kind(33, 4931)

  ! Math constants

  ! Pi
  real(dp), parameter :: pi_ = 2.d0*acos(0.d0)

  ! Eulers number
  real(dp), parameter :: e_ = exp(1.d0)

  ! Euler-Mascheroni constant
  real(dp), parameter :: em_ = 0.57721566490153286d0

  ! Complex i
  complex(dp), parameter :: i_ = (0,1)

  ! Physics constants

  ! Speed of light in m/s
  real(dp), parameter :: c_ = 2.99792458d8
  ! Speed of light in cm/s (cgs units)
  real(dp), parameter :: c_cgs_ = 2.99792458d10

  ! Planck constant in J*s
  real(dp), parameter :: h_ = 6.626070040d-34
  ! Reduced Planck constant, h/2*pi, in J*s
  real(dp), parameter :: hbar_ = 1.054571800d-34
  ! Planck constant in eV*s
  real(dp), parameter :: h_eV_ = 4.135667662d-15
  ! Reduced Planck constant, \(h/2\pi\), in \(eV\) \(s\)
  real(dp), parameter :: hbar_eV_ = 6.582119514d-16
  ! Planck constant in \(erg\) \(s\) (cgs units)
  real(dp), parameter :: h_cgs_ = 6.626070040d-27
  ! Reduced Planck constant, \(h/2\pi\), in \(erg\) \(s\) (cgs units)
  real(dp), parameter :: hbar_cgs_ = 1.054571800d-27
  ! Reduced Planck constant, \(hc/2\pi\), in \(MeV\) \(fm\)
  real(dp), parameter :: hbarc_ = 197.3269788d0

  ! Gravitational constant in m^3 kg^-1 s^-2
  real(dp), parameter :: G_ = 6.6743d-11
  ! Gravitational constant in cm^3 g^-1 s^-2 (dyne cm^2 g^-2) (cgs units)
  real(dp), parameter :: G_cgs_ = 6.6743d-8

  ! Mass of electron in g (cgs units)
  real(dp), parameter :: me_ = 9.10938356d-28
  ! Mass of muon in g (cgs units)
  real(dp), parameter :: mmu_ = 1.883531594d-25
  ! Mass of tau in g (cgs units)
  real(dp), parameter :: mtau_ = 3.16747d-24
  ! Mass of proton in g (cgs units)
  real(dp), parameter :: mp_ = 1.672621898d-24
  ! Mass of neutron in g (cgs units)
  real(dp), parameter :: mn_ = 1.674927471d-24
  ! Mass of alpha particle in g (cgs units)
  real(dp), parameter :: malpha_ = 6.644657230d-24
  ! Atomic mass unit in g (cgs units)
  real(dp), parameter :: amu_ = 1.660539d-24

  ! Bohr radius in cm (cgs units)
  real(dp), parameter :: bohrr_ = 5.2917721067d-9
  ! Fine-structure constant
  real(dp), parameter :: alpha_ = 7.2973525664d-3
  ! Hartree energy in J
  real(dp), parameter :: eHartree_ = 4.359744650d-18
  ! Hartree energy in eV
  real(dp), parameter :: eHartree_eV_ = 27.21138602d0

  ! Avagadro's number
  real(dp), parameter :: na_ = 6.0221367d23
  ! Boltzmann constant in J K^-1
  real(dp), parameter :: k_ = 1.38064852d-23
  ! Faraday constant in C mol^-1
  real(dp), parameter :: F_ = 96485.33289d0
  ! Rydberg constant in m^-1
  real(dp), parameter :: ryd_ = 10973731.568508d0
  ! Stefan-Boltzmann constant in W m^-2 K^-4
  real(dp), parameter :: stefboltz_ = 5.670367d-8
  ! Wien displacement law constant in m K
  real(dp), parameter :: wiend_ = 2.8977729d-3

  ! Electric charge in C
  real(dp), parameter :: ec_ = 1.6021766208d-19
  ! Electric charge in cm^{3/2} g^{1/2} s^-1 (cgs units)
  real(dp), parameter :: ec_cgs_ = 4.8032d-10
  ! Electron volt in J
  real(dp), parameter :: ev_ = 1.6021766208d-19
  ! Electron volt in erg (cgs units)
  real(dp), parameter :: ev_cgs_ = 1.60217733d-12

  ! Electric constant (vacuum permittivity) in F m^-1
  real(dp), parameter :: epsilon0_ = 8.854187817d-12
  ! Magnetic constant (vacuum permeability) in N A^-2
  real(dp), parameter :: mu0_ = 1.2566370614d-6

  ! Solar mass in g
  real(dp), parameter :: msolar_ = 1.988435d33
  ! Solar radius in cm
  real(dp), parameter :: rsolar_ = 6.955d10
  ! Solar luminosity in erg s^-1
  real(dp), parameter :: lumsolar_ = 3.839d33
  ! Astronomical Unit in cm
  real(dp), parameter :: au_ = 1.49597870700d13

end module nfConstants


program main

use euler

implicit none

        integer (int64), parameter :: MAXIMUM = 100;
        integer (int64) :: sqr_sum, sum_, i;

        sqr_sum = 0;
        sum_ = 0;

        do i = 0, MAXIMUM, 1
                call inc(sqr_sum, i**2);
                call inc(sum_, i);
        end do

        call printint(sum_**2 - sqr_sum);

end program main


program ChiTest
  use GSLMiniBind
  use iso_c_binding
  implicit none

  real, dimension(5) :: dset1 = (/ 199809., 200665., 199607., 200270., 199649. /)
  real, dimension(5) :: dset2 = (/ 522573., 244456., 139979.,  71531.,  21461. /)

  real :: dist, prob
  integer :: dof

  print *, "Dataset 1:"
  print *, dset1
  dist = chi2UniformDistance(dset1)
  dof = size(dset1) - 1
  write(*, '(A,I4,A,F12.4)') 'dof: ', dof, '   distance: ', dist
  prob = chi2Probability(dof, dist)
  write(*, '(A,F9.6)') 'probability: ', prob
  write(*, '(A,L)') 'uniform? ', chiIsUniform(dset1, 0.05)

  ! Lazy copy/past :|
  print *, "Dataset 2:"
  print *, dset2
  dist = chi2UniformDistance(dset2)
  dof = size(dset2) - 1
  write(*, '(A,I4,A,F12.4)') 'dof: ', dof, '   distance: ', dist
  prob = chi2Probability(dof, dist)
  write(*, '(A,F9.6)') 'probability: ', prob
  write(*, '(A,L)') 'uniform? ', chiIsUniform(dset2, 0.05)

contains

function chi2Probability(dof, distance)
  real :: chi2Probability
  integer, intent(in) :: dof
  real, intent(in) :: distance

  ! in order to make this work, we need linking with GSL library
  chi2Probability = gsl_sf_gamma_inc(real(0.5*dof, c_double), real(0.5*distance, c_double))
end function chi2Probability

function chiIsUniform(dset, significance)
  logical :: chiIsUniform
  real, dimension(:), intent(in) :: dset
  real, intent(in) :: significance

  integer :: dof
  real :: dist

  dof = size(dset) - 1
  dist = chi2UniformDistance(dset)
  chiIsUniform = chi2Probability(dof, dist) > significance
end function chiIsUniform

function chi2UniformDistance(ds)
  real :: chi2UniformDistance
  real, dimension(:), intent(in) :: ds

  real :: expected, summa = 0.0

  expected = sum(ds) / size(ds)
  summa = sum( (ds - expected) ** 2 )

  chi2UniformDistance = summa / expected
end function chi2UniformDistance

end program ChiTest


! Math Algorithms
!
! Purpose:       Program that calculates the roots of polynomial equations up to the second degree
! Language:      Fortran 95
! Author:        José Cintra
! Year:          2020
! Web Site:      https://github.com/JoseCintra/MathAlgorithms
! License:       Unlicense, described in http://unlicense.org
! Online demo:   https://onlinegdb.com/S1SvELfLd

PROGRAM Equation

   ! Variables
   IMPLICIT NONE
   REAL :: a,b,c  ! Coefficients of the equation
   REAL :: x1,x2  ! Roots of the equation
   REAL :: delta  ! For Bhaskara formula

   ! Data entry
   ! Change these Coefficients to test other input values
   a = 3
   b = 4
   c = 0

   ! Calculations
   PRINT *,""
   WRITE (*,'(a)') "The roots of that equation are:"
   IF (a == 0 .AND. b == 0) THEN
     WRITE (*,'(a)') "Invalid coefficients."
   ELSE IF (a == 0) THEN ! First degree equation
      x1 = -c/b
      PRINT *, x1
   ELSE ! Second degree equation
      delta = b*b -4*a*c
      IF (delta < 0) THEN
        WRITE (*,'(a)') "This equation has no real roots."
      ELSE
        x1 = (-b + sqrt(delta)) / (2*a)
        x2 = (-b - sqrt(delta)) / (2*a)
        PRINT *, x1
        PRINT *, x2
      END IF
   END IF

   ! END
   PRINT *,""
   WRITE (*, '(a)') "END of execution"

END PROGRAM Equation


Module Fortranpi
USE MPI
IMPLICIT NONE
contains
subroutine dboard(darts, dartsscore)
  integer, intent(in)                    :: darts
  double precision, intent(out)          :: dartsscore
  double precision                       :: x_coord, y_coord
  integer                                :: score, n

score = 0
do n = 1, darts
  call random_number(x_coord)
  call random_number(y_coord)

  if ((x_coord**2 + y_coord**2) <= 1.0d0) then
  score = score + 1
  end if
end do

dartsscore = 4.0d0*score/darts

end subroutine dboard

subroutine pi(avepi, DARTS, ROUNDS) bind(C, name="pi_")
  use, intrinsic                         :: iso_c_binding, only : c_double, c_int
  real(c_double), intent(out)            ::  avepi
  integer(c_int), intent(in)             ::  DARTS, ROUNDS
  integer                                ::  MASTER, rank, i, n
  integer, allocatable                   ::  seed(:)
  double precision                       ::  pi_est, homepi, pirecv, pisum

! we set it to zero in the sequential run
rank = 0
! initialize the random number generator
! we make sure the seed is different for each task
call random_seed()
call random_seed(size = n)
allocate(seed(n))
seed = 12 + rank*11
call random_seed(put=seed(1:n))
deallocate(seed)

avepi = 0
do i = 0, ROUNDS-1
  call dboard(darts, pi_est)
  ! calculate the average value of pi over all iterations
  avepi = ((avepi*i) + pi_est)/(i + 1)
end do
end subroutine pi

subroutine snowpi(avepi, DARTS, ROUNDS, proc_num, numprocs) bind(C, name="snowpi_")
use, intrinsic                         :: iso_c_binding, only : c_double, c_int
real(c_double), intent(out)            :: avepi
integer(c_int), intent(in)             :: DARTS, ROUNDS, proc_num, numprocs
integer                                :: i, n, mynpts
integer, allocatable                   :: seed(:)
double precision                       :: pi_est

  if (proc_num .eq. 1) then
	  mynpts = ROUNDS - (numprocs-1)*(ROUNDS/numprocs)
    else
      mynpts = ROUNDS/numprocs
  endif

  ! initialize the random number generator
  ! we make sure the seed is different for each task
  call random_seed()
  call random_seed(size = n)
  allocate(seed(n))
  seed = 12 + proc_num*11
  call random_seed(put=seed(1:n))
  deallocate(seed)

  avepi=0.0d0
    do i = 0, mynpts-1
      call dboard(darts, pi_est)
      ! calculate the average value of pi over all iterations
      avepi = ((avepi*i) + pi_est)/(i + 1)
  end do

end subroutine snowpi

end module Fortranpi


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! BKMATH Module
! Author: Brian Krauth, Simon Fraser University
!
! Mathematical procedures related to SMLE program.  All real-valued functions
! work in either single or double precision; results will be of same type as
! inputs.
!
! Public procedures available (by category) are:
!
!   Probability and statistics:
!
!	PDFN(x):	Standard normal PDF of x. For PDFN, CDFN,
!			and CDFINVN, x can be scalar, vector, or
!			2-dimensional matrix.  Result will be in
!			same type as x.
!	CDFN(x):	Standard normal CDF of x
! 	CDFINVN(x):	Inverse standard normal CDF of x
!	CHOL(x):	Cholesky decomposition of x, assuming
!			x is symmetric and positive definite.
!	OLS(x,y):	OLS coefficients for a regression of y on x.
!	RANDINT(n):	Vector of n random integers between 1 and n.
!
!
!   Combinatorics:
!
!	FACTORIAL(x):	Factorial of x (i.e., x!)
!	NCHOOSEK(n,k):	(n!)/(k!(n-k)!)
!
!   Halton sequences (Halton sequences give an improvement over random numbers for simulation-based
!	estimation.  See Kenneth Train's book for more information):
!
!	FIND_PRIMES(n):		Gives the first n prime numbers.  DOES IT INCLUDE 2?
!	HMAT(r,c):		Gives an r-by-c matrix of Halton sequences
!	HALTON_SEQUENCE(n,s):	Gives a Halton sequence.
!	RHALT(r,c):		Gives an r-by-c matrix of randomized Halton sequences
!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
module bkmath
use bklib, only : SP, DP, runif
implicit none
private
private :: pdfns0,pdfnd0,pdfns1,pdfns2,pdfnd1,pdfnd2, &
     cdfn0,cdfn1,cdfn2,cdfn0d,cdfn1d,cdfn2d, &
     cdfinvn0,cdfinvn1,cdfinvn2,cdfinvn0d,cdfinvn1d,cdfinvn2d, &
     chols,chold,olss,olsd,factorial0,factorial1,nchoosek0,nchoosek1, &
     swap,outerprod,outerand,inversed
public :: pdfn,cdfn,cdfinvn,chol,ols,randint,factorial,nchoosek,find_primes, &
     hmat,halton_sequence,rhalt,inverse
interface pdfn
   module procedure pdfns0,pdfnd0,pdfns1,pdfns2,pdfnd1,pdfnd2
end interface
interface cdfn
   module procedure cdfn0,cdfn1,cdfn2,cdfn0d,cdfn1d,cdfn2d
end interface
interface cdfinvn
   module procedure cdfinvn0,cdfinvn1,cdfinvn2,cdfinvn0d,cdfinvn1d,cdfinvn2d
end interface
interface chol
   module procedure chols,chold
end interface
interface ols
   module procedure olss,olsd
end interface
interface factorial
   module procedure factorial0,factorial1
end interface
interface nchoosek
   module procedure nchoosek0,nchoosek1
end interface
interface inverse
   module procedure inversed
end interface

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
contains
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

subroutine inversed(a)
  real(kind=DP), dimension(:,:), intent(inout) :: a
  integer, dimension(size(a,1)) :: ipiv,indxr,indxc
  logical, dimension(size(a,1)) :: lpiv
  real(kind=DP) :: pivinv
  real(kind=DP), dimension(size(a,1)) :: dumc
  integer, target, dimension(2) :: irc
  integer :: i,l,n
  integer, pointer :: irow,icol
  n=size(a,1)
  irow => irc(1)
  icol => irc(2)
  ipiv=0
  do i=1,n
     lpiv = (ipiv==0)
     irc = maxloc(abs(a),outerand(lpiv,lpiv))
     ipiv(icol)=ipiv(icol)+1
     if (ipiv(icol) > 1) stop "Singular matrix"
     if (irow /= icol) then
        call swap(a(irow,:),a(icol,:))
     end if
     indxr(i) = irow
     indxc(i) = icol
     if (a(icol,icol)==0.0_dp) stop "Singular matrix"
     pivinv=1.0_dp/a(icol,icol)
     a(icol,icol)=1.0_dp
     a(icol,:)=a(icol,:)*pivinv
     dumc=a(:,icol)
     a(:,icol)=0.0_dp
     a(icol,icol)=pivinv
     a(1:(icol-1),:)=a(1:(icol-1),:)-outerprod(dumc(1:(icol-1)),a(icol,:))
     a(icol+1:,:)=a(icol+1:,:)-outerprod(dumc(icol+1:),a(icol,:))
  end do
  do l=n,1,-1
     call swap(a(:,indxr(l)),a(:,indxc(l)))
  end do
end subroutine inversed

subroutine swap(a,b)
  real(kind=DP), dimension(:), intent(inout) :: a,b
  real(kind=DP), dimension(size(a))  :: dum
  dum=a
  a=b
  b=dum
end subroutine swap

function outerprod(a,b) result (outer)
  real(kind=DP), dimension(:), intent(in) :: a,b
  real(kind=DP), dimension(size(a),size(b)) :: outer
  outer = spread(a,dim=2,ncopies=size(b))*spread(b,dim=1,ncopies=size(a))
end function outerprod

function outerand(a,b) result (outer)
  logical, dimension(:), intent(in) :: a,b
  logical, dimension(size(a),size(b)) :: outer
  outer = spread(a,dim=2,ncopies=size(b)) .and. spread(b,dim=1,ncopies=size(a))
end function outerand

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! PDFN function
!
! Format: pdfn(x)
!
! Gives standard normal PDF of x.
!
! X can be either single or double precision, and can be a scalar,
! vector, or 2-dimensional array.  The output
! vector will be the same type as X.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
pure function pdfns0(a) result (pdfn)
  real(kind=SP), intent(in) :: a
  real(kind=SP) :: pdfn
  real(kind=SP), parameter :: pi=3.14159265 ! 3589793238462643
  pdfn = exp((-a**2)/2.0)/((2.0*pi)**0.5)
end function pdfns0
pure function pdfnd0(a) result (pdfn)
  real(kind=DP), intent(in) :: a
  real(kind=DP) :: pdfn
  real(kind=DP), parameter :: pi=3.14159265358979323_dp ! 8462643d0
  pdfn = exp((-a**2)/2.0_dp)/((2.0_dp*pi)**0.5_dp)
end function pdfnd0
pure function pdfns1(a) result (pdfn)
  real(kind=SP), dimension(:), intent(in) :: a
  real(kind=SP), dimension(size(a)) :: pdfn
  real(kind=SP), parameter :: pi=3.14159265 ! 3589793238462643
  pdfn = exp((-a**2)/2.0)/((2.0*pi)**0.5)
end function pdfns1
pure function pdfnd1(a) result (pdfn)
  real(kind=DP), dimension(:), intent(in) :: a
  real(kind=DP), dimension(size(a)) :: pdfn
  real(kind=DP), parameter :: pi=3.14159265358979323_dp ! 8462643d0
  pdfn = exp((-a**2)/2.0_dp)/((2.0_dp*pi)**0.5_dp)
end function pdfnd1
pure function pdfns2(a) result (pdfn)
  real(kind=SP), dimension(:,:), intent(in) :: a
  real(kind=SP), dimension(size(a,1),size(a,2)) :: pdfn
  real(kind=SP), parameter :: pi=3.14159265 ! 3589793238462643
  pdfn = exp((-a**2)/2.0)/((2.0*pi)**0.5)
end function pdfns2
pure function pdfnd2(a) result (pdfn)
  real(kind=DP), dimension(:,:), intent(in) :: a
  real(kind=DP), dimension(size(a,1),size(a,2)) :: pdfn
  real(kind=DP), parameter :: pi=3.14159265358979323_dp ! 8462643d0
  pdfn = exp((-a**2)/2.0_dp)/((2.0_dp*pi)**0.5_dp)
end function pdfnd2

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! CDFN function
!
! Format: cdfn(x)
!
! Gives standard normal CDF of x.
!
! X can be either single or double precision, and can be a scalar,
! vector, or 2-dimensional array.  The output
! vector will be the same type as X.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function cdfn0(x) result(cdfn)
  real, intent(in) :: x
  real :: cdfn
  cdfn = real(cdfn0d(real(x,kind=DP)),kind=SP)
end function cdfn0
function cdfn1(x) result(cdfn)
  real, dimension(:), intent(in) :: x
  real, dimension(size(x)) :: cdfn
  cdfn=real(cdfn1d(real(x,kind=DP)),kind=SP)
end function cdfn1
function cdfn2(x) result(cdfn)
  real, dimension(:,:), intent(in) :: x
  real, dimension(Size(x,1),Size(x,2)) :: cdfn
  real, dimension(Size(x,1)*Size(x,2)) :: tmpx
  tmpx = reshape(x,(/ size(x,1)*size(x,2) /))
  tmpx = cdfn1(tmpx)
  cdfn = reshape(tmpx,(/ size(x,1), size(x,2) /))
end function cdfn2
pure function cdfn0d(x) result(cdfn)
  real(kind=DP), intent(in) :: x
  real(kind=DP) :: cdfn
  real(kind=DP), parameter :: a1 = 0.398942280444_dp, a2 = 0.399903438504_dp, &
       a3 = 5.75885480458_dp, a4 = 29.8213557808_dp, a5 = 2.62433121679_dp, &
       a6 = 48.6959930692_dp, a7 = 5.92885724438_dp, b0 = 0.398942280385_dp, &
       b1 = 3.8052e-08_dp, b2 = 1.00000615302_dp, b3 = 3.98064794e-04_dp, &
       b4 = 1.98615381364_dp, b5 = 0.151679116635_dp, b6 = 5.29330324926_dp, &
       b7 = 4.8385912808_dp, b8 = 15.1508972451_dp, b9 = 0.742380924027_dp, &
       b10 = 30.789933034_dp, b11 = 3.99019417011_dp
  real(kind=DP) ::  y
  logical :: smallx
  y = 0.5_dp * x**2
  cdfn=0.0_dp
  smallx = (abs(x) < 1.28_dp)
  if (smallx) cdfn = 0.5_dp - abs(x)  * ( a1 - a2 * y / ( y + a3 - a4 / ( y + a5 &
      + a6 / ( y + a7 ) ) ) )
  if ((.not.smallx).and.(abs(x) < 12.7_dp)) cdfn = exp ( - y ) * b0 / ( abs(x)  - b1 &
      + b2 / ( abs(x)  + b3 &
      + b4 / ( abs(x)  - b5 &
      + b6 / ( abs(x)  + b7 &
      - b8 / ( abs(x)  + b9 &
      + b10 / ( abs(x)  + b11 ) ) ) ) ) )
  if ( x > 0.0_dp ) cdfn = 1.0_dp-cdfn
end function cdfn0d
!function cdfn0d(x)
!  real(kind=DP), intent(in) :: x
!  real(kind=DP) :: cdfn0d
!  real(kind=DP) :: xtmp(1)
!  xtmp(1)=x
!  xtmp=cdfn1d(xtmp)
!  cdfn0d=xtmp(1)
!end function cdfn0d
pure function cdfn1d(x) result(cdfn)
  real(kind=DP), dimension(:), intent(in) :: x
  real(kind=DP), dimension(size(x)) :: cdfn
  real(kind=DP), parameter :: a1 = 0.398942280444_dp, a2 = 0.399903438504_dp, &
       a3 = 5.75885480458_dp, a4 = 29.8213557808_dp, a5 = 2.62433121679_dp, &
       a6 = 48.6959930692_dp, a7 = 5.92885724438_dp, b0 = 0.398942280385_dp, &
       b1 = 3.8052e-08_dp, b2 = 1.00000615302_dp, b3 = 3.98064794e-04_dp, &
       b4 = 1.98615381364_dp, b5 = 0.151679116635_dp, b6 = 5.29330324926_dp, &
       b7 = 4.8385912808_dp, b8 = 15.1508972451_dp, b9 = 0.742380924027_dp, &
       b10 = 30.789933034_dp, b11 = 3.99019417011_dp
  real(kind=DP), dimension(size(x)) ::  y
  logical, dimension(size(x)) :: smallx
  y = 0.5_dp * x**2
  cdfn=0.0_dp
  smallx = (abs(x) < 1.28_dp)
  where (smallx) cdfn = 0.5_dp - abs(x)  * ( a1 - a2 * y / ( y + a3 - a4 / ( y + a5 &
      + a6 / ( y + a7 ) ) ) )
  where ((.not.smallx).and.(abs(x) < 12.7_dp)) cdfn = exp ( - y ) * b0 / ( abs(x)  - b1 &
      + b2 / ( abs(x)  + b3 &
      + b4 / ( abs(x)  - b5 &
      + b6 / ( abs(x)  + b7 &
      - b8 / ( abs(x)  + b9 &
      + b10 / ( abs(x)  + b11 ) ) ) ) ) )
  where ( x > 0.0_dp ) cdfn = 1.0_dp-cdfn
end function cdfn1d
function cdfn2d(x) result(cdfn)
  real(kind=DP), dimension(:,:), intent(in) :: x
  real(kind=DP), dimension(Size(x,1),Size(x,2)) :: cdfn
  real(kind=DP), dimension(Size(x,1)*Size(x,2)) :: tmpx
  tmpx = reshape(x,(/ size(x,1)*size(x,2) /))
  tmpx = cdfn1d(tmpx)
  cdfn = reshape(tmpx,(/ size(x,1), size(x,2) /))
end function cdfn2d

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! CDFINVN function
!
! Format: cdfinvn(x)
!
! Gives inverse of standard normal CDF of x.
!
! X can be either single or double precision, and can be a scalar,
! vector, or 2-dimensional array.  The output
! vector will be the same type as X.  In order for the inverse
! CDF to exist, X must be strictly between zero and one.  This
! function does not check!
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function cdfinvn0(p) result(cdfinvn)
  real, intent(in) :: p
  real :: cdfinvn
  real, dimension(1) :: tmp
  tmp(1) = p
  tmp = cdfinvn1(tmp)
  cdfinvn=tmp(1)
end function cdfinvn0
function cdfinvn1(p) result(cdfinvn)
  real, dimension(:), intent(in) :: p
  real, dimension(Size(p)) :: cdfinvn
  logical, dimension(Size(p)) :: maskgt
  real, dimension(Size(p)) :: y,xp
  real, parameter :: lim=1.0e20, p0=-0.32223243, p1=-1.0, &
                     p2=-0.34224208, p3=-0.02042312, &
                     p4=-0.45364221e-4, q0=0.09934846, &
                     q1=0.58858157, q2=0.53110346, &
                     q3=0.10353775, q4=0.38560700e-2
  maskgt = (p > 0.5)
  xp = p
  where (maskgt) xp = 1-xp
  y = sqrt(-2.0*log(xp))
  xp = y + ((((p4*y + p3) * y + p2)* y + p1)*y + p0)/ &
       ((((q4*y + q3) * y + q2) * y + q1) * y + q0)
  where (maskgt) xp = -xp
  where (p == 0.5) xp = 0.0
  cdfinvn = -xp
end function cdfinvn1
function cdfinvn2(p) result(cdfinvn)
  real, dimension(:,:), intent(in) :: p
  real, dimension(Size(p,1),Size(p,2)) :: cdfinvn
  real, dimension(Size(p,1)*Size(p,2)) :: tmp
  tmp = reshape(p,(/ size(p,1)*size(p,2) /))
  tmp = cdfinvn1(tmp)
  cdfinvn = reshape(tmp,(/ size(p,1), size(p,2) /))
end function cdfinvn2
pure function cdfinvn0d(p)  result(cdfinvn)
  real(kind=DP), intent(in) :: p
  real(kind=DP) :: cdfinvn
  logical :: maskgt
  real(kind=DP) :: y
  real(kind=DP), parameter :: p0=-0.322232431088_dp, p1=-1.0_dp, &
                     p2=-0.342242088547_dp, p3=-0.0204231210245_dp, &
                     p4=-0.453642210148e-4_dp, q0=0.0993484626060_dp, &
                     q1=0.588581570495_dp, q2=0.531103462366_dp, &
                     q3=0.103537752850_dp, q4=0.38560700634e-2_dp, &
                     minp=1.0e-300_dp
  maskgt = (p > 0.5_dp)
  cdfinvn = p
  if (maskgt) cdfinvn = 1.0_dp-cdfinvn
  if (cdfinvn < minp) then
     cdfinvn = minp
  end if
  y = sqrt(-2.0_dp*log(cdfinvn))
  cdfinvn = y + ((((p4*y + p3) * y + p2)* y + p1)*y + p0)/ &
       ((((q4*y + q3) * y + q2) * y + q1) * y + q0)
  if (.not.maskgt) cdfinvn=-cdfinvn
  if (p == 0.5_dp) cdfinvn = 0.0_dp
end function cdfinvn0d
pure function cdfinvn1d(p)  result(cdfinvn)
  real(kind=DP), dimension(:), intent(in) :: p
  real(kind=DP), dimension(size(p)) :: cdfinvn
  logical, dimension(size(p)) :: maskgt
  real(kind=DP), dimension(size(p)) :: y
  real(kind=DP), parameter :: p0=-0.322232431088_dp, p1=-1.0_dp, &
                     p2=-0.342242088547_dp, p3=-0.0204231210245_dp, &
                     p4=-0.453642210148e-4_dp, q0=0.0993484626060_dp, &
                     q1=0.588581570495_dp, q2=0.531103462366_dp, &
                     q3=0.103537752850_dp, q4=0.38560700634e-2_dp, &
                     minp=1.0e-300_dp
  maskgt = (p > 0.5_dp)
  cdfinvn = p
  where (maskgt) cdfinvn = 1.0_dp-cdfinvn
  where (cdfinvn < minp) cdfinvn=minp
  y = sqrt(-2.0_dp*log(cdfinvn))
  cdfinvn = y + ((((p4*y + p3) * y + p2)* y + p1)*y + p0)/ &
       ((((q4*y + q3) * y + q2) * y + q1) * y + q0)
  where (.not.maskgt) cdfinvn=-cdfinvn
  where (p == 0.5_dp) cdfinvn = 0.0_dp
end function cdfinvn1d
function cdfinvn2d(p) result(cdfinvn)
  real(kind=DP), dimension(:,:), intent(in) :: p
  real(kind=DP), dimension(Size(p,1),Size(p,2)) :: cdfinvn
  real(kind=DP), dimension(Size(p,1)*Size(p,2)) :: tmp
  tmp = reshape(p,(/ size(p,1)*size(p,2) /))
  tmp = cdfinvn1d(tmp)
  cdfinvn = reshape(tmp,(/ size(p,1), size(p,2) /))
end function cdfinvn2d

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! CHOL function
!
! Format: chol(a)
!
! Gives Cholesky decomposition of the symmetric positive definite
! matrix A, i.e., the matrix L such that LL'=a.  If A is not
! a symmetric positive definite matrix, then this function
! will give back garbage.  A can be either single or double
! precision, with the result being of the same type as A.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function chols(a) result(chol)
  real(kind=SP), dimension(:,:), intent(in) :: a
  real(kind=SP), dimension(size(a,1),size(a,2)) :: chol
  real(kind=SP), dimension(size(a,1)) :: p
  integer :: i,n
  real(kind=SP) :: sumn
  n = size(a,1) ! should check to make sure a is square
  chol = a
  do i=1,n
     sumn = chol(i,i) - dot_product(chol(1:i-1,i),chol(1:i-1,i))
     p(i) = sqrt(sumn)
     chol(i,i+1:n) = (chol(i+1:n,i)-matmul(chol(1:i-1,i),chol(1:i-1,i+1:n)))/p(i)
  end do
  do i = 1,n
     chol(i,i)=p(i)
     chol(i+1:n,i) = 0.0
  end do
end function chols
function chold(a) result(chol)
  real(kind=DP), dimension(:,:), intent(in) :: a
  real(kind=DP), dimension(size(a,1),size(a,1)) :: chol
  real(kind=DP), dimension(size(a,1)) :: p
  integer :: i,n
  real(kind=DP) :: sumn
  n = size(a,1) ! should check to make sure a is square
  chol = a
  do i=1,n
     sumn = chol(i,i) - dot_product(chol(1:i-1,i),chol(1:i-1,i))
     p(i) = sqrt(sumn)
     chol(i,i+1:n) = (chol(i+1:n,i)-matmul(chol(1:i-1,i),chol(1:i-1,i+1:n)))/p(i)
  end do
  do i = 1,n
     chol(i,i)=p(i)
     chol(i+1:n,i) = 0.0_dp
  end do
end function chold

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! OLS function
!
! Format: ols(x,y)
!
! Gives OLS coefficient vector for regression of x on y.
!
! X and Y can be either single or double precision.  The output
! vector will be the same type as X and Y.  X should have a
! column of ones if you want an intercept.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function olss(x,y) result(olsout)
  real(kind=SP), dimension(:,:), intent(in) :: x
  real(kind=SP), dimension(:), intent(in) :: y
  real(kind=SP), dimension(size(x,2)) :: olsout,xprimey,p
  real(kind=SP), dimension(size(x,2),size(x,2)) :: xprimex
  real(kind=SP) :: summ
  integer :: i,n
  n=size(x,2)
  xprimex = matmul(transpose(x),x)
  xprimey = matmul(transpose(x),y)
  do i=1,n
     summ = xprimex(i,i)-dot_product(xprimex(i,1:i-1),xprimex(i,1:i-1))
     p(i) = sqrt(summ)
     xprimex(i+1:n,i) = (xprimex(i,i+1:n)-matmul(xprimex(i+1:n,1:i-1),xprimex(i,1:i-1)))/p(i)
  end do
  do i=1,n
     olsout(i)=(xprimey(i)-dot_product(xprimex(i,1:i-1),olsout(1:i-1)))/p(i)
  end do
  do i=n,1, -1
     olsout(i)=(olsout(i)-dot_product(xprimex(i+1:n,i),olsout(i+1:n)))/p(i)
  end do
end function olss
function olsd(x,y) result(ols)
  real(kind=DP), dimension(:,:), intent(in) :: x
  real(kind=DP), dimension(:), intent(in) :: y
  real(kind=DP), dimension(size(x,2)) :: ols,xprimey,p
  real(kind=DP), dimension(size(x,2),size(x,2)) :: xprimex
  real(kind=DP) :: summ
  integer :: i,n
  n=size(x,2)
  xprimex = matmul(transpose(x),x)
  xprimey = matmul(transpose(x),y)
  do i=1,n
     summ = xprimex(i,i)-dot_product(xprimex(i,1:i-1),xprimex(i,1:i-1))
     p(i) = sqrt(summ)
     xprimex(i+1:n,i) = (xprimex(i,i+1:n)-matmul(xprimex(i+1:n,1:i-1),xprimex(i,1:i-1)))/p(i)
  end do
  do i=1,n
     ols(i)=(xprimey(i)-dot_product(xprimex(i,1:i-1),ols(1:i-1)))/p(i)
  end do
  do i=n,1, -1
     ols(i)=(ols(i)-dot_product(xprimex(i+1:n,i),ols(i+1:n)))/p(i)
  end do
end function olsd

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! RANDINT subroutine (formerly a function)
!
! Format: randint(n)
!
! Gives a list of n random integers between 1 and n.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine randint(randintout)
  integer, dimension(:), intent(out) :: randintout
  real, dimension(size(randintout)) :: rnd_num
  integer :: n
  n=size(randintout)
  call runif(rnd_num)
  randintout = 1+floor(real(n,SP)*rnd_num)
end subroutine randint

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! FACTORIAL function
!
! Format: factorial(x)
!
! Given the integer (or vector of integers) x, returns
!	x! or x*(x-1)*(x-2)*...*3*2*1
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
pure function factorial0(n) result(factorial)
  integer, intent(in) :: n
  integer :: factorial
  integer :: i
  factorial=1
  if (n > 1) then
     do i=2,n
        factorial=factorial*i
     end do
  end if
end function factorial0
pure function factorial1(n) result(factorial)
  integer, dimension(:), intent(in) :: n
  integer, dimension(size(n)) :: factorial
  integer :: i,maxn
  factorial=1
  maxn=maxval(n)
  if (maxn > 1) then
     do i=2,maxn
        where (n >= i) factorial=factorial*i
     end do
  end if
end function factorial1

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! NCHOOSEK function
!
! Format: nchoosek(n,k)
!
! Gives the number of k-length combinations of n items, or
!       n!
!     ----------
!     k!(n-k)!
!
! N and K can both be scalars, or both be vectors, but
! must be integers.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
pure function nchoosek0(n,k) result(nchoosek)
  integer, intent(in) :: n,k
  integer :: nchoosek
  nchoosek = factorial(n)/(factorial(k)*factorial(n-k))
end function nchoosek0
pure function nchoosek1(n,k) result(nchoosek)
  integer, dimension(:), intent(in) :: n
  integer, dimension(size(n)), intent(in) :: k
  integer, dimension(size(n)) :: nchoosek
  nchoosek = factorial(n)/(factorial(k)*factorial(n-k))
end function nchoosek1

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! FIND_PRIMES function
!
! Format: find_primes(n)
!
! Returns the first n primes in a vector of length n, through
! a very brute-force algorithm.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function find_primes(n) result(primes)
  integer, intent(in) :: n
  integer, dimension(n) :: primes
  integer :: i,j,nprimes
  logical :: isaprime
  primes(1)=2
  nprimes=1
  do i=3,huge(1)
     isaprime = .true.
     do j=1,nprimes
        if (modulo(i,primes(j)) == 0) then
           isaprime = .false.
           exit
        end if
     end do
     if (isaprime) then
        nprimes=nprimes+1
        primes(nprimes) = i
        if (nprimes == n) return
     end if
  end do
end function find_primes

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! RHALT function
!
! Format: rhalt(r,c,shift)
!
! Gives a randomized Halton matrix with r rows and c columns.
! "shift" is the random number
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function rhalt(r,c,shift) result(rhaltout)
  integer, intent(in) :: r,c
  real(kind=DP), intent(in) :: shift
  real(kind=DP), dimension(r,c) :: rhaltout
  rhaltout=hmat(r,c)+shift
  where (rhaltout > 1.0_dp) rhaltout=rhaltout-1.0_dp
end function rhalt

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! HMAT function
!
! Format: hmat(r,c)
!
! Gives a Halton matrix with r rows and c columns.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function hmat(r,c) result(hmatout)
  integer, intent(in) :: r,c
  real(kind=DP), dimension(r,c) :: hmatout
  integer, dimension(c) :: prim
  integer :: droppit,i
  real(kind=DP), dimension(:), allocatable :: tmp
  prim=find_primes(c)
  droppit = max(10,prim(c))
  allocate(tmp(r+droppit))
  do i=1,c
     tmp = halton_sequence(r+droppit,prim(i))
     hmatout(:,i) = tmp((droppit+1):(droppit+r))
  end do
  deallocate(tmp)
end function hmat

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! HALTON_SEQUENCE function
!
! Format: halton_sequence(n,s)
!
! Gives a Halton sequence
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
function halton_sequence(n,s) result(hseqout)
  integer, intent(in) :: n,s
  real(kind=DP), dimension(n) :: hseqout
  integer :: i,j,k,len
  real(kind=DP), dimension(:), allocatable :: x
  k = ceiling(log(real(n+1))/log(real(s)))
  allocate(x(1+s**k))
  x(1) = 0.0_dp
  len=1
  do i=1,k
     do j=1,(s-1)
        x((j*len+1):((j+1)*len))=x(1:len)+real(j,DP)/real(s**i,DP)
     end do
     len=len*s
  end do
  hseqout  = x(2:(n+1))
  deallocate(x)
end function halton_sequence

end module bkmath


program main
  ! Default
  implicit none

  ! Parameters
  integer(4), parameter :: target_sum = 1000

  ! Variables
  integer(4) :: a,b,c

  ! Do work
  outer: do a=1,target_sum
     do b=a,target_sum
        do c=b+1,target_sum
           if (is_triplet(a,b,c)) then
              if (a+b+c==target_sum) then
                 write(*,*) 'Special triple is: ',a,b,c
                 write(*,*) 'Product is: ',a*b*c
                 exit outer
              endif
           endif
        enddo
     enddo
  enddo outer

contains

  pure function is_triplet(a,b,c)
    ! Default
    implicit none

    ! Function arguments
    integer(4), intent(in) :: a,b,c
    logical                :: is_triplet

    ! Check if numbers are a triplet
    ! Assumes that a <= b < c
    if (a**2 + b**2 == c**2) then
       is_triplet = .true.
    else
       is_triplet = .false.
    endif

    return
  end function is_triplet

end program main


! Name: ARPIT KUMAR JAIN, Roll No: 180122009
PROGRAM ChebyshevInterpolationSinPiX
    IMPLICIT NONE
    REAL, PARAMETER :: pi = acos(-1.0)
    INTEGER:: n, k
    REAL:: Point
    REAL, DIMENSION(:), ALLOCATABLE:: X, F

    WRITE(*, fmt = '(/A)', ADVANCE = "NO") "Enter Order of Interpolation Polynomial: "
    READ(*, *) n
    ALLOCATE(X(0:n));
    ALLOCATE(F(0:n));
    WRITE(*, 10, ADVANCE = "NO") n
    10 FORMAT(/, "Enter the X value to find Q", i0, "(X): ")
    READ(*, *) point

    DO k = 0, n
        X(k) = cos(((2*k+1 )*pi)/(2*n+2))
        F(k) = Sin(pi * X(k))
    ENDDO

    CALL NewtonInterpolation(point, n, F, X)

    CONTAINS
    SUBROUTINE NewtonInterpolation(point, n, F, X)
        IMPLICIT NONE
        REAL:: point, QnX, polynomialTerm
        INTEGER:: n, i, j
        REAL, DIMENSION(0:n):: X, F
        REAL, DIMENSION(0:n, 0:n):: DD ! DD for Divided Difference
        DD = 0.0

        DO i = 0, n
            DD(i, i) = F(i)
        ENDDO

        DO j = 1, n
            DO i = 0, n-j
                DD(i, i+j) = ( DD(i+1, i+j) - DD(i, i+j-1) ) / ( X(i+j) - X(i) )
                ! WRITE(*, fmt = '(A, i0, A, i0, A, f0.9)') "DD[", i, "...", i+j, "] = ", DD(i, i+j)
            ENDDO
        ENDDO

        QnX = DD(0, 0) ! QnX = a0 (initialize)

        DO i = 0, n-1
            polynomialTerm = 1.0
            DO j = 0, i
                polynomialTerm = polynomialTerm * (point - X(j))
            ENDDO
            QnX = QnX + DD(0, i+1) * polynomialTerm
        ENDDO

        WRITE(*, fmt = '(/A)') "Result of Newton Interpolation"
        WRITE(*, 11) n, point, QnX
        11 FORMAT("Q", i0, "(", f0.3, ") = ", f0.8/)
    END SUBROUTINE NewtonInterpolation

END PROGRAM ChebyshevInterpolationSinPiX


program main

implicit none

        integer, parameter :: N_DIVISORS = 500
        integer, parameter :: ONE = 1

        print*, max_tri_divis(N_DIVISORS)

contains

        ! This is here because I really miss the '+=' operator from C
        ! Operates on TWO instances of 64 bit numbers.

        pure subroutine inc(base, offset)

                integer, intent(out) :: base
                integer, intent(in) :: offset

                base = base + offset

                return

        end subroutine inc

        ! Calculate what Triangle number is the first to have in excess of
        ! `m` divisors

        pure function max_tri_divis(m)

                integer, intent(in) :: m
                integer :: max_tri_divis
                integer :: i, tri

                i = 3
                tri = 3

                do while (.true.)
                        if (numdivis(tri) > m) then
                                max_tri_divis = tri
                                exit
                        endif

                        call inc(tri, i)
                        call inc(i, ONE)

                end do

                return

        end function max_tri_divis

        ! Calculate the number of divisors for a given number `x` by
        ! by searching up to the square and multiplying that count by 2

        pure function numdivis(x)

                integer, intent(in) :: x
                integer :: numdivis

                ! local
                integer :: i

                i = 1
                numdivis = 0

                do while ((i ** 2) < x)

                        if (mod(x, i) == 0) then
                                call inc(numdivis, ONE)
                        endif

                        call inc(i, ONE)

                end do

                numdivis = 2 * numdivis

                return

        end function numdivis

end program main


program main
    implicit none
    integer, parameter :: dp = selected_real_kind(8)
    real(dp), parameter :: Gammaba = 1.d-2, Gammaca = 1.d0, omegaca = 10.d0
    real(dp) :: Omegas, omegap, alpha

    open(unit = 1, file = 'AbsorptionCoefficient-1.txt', status = 'unknown')
    omegap = 0.d0
    Omegas = 0.d0
    do while (omegap <= 20.d0)
        alpha = omegap * ((omegap - omegaca) + Gammaba**2)**2&
        * (Gammaba * Omegas**2 + Gammaca * ((omegap - omegaca)**2 + Gammaba**2))&
        / ((omegap - omegaca)**2 * (Omegas**2 - ((omegap - omegaca)**2 + Gammaba**2))**2&
            + (Gammaba * Omegas**2 + Gammaca * ((omegap - omegaca)**2 + Gammaba**2))**2)
        write(1,'(2f20.8)') omegap / omegaca, alpha
        omegap = omegap + 1.d-2
    end do
    close(1)

    open(unit = 2, file = 'AbsorptionCoefficient-2.txt', status = 'unknown')
    omegap = 0.d0
    Omegas = .5d0 * Gammaca
    do while (omegap <= 20.d0)
        alpha = omegap * ((omegap - omegaca) + Gammaba**2)**2&
        * (Gammaba * Omegas**2 + Gammaca * ((omegap - omegaca)**2 + Gammaba**2))&
        / ((omegap - omegaca)**2 * (Omegas**2 - ((omegap - omegaca)**2 + Gammaba**2))**2&
            + (Gammaba * Omegas**2 + Gammaca * ((omegap - omegaca)**2 + Gammaba**2))**2)
        write(2,'(2f20.8)') omegap / omegaca, alpha
        omegap = omegap + 1.d-2
    end do
    close(2)

    open(unit = 3, file = 'AbsorptionCoefficient-3.txt', status = 'unknown')
    omegap = 0.d0
    Omegas = 5.d0 * Gammaca
    do while (omegap <= 20.d0)
        alpha = omegap * ((omegap - omegaca) + Gammaba**2)**2&
        * (Gammaba * Omegas**2 + Gammaca * ((omegap - omegaca)**2 + Gammaba**2))&
        / ((omegap - omegaca)**2 * (Omegas**2 - ((omegap - omegaca)**2 + Gammaba**2))**2&
            + (Gammaba * Omegas**2 + Gammaca * ((omegap - omegaca)**2 + Gammaba**2))**2)
        write(3,'(2f20.8)') omegap / omegaca, alpha
        omegap = omegap + 1.d-2
    end do
    close(3)

end program main


program intrinsics_19c
! Test math intrinsics both declarations and executable statements.
! Single and double precision, complex only.
integer, parameter :: dp = kind(0.d0)

real, parameter :: &
    s1 = abs((0.5,0.5)), &
    s5 = aimag((0.4,0.5))
complex, parameter :: &
    s2 = exp((0.5,0.5)), &
    s3 = log((0.5,0.5)), &
    s4 = sqrt((0.5,0.5))

real(dp), parameter :: &
    d1 = abs((0.5_dp,0.5_dp)), &
    d5 = aimag((0.4,0.5))
complex(dp), parameter :: &
    d2 = exp((0.5_dp,0.5_dp)), &
    d3 = log((0.5_dp,0.5_dp)), &
    d4 = sqrt((0.5_dp,0.5_dp))

complex :: x
complex(dp) :: y

x = (0.5,0.5)
y = (0.5_dp,0.5_dp)

print *, abs((0.5,0.5)), abs((0.5_dp,0.5_dp)), s1, d1, abs(x), abs(y)
print *, exp((0.5,0.5)), exp((0.5_dp,0.5_dp)), s2, d2, exp(x), exp(y)
print *, log((0.5,0.5)), log((0.5_dp,0.5_dp)), s3, d3, log(x), log(y)
print *, sqrt((0.5,0.5)), sqrt((0.5_dp,0.5_dp)), s4, d4, sqrt(x), sqrt(y)
x = (0.4,0.5)
y = (0.4_dp,0.5_dp)
print *, aimag((0.5,0.5)), aimag((0.5_dp,0.5_dp)), s5, d5, aimag(x), aimag(y)

end


module ToroidCurrents
  contains

    function rho(r, r0, y)
      USE Types
      real(kind=dp) :: rho, r, r0, y

       rho = sqrt((r-r0)**2+y**2)
    end function rho

    function currentInToroidR(r, r0, y, turns, I) result (curr)
      USE Types
      real(kind=dp) :: r, r0, y, curr, rho1, rho2, turns, I

      rho1 = rho(8d-3, r0, y)
      rho2 = rho(10d-3, r0, y)

      curr = turns * I /(2*pi*(rho2-rho1)*r)*(-y/rho(r, r0, y))

    end function currentInToroidR

    function currentInToroidY(r, r0, y, turns, I) result (curr)
      USE Types
      real(kind=dp) :: r, r0, y, curr, rho1, rho2, turns, I

      rho1 = rho(8d-3, r0, y)
      rho2 = rho(10d-3, r0, y)

      curr = turns * I /(2*pi*(rho2-rho1)*r)*((r-r0)/rho(r, r0, y))

    end function currentInToroidY

End module ToroidCurrents

FUNCTION currdens1( model, n, args) RESULT(curr)
  USE DefUtils
  Use ToroidCurrents
  IMPLICIT None
  TYPE(Model_t) :: model
  INTEGER :: n
  REAL(KIND=dp) :: x, y, z, args(4), curr, f, omega, &
                   theta, r0, r, turns, I, t

  x = args(1)
  y = args(2)
  z = args(3)
  t = args(4)

  r0 = 45d-3
  turns = 100d0

  f = 50d0
  omega = 2d0*pi*f

  I = 2d0 * sin(omega * t)

  r = sqrt(x**2 + z**2)

  theta = atan(x/z)

  curr = currentInToroidR(r, r0, y, turns, I) * sin(theta)

END FUNCTION currdens1

FUNCTION currdens2( model, n, args) RESULT(curr)
  USE DefUtils
  Use ToroidCurrents
  IMPLICIT None
  TYPE(Model_t) :: model
  INTEGER :: n
  REAL(KIND=dp) :: x, y, z, args(4), curr, f, omega, &
                   theta, r0, r, turns, I, t

  x = args(1)
  y = args(2)
  z = args(3)
  t = args(4)

  r0 = 45d-3
  turns = 100d0

  f = 50d0
  omega = 2d0*pi*f

  I = 2d0 * sin(omega * t)

  r = sqrt(x**2 + z**2)

  theta = atan(x/z)

  curr = currentInToroidY(r, r0, y, turns, I)

END FUNCTION currdens2

FUNCTION currdens3( model, n, args) RESULT(curr)
  USE DefUtils
  Use ToroidCurrents
  IMPLICIT None
  TYPE(Model_t) :: model
  INTEGER :: n
  REAL(KIND=dp) :: x, y, z, args(4), curr, f, omega, &
                   theta, r0, r, turns, I, t

  x = args(1)
  y = args(2)
  z = args(3)
  t = args(4)

  r0 = 45d-3
  turns = 100d0

  f = 50d0
  omega = 2d0*pi*f

  I = 2d0 * sin(omega * t)

  r = sqrt(x**2 + z**2)

  theta = atan(x/z)

  curr = currentInToroidR(r, r0, y, turns, I) * cos(theta)

END FUNCTION currdens3


	subroutine qbezier(y1,y2,y3,xp3,yp,offset)

!	Quadratic Bezier spline interpolation in 1d
!	y1, y2, and y3 are for x=-1, 0, and 1, respectively
!	the returned value, yp, is the result of the
!	interpolation for 0<= xp <= 1 if offset=0
!
!	If offset is not 0, it is assumed it is offset=1 and
!	then y1, y2 and y3 are for x=0,1, and 2, respectively
!	and still 0<= xp <= 1
!
!	C. Allende Prieto, Feb 2004
!
! 	The value xp is not actually needed, but 3 derived quantities in xp3
!	xp3=( (1-xp)**2, xp**2, 2*xp*(1-xp) )
!

	use share, only: dp
	implicit none

	integer	::	offset
	real(dp)::	 y1,y2,y3,xp3(3),yp,c0,yprime

	if (offset == 0) then

		yprime=0.5_dp*(y3-y1)
		c0=y2+0.5_dp*yprime

		!yp=y2*(1.0_dp-xp)**2+y3*xp**2+c0*2.d0*xp*(1.0_dp-xp)
		yp=y2*xp3(1) + y3*xp3(2) + c0*xp3(3)

	else

		yprime=0.5_dp*(y3-y1)
		c0=y2-0.5_dp*yprime

		!yp=y1*(1.0_dp-xp)**2+y2*xp**2+c0*2.d0*xp*(1.0_dp-xp)
		yp=y1*xp3(1) + y2*xp3(2) + c0*xp3(3)

	endif

	end subroutine qbezier


FUNCTION convlv(data,respns)
!-----------------------------------------------------------------------------
!
! Description:
!
!   External function convolving two time-series. Convolution is perfomed in
!   the frequency domain. Unit time-step is assumed.
!
! Dependencies:
!
!   Subroutine realft
!
! References:
!
!   Numerical Recipes in Fortran90, pag. 1253
!
! Notes:
!
!   Respns is assumed to have LESS number of points than Data.
!   The Respns time-series is assumed to NOT have values at negative times.
!   Input time-series are both zero-padded to avoid side-effects. Convolution
!   result is then truncated up to the original number of points before being
!   passed.
!
! Author: W. Imperatori
!
! Modified: January 2009 (v1.3)
!

use def_kind; use interfaces, only: realft

implicit none

! first input time-series (actually it is NOT modified)
real(kind=r_single),dimension(:),intent(inout):: data
! second input time-series
real(kind=r_single),dimension(:),intent(in)   :: respns
! output function
real(kind=r_single),dimension(size(data))     :: convlv
! local variables
integer(kind=i_single)                        :: n,m
complex(kind=r_single),dimension(size(data))  :: tmpd,tmpr
real(kind=r_single),dimension(2*size(data))   :: pad1,pad2

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

! extract sizes
n=size(data)
m=size(respns)

! check m > n
if (m > n) call error_handling(9,'null','CONVLV (fourier.f90)')

! check for 2**N number of points
if ( iand(n,n-1) /=0 ) call error_handling(5,'null','CONVLV (fourier.f90)')

! zero-pad input data to avoid side-effects (conservative assumption: zero-padding
! equal to first input length - in theory it could be equal to non-zero length
! of second input vector)
pad1(1:n) = data; pad1(n+1:) = 0.

! zero-pad also respns to have same number of points in frequency
pad2(1:m)=respns(:); pad2(m+1:)=0.

! FFT of input time-series
call realft(pad1,1,tmpd)
call realft(pad2,1,tmpr)

! multiply FFTs
tmpr(1)=cmplx(real(tmpd(1))*real(tmpr(1))/n,aimag(tmpd(1))*aimag(tmpr(1))/n,kind=r_single)
tmpr(2:)=tmpd(2:)*tmpr(2:)/n

! IFFT of multiplied Fourier spectra
call realft(pad2,-1,tmpr)

! return only first n points (exclude padding values)
convlv = pad2(1:n)

END FUNCTION convlv

!===================================================================================================

FUNCTION correl(data1,data2)
!-------------------------------------------------------------------------------
!
! Description:
!
!   Compute correlation between two time series in the frequency domain
!
! Dependencies:
!
!   Subroutine realft
!
! Notes:
!
!   Time-series are not padded here. They should be passed already padded to
!   avoid side-effects
!
! References:
!
!   Numerical Recipes in Fortran90, pag. 1254
!
! Author: W. Imperatori
!
! Modified: January 2009 (v1.3)
!
! *** NOT USED IN THIS VERSION ***
!

use def_kind; use interfaces, only: realft

implicit none

! input arrays
real(kind=r_single),dimension(:),intent(in)   :: data1,data2
! function
real(kind=r_single),dimension(size(data1))    :: correl
! local variables
complex(kind=r_single),dimension(size(data1)) :: cdat1,cdat2
integer(kind=i_single)                        :: n
real(kind=r_single),dimension(2*size(data1)) :: pad1,pad2

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

n = size(data1)

! checks for equal series length and 2**N npts
if (n /= size(data2)) call error_handling(9,'null','CORREL (fourier.f90)')
if (iand(n,n-1) /= 0) call error_handling(5,'null','CORREL (fourier.f90)')

! zero-pad input data to avoid side-effects
pad1(1:n) = data1; pad1(n+1:) = 0.
pad2(1:n) = data2; pad2(n+1:) = 0.

! FFT
call realft(pad1,1,cdat1)
call realft(pad2,1,cdat2)

! perform multiplication with complex conjugate
cdat1(1)=cmplx(real(cdat1(1))*real(cdat2(1))/n,aimag(cdat1(1))*aimag(cdat2(1))/n,kind=r_single)
cdat1(2:)=cdat1(2:)*conjg(cdat2(2:))/n

! IFFT
call realft(pad1,-1,cdat1)

! return only N points (exclude padding values)
correl(1:n/2) = pad1(1:n/2); correl(n/2 +1:) = pad1(3*n/2 +1:)

END FUNCTION correl

!===================================================================================================

FUNCTION lag_correl(seq1,seq2)
!--------------------------------------------------------------------
!
! Description:
!
!   Evaluate at which lag value the correlation of two sequences has
!   its maximum
!
! Dependencies:
!
!   Function correl
!
! Author: W. Imperatori
!
! Modified: January 2009 (v1.3)
!
! *** NOT USED IN THIS VERSION ***
!

use def_kind; use interfaces, only: correl

implicit none

! input time-series
real(kind=r_single),dimension(:),intent(in):: seq1,seq2
! function
real(kind=r_single)                        :: lag_correl
! local variables
integer(kind=i_single)                     :: max_index,n

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

n = size(seq1)

max_index = maxloc(correl(seq1,seq2),dim=1)

if (max_index > n/2) then
   lag_correl = -(max_index - n - 1)
else
   lag_correl = (max_index - 1)
endif

END FUNCTION lag_correl

!===================================================================================================

SUBROUTINE four1d(data,isign)
!---------------------------------------------------------------------
!
! Description:
!
!   External subroutine from Numerical Recipes, prepares input for
!   FAST FOURIER TRANSFORM (FFT) or inverse (IFFT) computation
!
! Dependencies:
!
!   Subroutine fourrow, function arth
!
! References:
!
!   Numerical Recipes in Fortran90, pag. 1239-1240
!
! Notes:
!
!   i_sign=1 -> FFT, i_sign=-1 -> IFFT
!
! Warning:
!
!   This subroutine works ONLY with 2**n number of points
!
! Authors: W. Imperatori
!
! Modified: January 2009 (v1.3)
!

use constants; use def_kind; use interfaces, only: fourrow, arth

implicit none

! input-output vector where complex transform will be stored
complex(kind=r_single),dimension(:),intent(inout) :: data
! flag for FFT/IFFT
integer(kind=i_single),intent(in)                 :: isign
! locals
complex(kind=r_single),dimension(:,:),allocatable :: dat,temp
complex(kind=r_double),dimension(:),allocatable   :: w,wp
real(kind=r_double),dimension(:),allocatable      :: theta
integer(kind=i_single)                            :: n,m1,m2,j

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

n=size(data)

if ( iand(n,n-1) /=0 ) call error_handling(5,'null','four1d (fft.f90)')

m1=2**ceiling(0.5*log(real(n,kind=r_single))/0.693147)
m2=n/m1

allocate(dat(m1,m2),theta(m1),w(m1),wp(m1),temp(m2,m1))

dat=reshape(data,shape(dat))

call fourrow(dat,isign)    !first transform

theta=arth(0,isign,m1)*pi_double/n
wp=cmplx(-2.0*sin(0.5*theta)**2,sin(theta),kind=r_double)
w=cmplx(1.0,0.0,kind=r_double)

do j=2,m2
   w=w*wp+w
   dat(:,j)=dat(:,j)*w
enddo

temp=transpose(dat)

call fourrow(temp,isign)   !second transform

data=reshape(temp,shape(data))

deallocate(dat,w,wp,theta,temp)

END SUBROUTINE four1d

!===================================================================================================

SUBROUTINE fourrow(data,isign)
!---------------------------------------------------------------------
!
! Description:
!
!   External subroutine from Numerical Recipes, calculates FAST FOURIER
!   TRANSFORM (FFT) and its inverse (IFFT) for single-precision complex
!   data
!
! Dependencies:
!
!   Subroutine swap
!
! References:
!
!   Numerical Recipes in Fortran90, pag. 1235
!
! Notes:
!
!   i_sign=1 -> FFT, i_sign=-1 -> IFFT
!
! Warning:
!
!   This subroutine works ONLY with 2**n number of points
!
! Authors: W. Imperatori, M. Mai, B. Mena
!
! Modified: January 2009 (v1.3)
!

use constants; use def_kind; use interfaces, only: swap

implicit none

! input/output array
complex(kind=r_single),dimension(:,:),intent(inout) :: data
! flag for FFT/IFFT
integer(kind=i_single),intent(in)                   :: isign
! locals
integer(kind=i_single)                              :: n,i,istep,j,m,mmax,n2
real(kind=r_double)                                 :: theta
complex(kind=r_single), dimension(size(data,1))     :: temp
complex(kind=r_double)                              :: w,wp
complex(kind=r_single)                              :: ws

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

n=size(data,2)

if ( iand(n,n-1) /= 0 ) call error_handling(5,'null','fourrow (fft.f90)')

n2=n/2

j=n2

do i=1,n-2
   if (j > i) call swap(data(:,j+1),data(:,i+1))
   m=n2

   do
      if (m < 2 .or. j < m) exit
         j=j-m
         m=m/2
   enddo

   j=j+m

enddo

mmax=1

do
   if (n <= mmax) exit
   istep=2*mmax
   theta=pi/(isign*mmax)
   wp=cmplx(-2.0*sin(0.5*theta)**2,sin(theta),kind=r_double)
   w=cmplx(1.0,0.0,kind=r_double)

   do m=1,mmax
      ws=w

      do i=m,n,istep
         j=i+mmax
         temp=ws*data(:,j)
         data(:,j)=data(:,i)-temp
         data(:,i)=data(:,i)+temp
      enddo
      w=w*wp+w
   enddo

   mmax=istep

enddo

END SUBROUTINE fourrow

!===================================================================================================

SUBROUTINE realft(data,isign,zdata)
!-------------------------------------------------------------------
!
! Description:
!
!   External subroutine performing FFT and IFFT of real time-series
!
! Dependencies:
!
!   subroutine four1d, function zroots_unity
!
! References:
!
!   Numerical Recipes in Fortran90, pag. 1243
!
! Author: W. Imperatori
!
! Modified: January 2009 (v1.3)
!

use def_kind; use interfaces, only: four1d, zroots_unity

implicit none

real(kind=r_single),dimension(:),intent(inout)     :: data
integer(kind=i_single),intent(in)                  :: isign
complex(kind=r_single),dimension(:),optional,target:: zdata
! local variables
integer(kind=i_single)                             :: n,ndum,nh,nq
complex(kind=r_single),dimension(size(data)/4)     :: w
complex(kind=r_single),dimension(size(data)/4-1)   :: h1,h2
complex(kind=r_single),dimension(:),pointer        :: cdata
complex(kind=r_single)                             :: z
real(kind=r_single)                                :: c1=0.5,c2

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

n=size(data)

if ( iand(n,n-1) /= 0 ) call error_handling(5,'null','realft (fft.f90)')

nh=n/2
nq=n/4

if (present(zdata)) then

   if ( n/2 /= size(zdata) ) call error_handling(7,'null','realft (fft.f90)')

   ndum=size(zdata)
   cdata=>zdata
   if (isign == 1) cdata=cmplx(data(1:n-1:2),data(2:n:2),kind=r_single)
else
   allocate(cdata(n/2))
   cdata=cmplx(data(1:n-1:2),data(2:n:2),kind=r_single)
endif

if (isign == 1) then
   c2=-0.5
   call four1d(cdata,+1)
else
   c2=0.5
endif

w=zroots_unity(sign(n,isign),n/4)
w=cmplx(-aimag(w),real(w),kind=r_single)
h1=c1*(cdata(2:nq)+conjg(cdata(nh:nq+2:-1)))
h2=c2*(cdata(2:nq)-conjg(cdata(nh:nq+2:-1)))
cdata(2:nq)=h1+w(2:nq)*h2
cdata(nh:nq+2:-1)=conjg(h1-w(2:nq)*h2)
z=cdata(1)

if (isign == 1) then
   cdata(1)=cmplx(real(z)+aimag(z),real(z)-aimag(z),kind=r_single)
else
   cdata(1)=cmplx(c1*(real(z)+aimag(z)),c1*(real(z)-aimag(z)),kind=r_single)
   call four1d(cdata,-1)
endif

if (present(zdata)) then
   if (isign /= 1) then
      data(1:n-1:2)=real(cdata)
      data(2:n:2)=aimag(cdata)
   endif
else
   data(1:n-1:2)=real(cdata)
   data(2:n:2)=aimag(cdata)
   deallocate(cdata)
endif

END SUBROUTINE realft

!===================================================================================================

FUNCTION arth(first,increment,n)
!-------------------------------------------------------
!
! Description:
!
!   Return an arithmetic progression
!
! Dependencies:
!
!   None
!
! References:
!
!   Numerical Recipes in Fortran90, pag. 1371
!
! Author: W. Imperatori
!
! Modified: January 2009 (v1.3)
!

use def_kind

implicit none

integer(kind=i_single),intent(in)  :: first,increment,n
integer(kind=i_single),dimension(n):: arth
! local variables
integer(kind=i_single)             :: k,k2,temp
integer(kind=i_single),parameter   :: NPAR_ARTH=16,NPAR2_ARTH=8

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

if (n > 0) arth(1)=first

if (n <= NPAR_ARTH) then

   do k=2,n
      arth(k)=arth(k-1)+increment
   enddo

else

   do k=2,NPAR2_ARTH
      arth(k)=arth(k-1)+increment
   enddo

   temp=increment*NPAR2_ARTH
   k=NPAR2_ARTH

   do
      if (k >= n) exit
         k2=k+k
         arth(k+1:min(k2,n))=temp+arth(1:min(k,n-k))
         temp=temp+temp
         k=k2
   enddo

endif

END FUNCTION arth

!===================================================================================================

SUBROUTINE swap(a,b)
!-------------------------------------------------------
!
! Description:
!
!   Swap the content of a and b
!
! Dependencies:
!
!   None
!
! References:
!
!   Numerical Recipes in Fortran90, pag. 1366-1367
!
! Author: W. Imperatori
!
! Modified: January 2009 (v1.3)
!

use def_kind

implicit none

! arrays to be swapped
complex(kind=r_single),dimension(:),intent(inout):: a,b
! local variable
complex(kind=r_single),dimension(size(a))        :: dum

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

dum=a
a=b
b=dum

END SUBROUTINE swap

!===================================================================================================

FUNCTION zroots_unity(n,nn)
!-------------------------------------------------------
!
! Description:
!
!   Return nn powers of the n-th root of unity
!
! Dependencies:
!
!   None
!
! References:
!
!   Numerical Recipes in Fortran90, pag. 1379
!
! Author: W. Imperatori
!
! Modified: January 2009 (v1.3)
!

use constants; use def_kind

implicit none

! input variables
integer(kind=i_single),intent(in)   :: n,nn
! function
complex(kind=r_single),dimension(nn):: zroots_unity
! local variables
integer(kind=i_single)              :: k
real(kind=r_single)                 :: theta

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

zroots_unity(1)=1.0
theta=pi_double/n
k=1

do
   if (k >= nn) exit
   zroots_unity(k+1)=cmplx(cos(k*theta),sin(k*theta),kind=r_single)
   zroots_unity(k+2:min(2*k,nn))=zroots_unity(k+1)*zroots_unity(2:min(k,nn-k))
   k=2*k
enddo

END FUNCTION zroots_unity


C$Procedure      ROTATE ( Generate a rotation matrix )

      SUBROUTINE ROTATE ( ANGLE, IAXIS, MOUT )

C$ Abstract
C
C      Calculate the 3x3 rotation matrix generated by a rotation
C      of a specified angle about a specified axis. This rotation
C      is thought of as rotating the coordinate system.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C      MATRIX,  ROTATION
C
C$ Declarations

      DOUBLE PRECISION   ANGLE
      INTEGER            IAXIS
      DOUBLE PRECISION   MOUT  ( 3,3 )

C$ Brief_I/O
C
C      VARIABLE  I/O              DESCRIPTION
C      --------  ---  --------------------------------------------------
C       ANGLE     I     Angle of rotation (radians).
C       IAXIS     I     Axis of rotation (X=1, Y=2, Z=3).
C       MOUT      O     Resulting rotation matrix [ANGLE]
C                                                       IAXIS
C$ Detailed_Input
C
C      ANGLE   The angle given in radians, through which the rotation
C              is performed.
C
C      IAXIS   The index of the axis of rotation.  The X, Y, and Z
C              axes have indices 1, 2 and 3 respectively.
C
C$ Detailed_Output
C
C      MOUT    Rotation matrix which describes the rotation of the
C               COORDINATE system through ANGLE radians about the
C               axis whose index is IAXIS.
C
C$ Parameters
C
C      None.
C
C$ Particulars
C
C      A rotation about the first, i.e. x-axis, is described by
C
C      |  1        0          0      |
C      |  0   cos(theta) sin(theta)  |
C      |  0  -sin(theta) cos(theta)  |
C
C      A rotation about the second, i.e. y-axis, is described by
C
C      |  cos(theta)  0  -sin(theta)  |
C      |      0       1        0      |
C      |  sin(theta)  0   cos(theta)  |
C
C      A rotation about the third, i.e. z-axis, is described by
C
C      |  cos(theta) sin(theta)   0   |
C      | -sin(theta) cos(theta)   0   |
C      |       0          0       1   |
C
C      ROTATE decides which form is appropriate according to the value
C      of IAXIS.
C
C$ Examples
C
C      If ROTATE is called from a FORTRAN program as follows:
C
C            CALL ROTATE (PI/4, 3, MOUT)
C
C      then MOUT will be given by
C
C                   | SQRT(2)/2   SQRT(2)/2   0  |
C            MOUT = |-SQRT(2)/2   SQRT(2)/2   0  |
C                   |     0           0       1  |
C
C$ Restrictions
C
C      None.
C
C$ Exceptions
C
C     Error free.
C
C     1) If the axis index is not in the range 1 to 3 it will be
C        treated the same as that integer 1, 2, or 3 that is congruent
C        to it mod 3.
C
C$ Files
C
C      None.
C
C$ Author_and_Institution
C
C      W.M. Owen       (JPL)
C      W.L. Taber      (JPL)
C
C$ Literature_References
C
C      None.
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WMO)
C
C-&

C$ Index_Entries
C
C     generate a rotation matrix
C
C-&

C$ Revisions
C
C-    Beta Version 1.1.0, 3-JAN-1989 (WLT)
C
C     Upgrade the routine to work with negative axis indexes.  Also take
C     care of the funky way the indices (other than the input) were
C     obtained via the MOD function.  It works but isn't as clear
C     (or fast) as just reading the axes from data.
C
C-&
C
C
      DOUBLE PRECISION      S
      DOUBLE PRECISION      C

      INTEGER               TEMP
      INTEGER               I1
      INTEGER               I2
      INTEGER               I3
      INTEGER               INDEXS ( 5 )
      SAVE                  INDEXS

      DATA                  INDEXS  / 3, 1, 2, 3, 1 /
C
C  Get the sine and cosine of ANGLE
C
      S = DSIN(ANGLE)
      C = DCOS(ANGLE)
C
C  Get indices for axes. The first index is for the axis of rotation.
C  The next two axes follow in right hand order (XYZ).  First get the
C  non-negative value of IAXIS mod 3 .
C
      TEMP = MOD ( MOD(IAXIS,3) + 3, 3 )

      I1 = INDEXS( TEMP + 1 )
      I2 = INDEXS( TEMP + 2 )
      I3 = INDEXS( TEMP + 3 )

C
C  Construct the rotation matrix
C
      MOUT(I1,I1) = 1.D0
      MOUT(I2,I1) = 0.D0
      MOUT(I3,I1) = 0.D0
      MOUT(I1,I2) = 0.D0
      MOUT(I2,I2) = C
      MOUT(I3,I2) = -S
      MOUT(I1,I3) = 0.D0
      MOUT(I2,I3) = S
      MOUT(I3,I3) = C
C
      RETURN
      END


module libfft
	use mylib
	CONTAINS
subroutine dft(input_file, x_fft)
    implicit none
	! dummy vars
	character (len=30) :: input_file
	complex, dimension(:), allocatable :: x_fft

	! local vars
	real, parameter :: PI = 4*atan(1.0)
    real, dimension(:), allocatable :: x
    integer :: N, k, i
	complex :: A, x_fft_sum

    ! Find how many lines are in the file
    call number_of_lines(input_file, N)

	! Load data from input_file
    allocate(x(N))
    call loadArrayFromFile(input_file, N, x)

	! allocate memory for FFT array
    allocate(x_fft(N))

	! Main Loop
	do k=1,N
		A = exp(cmplx(0,-2*PI*k/N))
		x_fft_sum = 0
		do i=1,N
			x_fft_sum = x_fft_sum + x(i) * (A**i)
		enddo
		x_fft(k) = x_fft_sum
	enddo

end subroutine

end module libfft


program compute_stats_test
    use, intrinsic :: iso_fortran_env, only : sp => REAL32
    implicit none
    type stats_type
        real(kind=sp) :: sum, mean, stddev
        integer :: n
    end type stats_type
    type(stats_type) :: stats
    integer, parameter :: data_size = 10
    real(kind=sp), dimension(data_size) :: v
    real(kind=sp) :: mean, stddev
    call init_vector(v)
    call compute_stats(v, mean, stddev)
    print '(2(A14, F10.5))', 'mean = ', mean, 'stddev = ', stddev
    stats = compute_stats_alt(v)
    print '(2(A14, F10.5))', 'mean = ', mean, 'stddev = ', stddev

contains

    subroutine init_vector(v)
        implicit none
        real(kind=sp), dimension(:), intent(inout) :: v
        integer :: i
        v = [ (real(i, kind=sp), i = 1, size(v)) ]
    end subroutine init_vector

    subroutine compute_stats(v, mean, stddev)
        implicit none
        real(kind=sp), dimension(:), intent(in) :: v
        real(kind=sp), intent(out) :: mean, stddev
        real(kind=sp) :: s, s2
        integer :: n
        n = size(v)
        s = sum(v)
        s2 = sum(v*v)
        mean = s/n
        stddev = sqrt((s*s - s2)/(n - 1))
    end subroutine compute_stats

    function compute_stats_alt(v) result(stats)
        implicit none
        real(kind=sp), dimension(:), intent(in) :: v
        type(stats_type) :: stats
        real(kind=sp) :: sum2
        stats%n = size(v)
        stats%sum = sum(v)
        sum2 = sum(v**2)
        stats%mean = stats%sum/stats%n
        stats%stddev = sqrt((stats%sum**2 - sum2)/(stats%n - 1))
    end function compute_stats_alt

end program compute_stats_test