module constants
implicit none
real, parameter :: pi = 3.1415926536
real, parameter :: e  = 2.716834

contains

	subroutine show_consts()
print*,"pi=pi",pi
print*,"e =e",  e
end subroutine show_consts

function ePower(x),result(ePx)
implicit none
real :: x
real ::ePx
ePx = e**x
end function ePower(x)

function areaCircle(r),result(a)
implicit none
real :: r
real :: a
a = pi*r**2
end function areaCircle(r)
end module constants

program module_example
use constants
implicit none

call show_consts()
print*,"e raised to power 2.0 =", epowerx (2.0)
print*,"area of circle with radius 7.0 =", area(7.0)
end program module_example


! 4670 Numerical Analysis
! Homework Four Due 11/6/17

module secret

integer :: fcounter

end module secret

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

program WebberHomework4Question1
use secret
implicit none

double precision :: a, b, f, h, n
double precision :: actual!, t, trapezoid
double precision :: simpson, s
integer :: i!, n

a = 1.0d0
b = 2.0d0
n = 2.0d0
actual = log(2.0d0)

print*, "Newton and Composite Simpson Method"

do i = 1, 25
	h = (b - a) / dble(n)
print*, h
	s = simpson(n, a, b, f)
print*, s
	!write(*,* ) n, s, abs(actual - s), abs(actual - s) / h**4.0d0
	print*, n, s, abs(actual - s), abs(actual - s) / h**4.0d0
	n = n * 2.0d0
print*, n
end do

stop
end program WebberHomework4Question1

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

double precision function fprime(x)
implicit none
double precision :: f, pi, x

f = exp(1.0d0)
pi = (4.0d0 * ATAN(1.0d0))						! most accurate for pi

fprime = (1.0d0 / SQRT(2.0d0 * pi)) * (f**(-x**2.0d0) / 2.0d0)

return
end

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

double precision function simpson(n, a, b, fprime)
implicit none

integer :: i!, n
double precision :: a, b, fv, h, n, fprime
double precision :: se, so

h = (b - a) / dble(n)

simpson = 0.0d0
se = 0.0d0
so = 0.0d0

do i = 1, n - 1
	fv = fprime(a + dble(i) * h)
	if (mod(i, 2) == 0) then
		se = se + fv
	else
		so = so + fv
	end if
end do

simpson = (h / 3.0d0 * (fprime(a) + fprime(b) + 2.0d0 * se + 4.0d0 * so))

return
end

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

double precision function trapezoid(n, a, b, fprime)
implicit none

integer :: i, n
double precision :: a, b, fprime, h, xuse

h = (b - a) / dble(n)

trapezoid = 0.0d0

do i = 1, n - 1
	xuse = a + dble(i) * h
	trapezoid = fprime + fprime(xuse)
end do

trapezoid = h / 2.0d0 * (2.0d0 * trapezoid + fprime(a) + fprime(b))

return
end


      SUBROUTINE MB02QY( M, N, NRHS, RANK, A, LDA, JPVT, B, LDB, TAU,
     $                   DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To determine the minimum-norm solution to a real linear least
C     squares problem:
C
C         minimize || A * X - B ||,
C
C     using the rank-revealing QR factorization of a real general
C     M-by-N matrix  A,  computed by SLICOT Library routine  MB03OD.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows of the matrices A and B.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns of the matrix A.  N >= 0.
C
C     NRHS    (input) INTEGER
C             The number of columns of the matrix B.  NRHS >= 0.
C
C     RANK    (input) INTEGER
C             The effective rank of  A,  as returned by SLICOT Library
C             routine  MB03OD.  min(M,N) >= RANK >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension
C             ( LDA, N )
C             On entry, the leading min(M,N)-by-N upper trapezoidal
C             part of this array contains the triangular factor  R,  as
C             returned by SLICOT Library routine  MB03OD.  The strict
C             lower trapezoidal part of  A  is not referenced.
C             On exit, if  RANK < N,  the leading  RANK-by-RANK  upper
C             triangular part of this array contains the upper
C             triangular matrix  R  of the complete orthogonal
C             factorization of  A,  and the submatrix  (1:RANK,RANK+1:N)
C             of this array, with the array  TAU,  represent the
C             orthogonal matrix  Z  (of the complete orthogonal
C             factorization of  A),  as a product of  RANK  elementary
C             reflectors.
C             On exit, if  RANK = N,  this array is unchanged.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,M).
C
C     JPVT    (input) INTEGER array, dimension ( N )
C             The recorded permutations performed by SLICOT Library
C             routine  MB03OD;  if  JPVT(i) = k,  then the i-th column
C             of  A*P  was the k-th column of the original matrix  A.
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C             ( LDB, NRHS )
C             On entry, if  NRHS > 0,  the leading M-by-NRHS part of
C             this array must contain the matrix  B  (corresponding to
C             the transformed matrix  A,  returned by SLICOT Library
C             routine  MB03OD).
C             On exit, if  NRHS > 0,  the leading N-by-NRHS part of this
C             array contains the solution matrix X.
C             If  M >= N  and  RANK = N,  the residual sum-of-squares
C             for the solution in the i-th column is given by the sum
C             of squares of elements  N+1:M  in that column.
C             If  NRHS = 0,  the array  B  is not referenced.
C
C     LDB     INTEGER
C             The leading dimension of the array B.
C             LDB >= max(1,M,N),  if  NRHS > 0.
C             LDB >= 1,           if  NRHS = 0.
C
C     TAU     (output) DOUBLE PRECISION array, dimension ( min(M,N) )
C             The scalar factors of the elementary reflectors.
C             If  RANK = N,  the array  TAU  is not referenced.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension ( LDWORK )
C             On exit, if  INFO = 0,  DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= max( 1, N, NRHS ).
C             For good performance,  LDWORK  should sometimes be larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value.
C
C     METHOD
C
C     The routine uses a QR factorization with column pivoting:
C
C        A * P = Q * R = Q * [ R11 R12 ],
C                            [  0  R22 ]
C
C     where  R11  is an upper triangular submatrix of estimated rank
C     RANK,  the effective rank of  A.  The submatrix  R22  can be
C     considered as negligible.
C
C     If  RANK < N,  then  R12  is annihilated by orthogonal
C     transformations from the right, arriving at the complete
C     orthogonal factorization:
C
C        A * P = Q * [ T11 0 ] * Z.
C                    [  0  0 ]
C
C     The minimum-norm solution is then
C
C        X = P * Z' [ inv(T11)*Q1'*B ],
C                   [        0       ]
C
C     where Q1 consists of the first  RANK  columns of Q.
C
C     The input data for  MB02QY  are the transformed matrices  Q' * A
C     (returned by SLICOT Library routine  MB03OD)  and  Q' * B.
C     Matrix  Q  is not needed.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically stable.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Aug. 2011.
C
C     KEYWORDS
C
C     Least squares solutions; QR decomposition.
C
C    ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LDWORK, M, N, NRHS, RANK
C     .. Array Arguments ..
      INTEGER            JPVT( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), DWORK( * ), TAU( * )
C     .. Local Scalars ..
      LOGICAL            LQUERY
      INTEGER            I, IASCL, IBSCL, J, MN
      DOUBLE PRECISION   ANRM, BIGNUM, BNRM, MAXWRK, SMLNUM
C     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLANGE, DLANTR
      EXTERNAL           DLAMCH, DLANGE, DLANTR
C     .. External Subroutines ..
      EXTERNAL           DCOPY, DLABAD, DLASCL, DLASET, DORMRZ, DTRSM,
     $                   DTZRZF, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MAX, MIN
C     ..
C     .. Executable Statements ..
C
      MN = MIN( M, N )
C
C     Test the input scalar arguments.
C
      INFO = 0
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( NRHS.LT.0 ) THEN
         INFO = -3
      ELSE IF( RANK.LT.0 .OR. RANK.GT.MN ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.1 .OR. ( NRHS.GT.0 .AND. LDB.LT.MAX( M, N ) ) )
     $      THEN
         INFO = -9
      ELSE
         I      = MAX( 1, N, NRHS )
         LQUERY = LDWORK.EQ.-1
         IF ( LQUERY ) THEN
            RANK = MAX( 0, N-1 )
            CALL DTZRZF( RANK, N, A, LDA, TAU, DWORK, -1, INFO )
            MAXWRK = MAX( DBLE( I ), DWORK( 1 ) )
            CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A,
     $                   LDA, TAU, B, LDB, DWORK, -1, INFO )
            MAXWRK = MAX( MAXWRK, DWORK( 1 ) )
         END IF
         IF( LDWORK.LT.I .AND. .NOT.LQUERY )
     $      INFO = -12
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'MB02QY', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = MAXWRK
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( MIN( MN, NRHS ).EQ.0 ) THEN
         DWORK( 1 ) = ONE
         RETURN
      END IF
C
C     Logically partition R = [ R11 R12 ],
C                             [  0  R22 ]
C
C     where R11 = R(1:RANK,1:RANK).  If  RANK = N,  let  T11 = R11.
C
      MAXWRK = DBLE( N )
      IF( RANK.LT.N ) THEN
C
C        Get machine parameters.
C
         SMLNUM = DLAMCH( 'Safe minimum' ) / DLAMCH( 'Precision' )
         BIGNUM = ONE / SMLNUM
         CALL DLABAD( SMLNUM, BIGNUM )
C
C        Scale A, B if max entries outside range [SMLNUM,BIGNUM].
C
         ANRM = DLANTR( 'MaxNorm', 'Upper', 'Non-unit', RANK, N, A, LDA,
     $                  DWORK )
         IASCL = 0
         IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
C
C           Scale matrix norm up to SMLNUM.
C
            CALL DLASCL( 'Upper', 0, 0, ANRM, SMLNUM, RANK, N, A, LDA,
     $                   INFO )
            IASCL = 1
         ELSE IF( ANRM.GT.BIGNUM ) THEN
C
C           Scale matrix norm down to BIGNUM.
C
            CALL DLASCL( 'Upper', 0, 0, ANRM, BIGNUM, RANK, N, A, LDA,
     $                   INFO )
            IASCL = 2
         ELSE IF( ANRM.EQ.ZERO ) THEN
C
C           Matrix all zero. Return zero solution.
C
            CALL DLASET( 'Full', N, NRHS, ZERO, ZERO, B, LDB )
            DWORK( 1 ) = ONE
            RETURN
         END IF
C
         BNRM = DLANGE( 'MaxNorm', M, NRHS, B, LDB, DWORK )
         IBSCL = 0
         IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
C
C           Scale matrix norm up to SMLNUM.
C
            CALL DLASCL( 'General', 0, 0, BNRM, SMLNUM, M, NRHS, B, LDB,
     $                   INFO )
            IBSCL = 1
         ELSE IF( BNRM.GT.BIGNUM ) THEN
C
C           Scale matrix norm down to BIGNUM.
C
            CALL DLASCL( 'General', 0, 0, BNRM, BIGNUM, M, NRHS, B, LDB,
     $                   INFO )
            IBSCL = 2
         END IF
C
C        [R11,R12] = [ T11, 0 ] * Z.
C        Details of Householder rotations are stored in TAU.
C        Workspace need RANK, prefer RANK*NB.
C
         CALL DTZRZF( RANK, N, A, LDA, TAU, DWORK, LDWORK, INFO )
         MAXWRK = MAX( MAXWRK, DWORK( 1 ) )
      END IF
C
C     B(1:RANK,1:NRHS) := inv(T11) * B(1:RANK,1:NRHS).
C
      CALL DTRSM( 'Left', 'Upper', 'No transpose', 'Non-unit', RANK,
     $            NRHS, ONE, A, LDA, B, LDB )
C
      IF( RANK.LT.N ) THEN
C
         CALL DLASET( 'Full', N-RANK, NRHS, ZERO, ZERO, B( RANK+1, 1 ),
     $                LDB )
C
C        B(1:N,1:NRHS) := Z' * B(1:N,1:NRHS).
C        Workspace need NRHS, prefer NRHS*NB.
C
         CALL DORMRZ( 'Left', 'Transpose', N, NRHS, RANK, N-RANK, A,
     $                LDA, TAU, B, LDB, DWORK, LDWORK, INFO )
         MAXWRK = MAX( MAXWRK, DWORK( 1 ) )
C
C        Undo scaling.
C
         IF( IASCL.EQ.1 ) THEN
            CALL DLASCL( 'General', 0, 0, ANRM, SMLNUM, N, NRHS, B, LDB,
     $                   INFO )
            CALL DLASCL( 'Upper', 0, 0, SMLNUM, ANRM, RANK, RANK, A,
     $                   LDA, INFO )
         ELSE IF( IASCL.EQ.2 ) THEN
            CALL DLASCL( 'General', 0, 0, ANRM, BIGNUM, N, NRHS, B, LDB,
     $                   INFO )
            CALL DLASCL( 'Upper', 0, 0, BIGNUM, ANRM, RANK, RANK, A,
     $                   LDA, INFO )
         END IF
         IF( IBSCL.EQ.1 ) THEN
            CALL DLASCL( 'General', 0, 0, SMLNUM, BNRM, N, NRHS, B, LDB,
     $                   INFO )
         ELSE IF( IBSCL.EQ.2 ) THEN
            CALL DLASCL( 'General', 0, 0, BIGNUM, BNRM, N, NRHS, B, LDB,
     $                   INFO )
         END IF
      END IF
C
C     B(1:N,1:NRHS) := P * B(1:N,1:NRHS).
C     Workspace N.
C
      DO 20 J = 1, NRHS
C
         DO 10 I = 1, N
            DWORK( JPVT( I ) ) = B( I, J )
   10    CONTINUE
C
         CALL DCOPY( N, DWORK, 1, B( 1, J ), 1 )
   20 CONTINUE
C
      DWORK( 1 ) = MAXWRK
      RETURN
C
C *** Last line of MB02QY ***
      END


module rational_numbers
  implicit none
contains

  function add(r1,r2)
    integer,dimension(2) :: add, r1,r2
    !(a1 * b2 + a2 * b1) / (b1 * b2)
    add(1) = r1(1)*r2(2)+r2(1)*r1(2)
    add(2) = r1(2)*r2(2)
    add = reduce(add)
  end function

  function sub(r1,r2)
    integer,dimension(2) :: sub, r1,r2
    !r₁ - r₂ = a₁/b₁ - a₂/b₂ = (a₁ * b₂ - a₂ * b₁) / (b₁ * b₂).
    sub(1) = r1(1)*r2(2)-r2(1)*r1(2)
    sub(2) = r1(2)*r2(2)
    sub = reduce(sub)
  end function

  function mul(r1,r2)
    integer,dimension(2) :: mul, r1,r2
    !r₁ * r₂ = (a₁ * a₂) / (b₁ * b₂).
    mul(1) = r1(1)*r2(1)
    mul(2) = r1(2)*r2(2)
    mul = reduce(mul)
  end function

  function div(r1,r2)
    integer,dimension(2) :: div, r1,r2
    ! r₁ / r₂ = (a₁ * b₂) / (a₂ * b₁)
    div(1) = r1(1)*r2(2)
    div(2) = r1(2)*r2(1)
    div = reduce(div)
  end function

  function rational_abs(r1)
    integer,dimension(2) :: rational_abs, r1
    rational_abs(1) = abs(r1(1))
    rational_abs(2) = abs(r1(2))
  end function

  function rational_to_pow(r1, ex)
    integer,dimension(2) :: rational_to_pow, r1
    integer :: ex
    !(a1 * b2 + a2 * b1) / (b1 * b2)
    rational_to_pow(1) = r1(1)**ex
    rational_to_pow(2) = r1(2)**ex
  end function

  function real_to_rational_pow(ex,r1)
    integer,dimension(2) ::  r1
    real :: real_to_rational_pow,ex
    !(a1 * b2 + a2 * b1) / (b1 * b2)
    if ( r1(1)==0 ) then
      real_to_rational_pow=0.0
    else
      real_to_rational_pow = ex**(real(r1(1))/real(r1(2)))
    endif
  end function

  function gcd(m,n)
    integer,intent(in)  :: m, n
    integer :: gcd,irest,ifirst
    ifirst=abs(m)
    gcd=abs(n)
    if(gcd==0)then
      gcd=ifirst
    else
      do
        irest = mod(ifirst,gcd)
        if(irest == 0)  exit
        ifirst = gcd
        gcd = irest
      enddo
      gcd= abs(gcd)
    endif
  end function

  function reduce(r1)
    integer,dimension(2) :: reduce, r1
    integer :: gcd_num
    !(a1 * b2 + a2 * b1) / (b1 * b2)
    gcd_num = gcd(r1(1),r1(2))
    reduce(:) = r1(:)/gcd_num
    if (reduce(2)<0)then ! fix sign
      reduce = -reduce
    endif
  end function

end module


c=======================================================================
c
c     subroutine PEMRJBM
c
c     Mean Reversion with Jump process (Marlim Model)
c
c                S(t) = delta*(mu - S(t))dt + sigma*dW(t) + dq
c
c                Poisson process dq
c
c                dq = 0   with probability (1-lambda)dt
c                   = phi with probability lambda*dt
c
c     Method: Euler discretization of SDE
c
c                S(1)   = S
c                a      = exp(- delta*dt )
c                b      = sqrt((1 - exp(- 2*delta*dt))/(2*delta))
c                S(t+1) = S(t)*a + mu*(1 - a) + sigma*b*N(0,1)
c
c                with dt = T/(N-1)
c
c-----------------------------------------------------------------------
c
c     INPUT :
c            T      : time (days, months, years)                 integer
c            N      : number of sub-division(s)                  integer
c            S      : initial value                               double
c            delta  : velocity of the reversion                   double
c            mu     : mean reversion                              double
c            sigma  : process volatility                          double
c            lambda : jump frequency                               double
c            phi    : jump level                                  double
c
c     OUTPUT :
c            y      : generated step (N)                          double
c            info   : diagnostic information                     integer
c
c-----------------------------------------------------------------------
c
      SUBROUTINE pemrjbm ( T, N, S, delta, mu, sigma, lambda, phi,
     &                     y, info )
c
      IMPLICIT NONE
c
c     arguments i/o
      INTEGER N, T, info
      DOUBLE PRECISION S, delta, mu, sigma, lambda, phi, y(*)
c
c     local variables
      INTEGER i, M
      DOUBLE PRECISION dt, jump, u, v, a, b
c
c     external functions
      DOUBLE PRECISION rn, ranf
      EXTERNAL rn, ranf
c
c-----------------------------------------------------------------------
c
c     initialization
      info = 0
      jump = 0
c
c     discetization step
      M  = N - 1
      IF (M .EQ. 0) THEN
        info = -1
        RETURN
      ENDIF
      dt = (dfloat(T)/M)
c
c     local parameters
      a = exp( - delta * dt)
      b = sqrt((1. - exp(- 2.* delta * dt))/(2. * delta))
      v = lambda * dt
c
c     mean-reversion with jump
      y(1) = S
      DO i = 1,M
c
c        uniform random variable U[0,1]
         u = ranf()
         IF (u .lt. v) THEN
            jump = phi
         ELSE
            jump = 0
         ENDIF
         y(i + 1) = (a*y(i)) + (mu*(1. - a)) + (b*sigma*rn()) + jump
      ENDDO
c
      RETURN
      END


      double precision function dnrm2(n,x,incx)
      integer n, incx
      double precision x(n)
c     **********
c
c     Function dnrm2
c
c     Given a vector x of length n, this function calculates the
c     Euclidean norm of x with stride incx.
c
c     The function statement is
c
c       double precision function dnrm2(n,x,incx)
c
c     where
c
c       n is an integer variable.
c         On entry n is the length of x.
c         On exit n is unchanged.
c
c       x is a double precision array of dimension n.
c         On entry x specifies the vector x.
c         On exit x is unchanged.
c
c       incx is an integer variable.
c         On entry incx specifies the stride.
c         On exit incx is unchanged.
c
c     MINPACK-2 Project. October 1993.
c     Argonne National Laboratory and University of Minnesota.
c     Brett M. Averick and Jorge J. More'.
c
c     **********
      double precision zero
      parameter (zero=0.0d0)

      integer i
      double precision scale

      scale = zero
      do 10 i = 1, n, incx
         scale = max(scale,abs(x(i)))
   10 continue

      dnrm2 = zero
      if (scale .eq. zero) return

      do 20 i = 1, n, incx
         dnrm2 = dnrm2 + (x(i)/scale)**2
   20 continue
      dnrm2 = scale*sqrt(dnrm2)

      end


program power
use procedures
implicit none

real(kind=8), allocatable, dimension(:,:) :: a
real(kind=8), allocatable, dimension(:) :: x
real(kind=8) :: some_number, eigenval
integer :: n, i, j, io

write(*,*)

! Determine dimensions of a:
open (unit=2, file='a.txt', status='old', action='read')
n = 0
do
   read(2,*,iostat=io) some_number
   if (io /= 0) exit
      n = n + 1
end do
write(*,*) "number of equations and variables: ", n
write(*,*)
allocate(a(n,n), x(n))

! Assign the elements of a:
rewind(2)
do i = 1, n
   read(2,*) (a(i,j), j = 1,n)
end do
close(2)

write(*,*) "The matrix a:"
call writes2d(a)
write(*,*)

! Assign the elements of x:
x(1) = 1.0d0
x(2) = 1.0d0
x(3) = 1.0d0

eigenval = MaxEig(A)

end program power


ELEMENTAL FUNCTION func_normal_CDF(x, mean, stddev) RESULT(ans)
    ! NOTE: See https://en.wikipedia.org/wiki/Normal_distribution

    USE ISO_FORTRAN_ENV

    IMPLICIT NONE

    ! Declare inputs/outputs ...
    REAL(kind = REAL64)                                                         :: ans
    REAL(kind = REAL64), INTENT(in)                                             :: mean
    REAL(kind = REAL64), INTENT(in)                                             :: stddev
    REAL(kind = REAL64), INTENT(in)                                             :: x

    ! Declare internal variables ...
    REAL(kind = REAL64)                                                         :: tmp

    ! Calculate short-hand ...
    tmp = (x - mean) / (stddev * SQRT(2.0e0_REAL64))

    ! Calculate CDF ...
    ans = 0.5e0_REAL64 * (1.0e0_REAL64 + ERF(tmp))
END FUNCTION func_normal_CDF


module stdlib_math
    use stdlib_kinds, only: int8, int16, int32, int64, sp, dp, qp
    use stdlib_optval, only: optval

    implicit none
    private
    public :: clip, linspace, logspace
    public :: EULERS_NUMBER_SP, EULERS_NUMBER_DP, EULERS_NUMBER_QP
    public :: DEFAULT_LINSPACE_LENGTH, DEFAULT_LOGSPACE_BASE, DEFAULT_LOGSPACE_LENGTH
    public :: arange

    integer, parameter :: DEFAULT_LINSPACE_LENGTH = 100
    integer, parameter :: DEFAULT_LOGSPACE_LENGTH = 50
    integer, parameter :: DEFAULT_LOGSPACE_BASE = 10

    ! Useful constants for lnspace
    real(sp), parameter :: EULERS_NUMBER_SP = exp(1.0_sp)
    real(dp), parameter :: EULERS_NUMBER_DP = exp(1.0_dp)
    real(qp), parameter :: EULERS_NUMBER_QP = exp(1.0_qp)

    interface clip
        module procedure clip_int8
        module procedure clip_int16
        module procedure clip_int32
        module procedure clip_int64
        module procedure clip_sp
        module procedure clip_dp
        module procedure clip_qp
    end interface clip

    interface linspace
    !! Version: Experimental
    !!
    !! Create rank 1 array of linearly spaced elements
    !! If the number of elements is not specified, create an array with size 100. If n is a negative value,
    !! return an array with size 0. If n = 1, return an array whose only element is end
    !!([Specification](../page/specs/stdlib_math.html#linspace-create-a-linearly-spaced-rank-one-array))
      module function linspace_default_1_rsp_rsp(start, end) result(res)
        real(sp), intent(in) :: start
        real(sp), intent(in) :: end

        real(sp) :: res(DEFAULT_LINSPACE_LENGTH)
      end function linspace_default_1_rsp_rsp
      module function linspace_default_1_rdp_rdp(start, end) result(res)
        real(dp), intent(in) :: start
        real(dp), intent(in) :: end

        real(dp) :: res(DEFAULT_LINSPACE_LENGTH)
      end function linspace_default_1_rdp_rdp
      module function linspace_default_1_rqp_rqp(start, end) result(res)
        real(qp), intent(in) :: start
        real(qp), intent(in) :: end

        real(qp) :: res(DEFAULT_LINSPACE_LENGTH)
      end function linspace_default_1_rqp_rqp
      module function linspace_default_1_csp_csp(start, end) result(res)
        complex(sp), intent(in) :: start
        complex(sp), intent(in) :: end

        complex(sp) :: res(DEFAULT_LINSPACE_LENGTH)
      end function linspace_default_1_csp_csp
      module function linspace_default_1_cdp_cdp(start, end) result(res)
        complex(dp), intent(in) :: start
        complex(dp), intent(in) :: end

        complex(dp) :: res(DEFAULT_LINSPACE_LENGTH)
      end function linspace_default_1_cdp_cdp
      module function linspace_default_1_cqp_cqp(start, end) result(res)
        complex(qp), intent(in) :: start
        complex(qp), intent(in) :: end

        complex(qp) :: res(DEFAULT_LINSPACE_LENGTH)
      end function linspace_default_1_cqp_cqp

      module function linspace_n_1_rsp_rsp(start, end, n) result(res)
        real(sp), intent(in) :: start
        real(sp), intent(in) :: end
        integer, intent(in) :: n

        real(sp) :: res(max(n, 0))
      end function linspace_n_1_rsp_rsp
      module function linspace_n_1_rdp_rdp(start, end, n) result(res)
        real(dp), intent(in) :: start
        real(dp), intent(in) :: end
        integer, intent(in) :: n

        real(dp) :: res(max(n, 0))
      end function linspace_n_1_rdp_rdp
      module function linspace_n_1_rqp_rqp(start, end, n) result(res)
        real(qp), intent(in) :: start
        real(qp), intent(in) :: end
        integer, intent(in) :: n

        real(qp) :: res(max(n, 0))
      end function linspace_n_1_rqp_rqp
      module function linspace_n_1_csp_csp(start, end, n) result(res)
        complex(sp), intent(in) :: start
        complex(sp), intent(in) :: end
        integer, intent(in) :: n

        complex(sp) :: res(max(n, 0))
      end function linspace_n_1_csp_csp
      module function linspace_n_1_cdp_cdp(start, end, n) result(res)
        complex(dp), intent(in) :: start
        complex(dp), intent(in) :: end
        integer, intent(in) :: n

        complex(dp) :: res(max(n, 0))
      end function linspace_n_1_cdp_cdp
      module function linspace_n_1_cqp_cqp(start, end, n) result(res)
        complex(qp), intent(in) :: start
        complex(qp), intent(in) :: end
        integer, intent(in) :: n

        complex(qp) :: res(max(n, 0))
      end function linspace_n_1_cqp_cqp

    ! Add support for integer linspace
    !!
    !! When dealing with integers as the `start` and `end` parameters, the return type is always a `real(dp)`.
      module function linspace_default_1_iint8_iint8(start, end) result(res)
        integer(int8), intent(in) :: start
        integer(int8), intent(in) :: end

        real(dp) :: res(DEFAULT_LINSPACE_LENGTH)
      end function linspace_default_1_iint8_iint8
      module function linspace_default_1_iint16_iint16(start, end) result(res)
        integer(int16), intent(in) :: start
        integer(int16), intent(in) :: end

        real(dp) :: res(DEFAULT_LINSPACE_LENGTH)
      end function linspace_default_1_iint16_iint16
      module function linspace_default_1_iint32_iint32(start, end) result(res)
        integer(int32), intent(in) :: start
        integer(int32), intent(in) :: end

        real(dp) :: res(DEFAULT_LINSPACE_LENGTH)
      end function linspace_default_1_iint32_iint32
      module function linspace_default_1_iint64_iint64(start, end) result(res)
        integer(int64), intent(in) :: start
        integer(int64), intent(in) :: end

        real(dp) :: res(DEFAULT_LINSPACE_LENGTH)
      end function linspace_default_1_iint64_iint64

      module function linspace_n_1_iint8_iint8(start, end, n) result(res)
        integer(int8), intent(in) :: start
        integer(int8), intent(in) :: end
        integer, intent(in) :: n

        real(dp) :: res(max(n, 0))
      end function linspace_n_1_iint8_iint8
      module function linspace_n_1_iint16_iint16(start, end, n) result(res)
        integer(int16), intent(in) :: start
        integer(int16), intent(in) :: end
        integer, intent(in) :: n

        real(dp) :: res(max(n, 0))
      end function linspace_n_1_iint16_iint16
      module function linspace_n_1_iint32_iint32(start, end, n) result(res)
        integer(int32), intent(in) :: start
        integer(int32), intent(in) :: end
        integer, intent(in) :: n

        real(dp) :: res(max(n, 0))
      end function linspace_n_1_iint32_iint32
      module function linspace_n_1_iint64_iint64(start, end, n) result(res)
        integer(int64), intent(in) :: start
        integer(int64), intent(in) :: end
        integer, intent(in) :: n

        real(dp) :: res(max(n, 0))
      end function linspace_n_1_iint64_iint64

  end interface

  interface logspace
  !! Version: Experimental
  !!
  !! Create rank 1 array of logarithmically spaced elements from base**start to base**end.
  !! If the number of elements is not specified, create an array with size 50. If n is a negative value,
  !! return an array with size 0. If n = 1, return an array whose only element is base**end. If no base
  !! is specified, logspace will default to using a base of 10
  !!
  !!([Specification](../page/specs/stdlib_math.html#logspace-create-a-logarithmically-spaced-rank-one-array))
    module function logspace_1_rsp_default(start, end) result(res)

      real(sp), intent(in) :: start
      real(sp), intent(in) :: end

      real(sp) :: res(DEFAULT_LOGSPACE_LENGTH)

    end function logspace_1_rsp_default
    module function logspace_1_rdp_default(start, end) result(res)

      real(dp), intent(in) :: start
      real(dp), intent(in) :: end

      real(dp) :: res(DEFAULT_LOGSPACE_LENGTH)

    end function logspace_1_rdp_default
    module function logspace_1_rqp_default(start, end) result(res)

      real(qp), intent(in) :: start
      real(qp), intent(in) :: end

      real(qp) :: res(DEFAULT_LOGSPACE_LENGTH)

    end function logspace_1_rqp_default
    module function logspace_1_csp_default(start, end) result(res)

      complex(sp), intent(in) :: start
      complex(sp), intent(in) :: end

      complex(sp) :: res(DEFAULT_LOGSPACE_LENGTH)

    end function logspace_1_csp_default
    module function logspace_1_cdp_default(start, end) result(res)

      complex(dp), intent(in) :: start
      complex(dp), intent(in) :: end

      complex(dp) :: res(DEFAULT_LOGSPACE_LENGTH)

    end function logspace_1_cdp_default
    module function logspace_1_cqp_default(start, end) result(res)

      complex(qp), intent(in) :: start
      complex(qp), intent(in) :: end

      complex(qp) :: res(DEFAULT_LOGSPACE_LENGTH)

    end function logspace_1_cqp_default
    module function logspace_1_iint32_default(start, end) result(res)

      integer, intent(in) :: start
      integer, intent(in) :: end

      real(dp) :: res(DEFAULT_LOGSPACE_LENGTH)

  end function logspace_1_iint32_default

    module function logspace_1_rsp_n(start, end, n) result(res)
      real(sp), intent(in) :: start
      real(sp), intent(in) :: end
      integer, intent(in) :: n

      real(sp) :: res(max(n, 0))
    end function logspace_1_rsp_n
    module function logspace_1_rdp_n(start, end, n) result(res)
      real(dp), intent(in) :: start
      real(dp), intent(in) :: end
      integer, intent(in) :: n

      real(dp) :: res(max(n, 0))
    end function logspace_1_rdp_n
    module function logspace_1_rqp_n(start, end, n) result(res)
      real(qp), intent(in) :: start
      real(qp), intent(in) :: end
      integer, intent(in) :: n

      real(qp) :: res(max(n, 0))
    end function logspace_1_rqp_n
    module function logspace_1_csp_n(start, end, n) result(res)
      complex(sp), intent(in) :: start
      complex(sp), intent(in) :: end
      integer, intent(in) :: n

      complex(sp) :: res(max(n, 0))
    end function logspace_1_csp_n
    module function logspace_1_cdp_n(start, end, n) result(res)
      complex(dp), intent(in) :: start
      complex(dp), intent(in) :: end
      integer, intent(in) :: n

      complex(dp) :: res(max(n, 0))
    end function logspace_1_cdp_n
    module function logspace_1_cqp_n(start, end, n) result(res)
      complex(qp), intent(in) :: start
      complex(qp), intent(in) :: end
      integer, intent(in) :: n

      complex(qp) :: res(max(n, 0))
    end function logspace_1_cqp_n
    module function logspace_1_iint32_n(start, end, n) result(res)
      integer, intent(in) :: start
      integer, intent(in) :: end
      integer, intent(in) :: n

      real(dp) :: res(n)
    end function logspace_1_iint32_n

    ! Generate logarithmically spaced sequence from sp base to the powers
    ! of sp start and end. [base^start, ... , base^end]
    ! Different combinations of parameter types will lead to different result types.
    ! Those combinations are indicated in the body of each function.
    module function logspace_1_rsp_n_rbase(start, end, n, base) result(res)
      real(sp), intent(in) :: start
      real(sp), intent(in) :: end
      integer, intent(in) :: n
      real(sp), intent(in) :: base
      ! real(sp) endpoints + real(sp) base = real(sp) result
      real(sp) :: res(max(n, 0))
    end function logspace_1_rsp_n_rbase

    module function logspace_1_rsp_n_cbase(start, end, n, base) result(res)
      real(sp), intent(in) :: start
      real(sp), intent(in) :: end
      integer, intent(in) :: n
      complex(sp), intent(in) :: base
      ! real(sp) endpoints + complex(sp) base = complex(sp) result
      real(sp) :: res(max(n, 0))
    end function logspace_1_rsp_n_cbase

    module function logspace_1_rsp_n_ibase(start, end, n, base) result(res)
      real(sp), intent(in) :: start
      real(sp), intent(in) :: end
      integer, intent(in) :: n
      integer, intent(in) :: base
      ! real(sp) endpoints + integer base = real(sp) result
      real(sp) :: res(max(n, 0))
    end function logspace_1_rsp_n_ibase
    ! Generate logarithmically spaced sequence from dp base to the powers
    ! of dp start and end. [base^start, ... , base^end]
    ! Different combinations of parameter types will lead to different result types.
    ! Those combinations are indicated in the body of each function.
    module function logspace_1_rdp_n_rbase(start, end, n, base) result(res)
      real(dp), intent(in) :: start
      real(dp), intent(in) :: end
      integer, intent(in) :: n
      real(dp), intent(in) :: base
      ! real(dp) endpoints + real(dp) base = real(dp) result
      real(dp) :: res(max(n, 0))
    end function logspace_1_rdp_n_rbase

    module function logspace_1_rdp_n_cbase(start, end, n, base) result(res)
      real(dp), intent(in) :: start
      real(dp), intent(in) :: end
      integer, intent(in) :: n
      complex(dp), intent(in) :: base
      ! real(dp) endpoints + complex(dp) base = complex(dp) result
      real(dp) :: res(max(n, 0))
    end function logspace_1_rdp_n_cbase

    module function logspace_1_rdp_n_ibase(start, end, n, base) result(res)
      real(dp), intent(in) :: start
      real(dp), intent(in) :: end
      integer, intent(in) :: n
      integer, intent(in) :: base
      ! real(dp) endpoints + integer base = real(dp) result
      real(dp) :: res(max(n, 0))
    end function logspace_1_rdp_n_ibase
    ! Generate logarithmically spaced sequence from qp base to the powers
    ! of qp start and end. [base^start, ... , base^end]
    ! Different combinations of parameter types will lead to different result types.
    ! Those combinations are indicated in the body of each function.
    module function logspace_1_rqp_n_rbase(start, end, n, base) result(res)
      real(qp), intent(in) :: start
      real(qp), intent(in) :: end
      integer, intent(in) :: n
      real(qp), intent(in) :: base
      ! real(qp) endpoints + real(qp) base = real(qp) result
      real(qp) :: res(max(n, 0))
    end function logspace_1_rqp_n_rbase

    module function logspace_1_rqp_n_cbase(start, end, n, base) result(res)
      real(qp), intent(in) :: start
      real(qp), intent(in) :: end
      integer, intent(in) :: n
      complex(qp), intent(in) :: base
      ! real(qp) endpoints + complex(qp) base = complex(qp) result
      real(qp) :: res(max(n, 0))
    end function logspace_1_rqp_n_cbase

    module function logspace_1_rqp_n_ibase(start, end, n, base) result(res)
      real(qp), intent(in) :: start
      real(qp), intent(in) :: end
      integer, intent(in) :: n
      integer, intent(in) :: base
      ! real(qp) endpoints + integer base = real(qp) result
      real(qp) :: res(max(n, 0))
    end function logspace_1_rqp_n_ibase
    ! Generate logarithmically spaced sequence from sp base to the powers
    ! of sp start and end. [base^start, ... , base^end]
    ! Different combinations of parameter types will lead to different result types.
    ! Those combinations are indicated in the body of each function.
    module function logspace_1_csp_n_rbase(start, end, n, base) result(res)
      complex(sp), intent(in) :: start
      complex(sp), intent(in) :: end
      integer, intent(in) :: n
      real(sp), intent(in) :: base
      ! complex(sp) endpoints + real(sp) base = complex(sp) result
      complex(sp) :: res(max(n, 0))
    end function logspace_1_csp_n_rbase

    module function logspace_1_csp_n_cbase(start, end, n, base) result(res)
      complex(sp), intent(in) :: start
      complex(sp), intent(in) :: end
      integer, intent(in) :: n
      complex(sp), intent(in) :: base
      ! complex(sp) endpoints + complex(sp) base = complex(sp) result
      complex(sp) :: res(max(n, 0))
    end function logspace_1_csp_n_cbase

    module function logspace_1_csp_n_ibase(start, end, n, base) result(res)
      complex(sp), intent(in) :: start
      complex(sp), intent(in) :: end
      integer, intent(in) :: n
      integer, intent(in) :: base
      ! complex(sp) endpoints + integer base = complex(sp) result
      complex(sp) :: res(max(n, 0))
    end function logspace_1_csp_n_ibase
    ! Generate logarithmically spaced sequence from dp base to the powers
    ! of dp start and end. [base^start, ... , base^end]
    ! Different combinations of parameter types will lead to different result types.
    ! Those combinations are indicated in the body of each function.
    module function logspace_1_cdp_n_rbase(start, end, n, base) result(res)
      complex(dp), intent(in) :: start
      complex(dp), intent(in) :: end
      integer, intent(in) :: n
      real(dp), intent(in) :: base
      ! complex(dp) endpoints + real(dp) base = complex(dp) result
      complex(dp) :: res(max(n, 0))
    end function logspace_1_cdp_n_rbase

    module function logspace_1_cdp_n_cbase(start, end, n, base) result(res)
      complex(dp), intent(in) :: start
      complex(dp), intent(in) :: end
      integer, intent(in) :: n
      complex(dp), intent(in) :: base
      ! complex(dp) endpoints + complex(dp) base = complex(dp) result
      complex(dp) :: res(max(n, 0))
    end function logspace_1_cdp_n_cbase

    module function logspace_1_cdp_n_ibase(start, end, n, base) result(res)
      complex(dp), intent(in) :: start
      complex(dp), intent(in) :: end
      integer, intent(in) :: n
      integer, intent(in) :: base
      ! complex(dp) endpoints + integer base = complex(dp) result
      complex(dp) :: res(max(n, 0))
    end function logspace_1_cdp_n_ibase
    ! Generate logarithmically spaced sequence from qp base to the powers
    ! of qp start and end. [base^start, ... , base^end]
    ! Different combinations of parameter types will lead to different result types.
    ! Those combinations are indicated in the body of each function.
    module function logspace_1_cqp_n_rbase(start, end, n, base) result(res)
      complex(qp), intent(in) :: start
      complex(qp), intent(in) :: end
      integer, intent(in) :: n
      real(qp), intent(in) :: base
      ! complex(qp) endpoints + real(qp) base = complex(qp) result
      complex(qp) :: res(max(n, 0))
    end function logspace_1_cqp_n_rbase

    module function logspace_1_cqp_n_cbase(start, end, n, base) result(res)
      complex(qp), intent(in) :: start
      complex(qp), intent(in) :: end
      integer, intent(in) :: n
      complex(qp), intent(in) :: base
      ! complex(qp) endpoints + complex(qp) base = complex(qp) result
      complex(qp) :: res(max(n, 0))
    end function logspace_1_cqp_n_cbase

    module function logspace_1_cqp_n_ibase(start, end, n, base) result(res)
      complex(qp), intent(in) :: start
      complex(qp), intent(in) :: end
      integer, intent(in) :: n
      integer, intent(in) :: base
      ! complex(qp) endpoints + integer base = complex(qp) result
      complex(qp) :: res(max(n, 0))
    end function logspace_1_cqp_n_ibase
    ! Generate logarithmically spaced sequence from qp base to the powers
    ! of qp start and end. [base^start, ... , base^end]
    ! Different combinations of parameter types will lead to different result types.
    ! Those combinations are indicated in the body of each function.
    module function logspace_1_iint32_n_rspbase(start, end, n, base) result(res)
      integer, intent(in) :: start
      integer, intent(in) :: end
      integer, intent(in) :: n
      real(sp), intent(in) :: base
      ! integer endpoints + real(sp) base = real(sp) result
      real(sp) :: res(max(n, 0))
    end function logspace_1_iint32_n_rspbase

    module function logspace_1_iint32_n_cspbase(start, end, n, base) result(res)
      integer, intent(in) :: start
      integer, intent(in) :: end
      integer, intent(in) :: n
      complex(sp), intent(in) :: base
      ! integer endpoints + complex(sp) base = complex(sp) result
      complex(sp) :: res(max(n, 0))
    end function logspace_1_iint32_n_cspbase
    module function logspace_1_iint32_n_rdpbase(start, end, n, base) result(res)
      integer, intent(in) :: start
      integer, intent(in) :: end
      integer, intent(in) :: n
      real(dp), intent(in) :: base
      ! integer endpoints + real(dp) base = real(dp) result
      real(dp) :: res(max(n, 0))
    end function logspace_1_iint32_n_rdpbase

    module function logspace_1_iint32_n_cdpbase(start, end, n, base) result(res)
      integer, intent(in) :: start
      integer, intent(in) :: end
      integer, intent(in) :: n
      complex(dp), intent(in) :: base
      ! integer endpoints + complex(dp) base = complex(dp) result
      complex(dp) :: res(max(n, 0))
    end function logspace_1_iint32_n_cdpbase
    module function logspace_1_iint32_n_rqpbase(start, end, n, base) result(res)
      integer, intent(in) :: start
      integer, intent(in) :: end
      integer, intent(in) :: n
      real(qp), intent(in) :: base
      ! integer endpoints + real(qp) base = real(qp) result
      real(qp) :: res(max(n, 0))
    end function logspace_1_iint32_n_rqpbase

    module function logspace_1_iint32_n_cqpbase(start, end, n, base) result(res)
      integer, intent(in) :: start
      integer, intent(in) :: end
      integer, intent(in) :: n
      complex(qp), intent(in) :: base
      ! integer endpoints + complex(qp) base = complex(qp) result
      complex(qp) :: res(max(n, 0))
    end function logspace_1_iint32_n_cqpbase

    module function logspace_1_iint32_n_ibase(start, end, n, base) result(res)
      integer, intent(in) :: start
      integer, intent(in) :: end
      integer, intent(in) :: n
      integer, intent(in) :: base
      ! integer endpoints + integer base = integer result
      integer :: res(max(n, 0))
    end function logspace_1_iint32_n_ibase

  end interface

    !> Version: experimental
    !>
    !> `arange` creates a one-dimensional `array` of the `integer/real` type
    !>  with fixed-spaced values of given spacing, within a given interval.
    !> ([Specification](../page/specs/stdlib_math.html#arange))
    interface arange
        pure module function arange_r_sp(start, end, step) result(result)
            real(sp), intent(in) :: start
            real(sp), intent(in), optional :: end, step
            real(sp), allocatable :: result(:)
        end function arange_r_sp
        pure module function arange_r_dp(start, end, step) result(result)
            real(dp), intent(in) :: start
            real(dp), intent(in), optional :: end, step
            real(dp), allocatable :: result(:)
        end function arange_r_dp
        pure module function arange_r_qp(start, end, step) result(result)
            real(qp), intent(in) :: start
            real(qp), intent(in), optional :: end, step
            real(qp), allocatable :: result(:)
        end function arange_r_qp
        pure module function arange_i_int8(start, end, step) result(result)
            integer(int8), intent(in) :: start
            integer(int8), intent(in), optional :: end, step
            integer(int8), allocatable :: result(:)
        end function arange_i_int8
        pure module function arange_i_int16(start, end, step) result(result)
            integer(int16), intent(in) :: start
            integer(int16), intent(in), optional :: end, step
            integer(int16), allocatable :: result(:)
        end function arange_i_int16
        pure module function arange_i_int32(start, end, step) result(result)
            integer(int32), intent(in) :: start
            integer(int32), intent(in), optional :: end, step
            integer(int32), allocatable :: result(:)
        end function arange_i_int32
        pure module function arange_i_int64(start, end, step) result(result)
            integer(int64), intent(in) :: start
            integer(int64), intent(in), optional :: end, step
            integer(int64), allocatable :: result(:)
        end function arange_i_int64
    end interface arange

contains

    elemental function clip_int8(x, xmin, xmax) result(res)
        integer(int8), intent(in) :: x
        integer(int8), intent(in) :: xmin
        integer(int8), intent(in) :: xmax
        integer(int8) :: res

        res = max(min(x, xmax), xmin)
    end function clip_int8

    elemental function clip_int16(x, xmin, xmax) result(res)
        integer(int16), intent(in) :: x
        integer(int16), intent(in) :: xmin
        integer(int16), intent(in) :: xmax
        integer(int16) :: res

        res = max(min(x, xmax), xmin)
    end function clip_int16

    elemental function clip_int32(x, xmin, xmax) result(res)
        integer(int32), intent(in) :: x
        integer(int32), intent(in) :: xmin
        integer(int32), intent(in) :: xmax
        integer(int32) :: res

        res = max(min(x, xmax), xmin)
    end function clip_int32

    elemental function clip_int64(x, xmin, xmax) result(res)
        integer(int64), intent(in) :: x
        integer(int64), intent(in) :: xmin
        integer(int64), intent(in) :: xmax
        integer(int64) :: res

        res = max(min(x, xmax), xmin)
    end function clip_int64

    elemental function clip_sp(x, xmin, xmax) result(res)
        real(sp), intent(in) :: x
        real(sp), intent(in) :: xmin
        real(sp), intent(in) :: xmax
        real(sp) :: res

        res = max(min(x, xmax), xmin)
    end function clip_sp

    elemental function clip_dp(x, xmin, xmax) result(res)
        real(dp), intent(in) :: x
        real(dp), intent(in) :: xmin
        real(dp), intent(in) :: xmax
        real(dp) :: res

        res = max(min(x, xmax), xmin)
    end function clip_dp

    elemental function clip_qp(x, xmin, xmax) result(res)
        real(qp), intent(in) :: x
        real(qp), intent(in) :: xmin
        real(qp), intent(in) :: xmax
        real(qp) :: res

        res = max(min(x, xmax), xmin)
    end function clip_qp

end module stdlib_math


! A[r,s] * B[s,t] = C[r,t]
subroutine matrix_multiply(A,r,s,B,t,C)
	integer :: r, s, t
	real, intent(in) :: A(r,s)
	real, intent(in) :: B(s,t)
	real, intent(out) :: C(r,t)

	C = matmul(A,B)
end subroutine matrix_multiply


function rosenbrock(x)

!*****************************************************************************80
!
!! ROSENBROCK evaluates the Rosenbrock parabolic value function.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    19 February 2008
!
!  Author:
!
!    John Burkardt
!
!  Reference:
!
!    R ONeill,
!    Algorithm AS 47:
!    Function Minimization Using a Simplex Procedure,
!    Applied Statistics,
!    Volume 20, Number 3, 1971, pages 338-345.
!
!  Parameters:
!
!    Input, real(dp) X(2), the argument.
!
!    Output, real(dp) ROSENBROCK, the value of the function.
!
  use mo_kind,   only: dp

  implicit none

  real(dp), dimension(:), intent(in) :: x
  real(dp) :: rosenbrock

  real(dp) :: fx
  real(dp) :: fx1
  real(dp) :: fx2

  fx1 = x(2) - x(1) * x(1)
  fx2 = 1.0_dp - x(1)

  fx = 100.0_dp * fx1 * fx1 + fx2 * fx2

  rosenbrock = fx

  return

end function rosenbrock


Program P1
	Implicit none
	real*8 :: dt, min, max, t
	real*8, dimension(2) :: y
	integer :: n
	parameter (n=2) ! y 1: pos; 2: vel;

	! inteval
	min=0.0D0
	max=200.0D0
	! time step
	dt=0.1D0
	! initial position
	y(1)=0.0D0
	! initial velocity
	y(2)=4.0D0

	! print the exact result
	print *, sqrt(4.0D0**2.D0+2.d0*400*max/70)
	Open(6, File='P1.dat')

	! Runga-Kutta iteration
	Do t=min, max, dt
		Call rk2(t, dt, y, n)
		Write (6,*) t, y(2) ! y(2): vel
	enddo

	Close(6)
End program P1

! second-order Runge-Kutta subroutine
! will update y(1) & y(2) based on n
subroutine rk2(t, dt, y, n)
	Implicit none
	real*8, external :: deriv
	real*8, intent(in) :: t, dt
	real*8, intent(inout), dimension(2) :: y
	real*8 :: h
	real*8, dimension(2) :: k1, k2, t1
	integer :: i,n

	h=dt/2.0D0
	Do i = 1,n
	   k1(i) = dt * deriv(y, i)
	   t1(i) = y(i) + 0.5D0*k1(i)
	enddo
	Do i = 1,n
	   k2(i) = dt * deriv(t1, i)
	   y(i) = y(i) + k2(i)
	enddo
	Return
End subroutine rk2

! function which returns the derivatives (RHS)
real*8 function deriv(temp, i)
	Implicit none
! declarations
	Real*8 :: omega
	real*8, dimension(2), intent(inout):: temp
	Integer :: i
	data omega /5.7143d0/
	!   dx/dt=v
	!   dv/dt=P/(mv)= 400/70/v=5.7143/v
	If (i .EQ. 1) deriv=temp(2)
	If (i .EQ. 2) deriv=omega / temp(2)
	Return
End function deriv


module m_geometry
  !! See Shewchuk 1997 Adaptive Precision Floating-Point Arithmetic and Fast Robust Geometric Predicates

  use variableKind, only: i32, i64, r32, r64
  use m_unitTester, only: tester

  private

  public :: orient2D
  public :: orient3D
  public :: geometryTest

  interface
    !====================================================================!
    module function inCircle(ax, ay, bx, by, cx, cy, dx, dy) result(determinant)
      !! Determines whether the point d is inside the circumcircle of the triangle formed by a-b-c
      !! Returns a positive value if d is inside.
      !! Returns a negative value if d is outside.
      !! Returns a zero if the four points are cocircular.
      !!
      !! Uses an adaptive floating method by Shewchuk. Only exact computations
      !! are carried out when needed.
    !====================================================================!
    real(r64), intent(in) :: ax
      !! x co-ordinate of the first point
    real(r64), intent(in) :: ay
      !! y co-ordinate of the first point
    real(r64), intent(in) :: bx
      !! x co-ordinate of the second point
    real(r64), intent(in) :: by
      !! y co-ordinate of the second point
    real(r64), intent(in) :: cx
      !! x co-ordinate of the third point
    real(r64), intent(in) :: cy
      !! y co-ordinate of the third point
    real(r64), intent(in) :: dx
      !! x co-ordinate of the fourth point
    real(r64), intent(in) :: dy
      !! y co-ordinate of the fourth point
    real(r64) :: determinant
      !! [-ve, 0, +ve] for point d [outside, on, inside] the circumcircle of a -> b -> c
    end function
  end interface

  interface
    !====================================================================!
    module function inSphere(ax, ay, az, bx, by, bz, cx, cy, cz, dx, dy, dz, ex, ey, ez) result(determinant)
      !! Determines whether the point e is inside the circumsphere of the tetrahedron formed by a-b-c-d
      !! Returns a positive value if e is inside.
      !! Returns a negative value if e is outside.
      !! Returns a zero if the five points are cospherical.
      !! a -> b -> c -> d must be ordered in a clockwise manner as defined by orient3D
      !!
      !! Uses an adaptive floating method by Shewchuk. Only exact computations
      !! are carried out when needed.
    !====================================================================!
    real(r64), intent(in) :: ax
      !! x co-ordinate of the first point
    real(r64), intent(in) :: ay
      !! y co-ordinate of the first point
    real(r64), intent(in) :: az
      !! z co-ordinate of the first point
    real(r64), intent(in) :: bx
      !! x co-ordinate of the second point
    real(r64), intent(in) :: by
      !! y co-ordinate of the second point
    real(r64), intent(in) :: bz
      !! z co-ordinate of the second point
    real(r64), intent(in) :: cx
      !! x co-ordinate of the third point
    real(r64), intent(in) :: cy
      !! y co-ordinate of the third point
    real(r64), intent(in) :: cz
      !! z co-ordinate of the third point
    real(r64), intent(in) :: dx
      !! x co-ordinate of the fourth point
    real(r64), intent(in) :: dy
      !! y co-ordinate of the fourth point
    real(r64), intent(in) :: dz
      !! z co-ordinate of the fourth point
    real(r64), intent(in) :: ex
      !! x co-ordinate of the fifth point
    real(r64), intent(in) :: ey
      !! y co-ordinate of the fifth point
    real(r64), intent(in) :: ez
      !! z co-ordinate of the fifth point
    real(r64) :: determinant
      !! [-ve, 0, +ve] for point e [outside, on, inside] the circumsphere defined by points a -> b -> c -> d
    end function
    !====================================================================!
  end interface

  interface
    !====================================================================!
    module function orient2D(ax, ay, bx, by, cx, cy) result(determinant)
      !! Determines whether three points a, b, c are in clockwise order.
      !! i.e. is the point c to the left or right of line a-b?
      !! Returns a positive value if a-b-c are in an anticlockwise order.
      !! Returns a negative value if a-b-c are in clockwise order.
      !! Returns a zero if the points are colinear.
      !!
      !! Uses an adaptive floating method by Shewchuk. Only exact computations
      !! are carried out when needed.
    !====================================================================!
    real(r64), intent(in) :: ax
      !! x co-ordinate of the first point
    real(r64), intent(in) :: ay
      !! y co-ordinate of the first point
    real(r64), intent(in) :: bx
      !! x co-ordinate of the second point
    real(r64), intent(in) :: by
      !! y co-ordinate of the second point
    real(r64), intent(in) :: cx
      !! x co-ordinate of the third point
    real(r64), intent(in) :: cy
      !! y co-ordinate of the third point
    real(r64) :: determinant
      !! [-ve, 0, +ve] for [clockwise, colinear, anticlockwise] points a -> b -> c
    end function
  end interface

  interface
    !====================================================================!
    module function orient3D(ax, ay, az, bx, by, bz, cx, cy, cz, dx, dy, dz) result(determinant)
      !! Determines whether the points a, b, c, d defining a polyhedron are ordered
      !! in an anticlockwise manner.
      !! Returns a positive value if a-b-c-d are in an anticlockwise order.
      !! Returns a negative value if a-b-c-d are in clockwise order.
      !! Returns zero if they are coplanar.
      !! Clockwise is defined when viewed from above the plane defined by a-b-c.
      !!
      !! Uses an adaptive floating method by Shewchuk. Only exact computations
      !! are carried out when needed.
    !====================================================================!
    real(r64), intent(in) :: ax
      !! x co-ordinate of the first point
    real(r64), intent(in) :: ay
      !! y co-ordinate of the first point
    real(r64), intent(in) :: az
      !! z co-ordinate of the first point
    real(r64), intent(in) :: bx
      !! x co-ordinate of the second point
    real(r64), intent(in) :: by
      !! y co-ordinate of the second point
    real(r64), intent(in) :: bz
      !! z co-ordinate of the second point
    real(r64), intent(in) :: cx
      !! x co-ordinate of the third point
    real(r64), intent(in) :: cy
      !! y co-ordinate of the third point
    real(r64), intent(in) :: cz
      !! z co-ordinate of the third point
    real(r64), intent(in) :: dx
      !! x co-ordinate of the fourth point
    real(r64), intent(in) :: dy
      !! y co-ordinate of the fourth point
    real(r64), intent(in) :: dz
      !! z co-ordinate of the fourth point
    real(r64) :: determinant
      !! [-ve, 0, +ve] for point d [right, on, left] of the plane defined by points a -> b -> c
    end function
  end interface

  interface
    !====================================================================!
    module subroutine geometryTest(test)
    !====================================================================!
    class(tester) :: test
    end subroutine
  end interface
  !====================================================================!

end module


module pend_len
! Allows the declaration of global variables whose values can be assigned in other places.
double precision :: l
end module

module dpend
double precision :: l1, l2, m1, m2, ms
end module

module gonewiththewind
double precision :: as, ar, k
end module

module per_harv
double precision :: a, h, r
end module

program main
use pend_len
use dpend
use gonewiththewind
use per_harv
implicit none
! call simple_pendulum
 call double_pendulum
 call double_pendulum_adapt
! call gone_with_the_wind
! call periodic_harvesting
! call periodic_harvesting2
! call periodic_harvesting_adapt
end program main

subroutine periodic_harvesting
! Excercise 7.2.19 of non-linear dynamics and chaos Strogatz
use per_harv
implicit none
integer, parameter :: n = 1
double precision ti, tf, dt, tmax
double precision xi(n), xf(n)
integer i
external pharv

open(unit=1, file='pharv.dat')
! initial data
ti    = 0.0
tmax  = 100.0
dt    = 0.01
a     = 0.5
r     = 1.0
h     = 0.2  ! criticals are roughly h<r/4, h<r/(4*(1+a))
xi(1) = 1.0  ! dimensionless model, the maximum population is really a proportion.

! print initial conditions
write(1,*) ti, xi(1)

! integration of ODEs
do while(ti <= tmax)
   tf = ti + dt
   call rk4n(pharv,ti,tf,xi,xf,n)
   write(1,*) tf, xf(1)

! preparing for next step
   ti = tf
   do i = 1,n
      xi(i) = xf(i)
   end do
end do

100 format(5x,'t',11x,'x',11x,'y',11x,'dx/dt',7x,'dy/dt')
102 format(5(1pe12.3))
end subroutine periodic_harvesting

subroutine periodic_harvesting2
! Excercise 7.2.19 of non-linear dynamics and chaos Strogatz
use per_harv
use functions
implicit none
integer, parameter :: n = 1
double precision ti, tf, dt, tmax
double precision xi(n), xf(n), er(n)
integer i
external pharv

open(unit=1, file='pharv2.dat')
! initial data
ti    = 0.0
tmax  = 100.0
dt    = 0.01
a     = 0.5
r     = 1.0
h     = 0.2  ! criticals are roughly h<r/4, h<r/(4*(1+a))
xi(1) = 1.0  ! dimensionless model, the maximum population is really a proportion.

! print initial conditions
write(1,*) ti, xi(1)

! integration of ODEs
do while(ti <= tmax)
   !call rkckn(pharv,ti,xi,xf,er,dt,n)
   tf = ti + dt
   write(1,*) tf, xf(1)

! preparing for next step
   ti = tf
   do i = 1,n
      xi(i) = xf(i)
   end do
end do

100 format(5x,'t',11x,'x',11x,'y',11x,'dx/dt',7x,'dy/dt')
102 format(5(1pe12.3))
end subroutine periodic_harvesting2

subroutine periodic_harvesting_adapt
! Excercise 7.2.19 of non-linear dynamics and chaos Strogatz
use per_harv
use functions
implicit none
integer, parameter :: n = 1
double precision ti, tf, dt, tmax
double precision xi(n), xf(n), er(n)
double precision der, dtmin
integer i
external pharv

open(unit=1, file='pharv_adapt.dat')
! initial data
ti    = 0.0
tmax  = 100.0
dt    = 0.01
der   = 1e-7
dtmin = 1e-4
a     = 0.5
r     = 1.0
h     = 0.2  ! criticals are roughly h<r/4, h<r/(4*(1+a))
xi(1) = 1.0  ! dimensionless model, the maximum population is really a proportion.

! print initial conditions
write(1,*) ti, xi(1)

! integration of ODEs
do while(ti <= tmax)
  !call rkcka(pharv,ti,tf,xi,xf,der,dt,dtmin,n)
  write(1,*) tf, xf(1)
end do

100 format(5x,'t',11x,'x',11x,'y',11x,'dx/dt',7x,'dy/dt')
102 format(5(1pe12.3))
end subroutine periodic_harvesting_adapt

subroutine pharv(t,x,dx,n)
! Excercise 8.5.4 strogatz
use per_harv
implicit none
integer n
double precision t, x(n), dx(n)

dx(1) = r*x(1)*(1-x(1)) - h*(1 + a*sin(t))
end subroutine pharv

subroutine gone_with_the_wind
! Excercise 7.2.19 of non-linear dynamics and chaos Strogatz
use gonewiththewind
implicit none
integer, parameter :: n = 2
double precision ti, tf, dt, tmax
double precision xi(n), xf(n)
integer i
external gwtw

open(unit=1, file='gwtw.dat')
! initial data
ti    = 0.0
tmax  = 100.0
dt    = 0.01
as    = 1.2
ar    = 1.0
k     = 15.0
xi(1) = 0.0
xi(2) = 0.0

! print initial conditions
write(1,*) ti, xi(1), xi(2)

! integration of ODEs
do while(ti <= tmax)
   tf = ti + dt
   call rk4n(gwtw,ti,tf,xi,xf,n)
   write(1,*) tf, xf(1), xf(2)

! preparing for next step
   ti = tf
   do i = 1,n
      xi(i) = xf(i)
   end do
end do

100 format(5x,'t',11x,'x',11x,'y',11x,'dx/dt',7x,'dy/dt')
102 format(5(1pe12.3))
end subroutine gone_with_the_wind

subroutine gwtw(t,x,dx,n)
!======================================================!
! Daniel Celis Garza  13 Dec. 2014                     !
! Love affair between Scarlett O'Hara and Rhett Butler !
! x(1) = r    dx(1) = r'                               !
! x(2) = s    dx(2) = s'                               !
!======================================================!
use gonewiththewind
implicit none
integer n
double precision t, x(n), dx(n)

dx(1) = -x(1) + as + k*x(2)*exp(-x(2))
dx(2) = -x(2) + ar + k*x(1)*exp(-x(1))
end subroutine gwtw

subroutine double_pendulum
use dpend
use functions
implicit none
integer, parameter :: n = 4
double precision, parameter :: rad = 3.1415926/180.0
double precision ti, tf, dt, tmax, thsi
double precision xi(n), xf(n), dxi(n),er(n)
double precision start, finish
integer i
interface
  subroutine dpen(x,y,dx)
    implicit none
    double precision, intent(in) :: x, y(:)
    double precision, intent(out) :: dx(:)
  end subroutine
end interface

open(unit=1, file = 'd_pendulum.dat')
! initial data
ti     = 0.0
tmax   = 50.0
dt     = 5.0e-3
l1     = 5.0
l2     = 9.0
m1     = 13.0
m2     = 50.0
xi(1)  = 173.0*rad
xi(2)  = -86.0*rad
dxi(1) = -3.0*rad
dxi(2) = 35.0*rad
ms     = m1 + m2
thsi   = xi(1) - xi(2)
xi(3)  = ms*l1*l1*dxi(1) + m2*l1*l2*dxi(2)*cos(thsi)
xi(4)  = m2*l2*l2*dxi(2) + m2*l1*l2*dxi(1)*cos(thsi)

! print initial conditions
write(1,*) ti,xi(1),xi(2),xi(3),xi(4),l1*sin(xi(1)),-l1*cos(xi(1)),l1*sin(xi(1))+l2*sin(xi(2)),-l1*cos(xi(1))-l2*cos(xi(2))
CALL CPU_TIME(start)
! integration of ODEs
do while(ti <= tmax)
   tf = ti + dt
   call rkckn(dpen,ti,xi,xf,er,dt)
   !call rkckn(dpen,ti,xi,xf,er,dt,n)
   write(1,*) tf,xf(1),xf(2),xf(3),xf(4),l1*sin(xf(1)),-l1*cos(xf(1)),l1*sin(xf(1))+l2*sin(xf(2)),-l1*cos(xf(1))-l2*cos(xf(2))

! prepare for next step
   ti = tf
   do i = 1,n
      xi(i) = xf(i)
      end do
end do

100 format(5x,'t',11x,'x',11x,'y',11x,'dx/dt',7x,'dy/dt')
102 format(5(1pe12.3))
CALL CPU_TIME(finish)
print '("Time = ",f6.3," seconds.")',finish-start
end subroutine double_pendulum

subroutine double_pendulum_adapt
use dpend
use functions
implicit none
integer, parameter :: n = 4
double precision, parameter :: rad = 3.1415926/180.0
double precision ti, tf, dt, dtmin, der, tmax, thsi, t
double precision x(n)
double precision start, finish
integer i
interface
  subroutine dpen(x,y,dx)
    implicit none
    double precision, intent(in) :: x, y(:)
    double precision, intent(out) :: dx(:)
  end subroutine
end interface
double precision, dimension(size(x)) :: xi, xf, dxi, dx

open(unit=1, file = 'd_pendulum_adapt.dat')
! initial data
ti     = 0.0
tmax   = 50.0
dt     = 5.0e-3
dtmin  = 4.375e-3
der    = 1.3125e-7
l1     = 5.0
l2     = 9.0
m1     = 13.0
m2     = 50.0
xi(1)  = 173.0*rad
xi(2)  = -86.0*rad
dxi(1) = -3.0*rad
dxi(2) = 35.0*rad
ms     = m1 + m2
thsi   = xi(1) - xi(2)
xi(3)  = ms*l1*l1*dxi(1) + m2*l1*l2*dxi(2)*cos(thsi)
xi(4)  = m2*l2*l2*dxi(2) + m2*l1*l2*dxi(1)*cos(thsi)
! print initial conditions
write(1,*) ti,xi(1),xi(2),xi(3),xi(4),l1*sin(xi(1)),-l1*cos(xi(1)),l1*sin(xi(1))+l2*sin(xi(2)),-l1*cos(xi(1))-l2*cos(xi(2))
t = ti
x(:) = xi(:)
CALL CPU_TIME(start)
! integration of ODEs
do while(t <= tmax)
  call rkcka(dpen,t,x,der,dt,dtmin)
  !call rkcka(dpen,ti,tf,xi,xf,der,dt,dtmin,n)
  write(1,*) t,x(1),x(2),x(3),x(4),l1*sin(x(1)),-l1*cos(x(1)),l1*sin(x(1))+l2*sin(x(2)),-l1*cos(x(1))-l2*cos(x(2))
end do
CALL CPU_TIME(finish)
print '("Time = ",f6.3," seconds.")',finish-start
end subroutine double_pendulum_adapt

subroutine dpen(t,x,dx)
! x(1) = theta1    dx(1) = theta1'
! x(2) = theta2    dx(2) = theta2'
! x(3) = p1        dx(3) = p1'
! x(4) = p2        dx(4) = p2'
use dpend
implicit none
double precision t, ths, den, c1, c2
double precision, intent(inout) :: x(:)
double precision, intent(out):: dx(:)
double precision, parameter :: g = 9.81
ths   = x(1) - x(2)
den   = m1 + m2*sin(ths)*sin(ths)
c1    = (x(3)*x(4)*sin(ths))/(l1*l2*den)
c2    = (l2*l2*m2*x(3)*x(3) + l1*l1*ms*x(4)*x(4) - l1*l2*m2*x(3)*x(4)*cos(ths))/(2*l1*l1*l2*l2*den*den)*sin(2*ths)
dx(1) = (l2*x(3)-l1*x(4)*cos(ths))/(l1*l1*l2*den)
dx(2) = (l1*ms*x(4)-l2*m2*x(3)*cos(ths))/(l1*l2*l2*m2*den)
dx(3) = -ms*g*l1*sin(x(1)) - c1 + c2
dx(4) = -m2*g*l2*sin(x(2)) + c1 - c2
end subroutine dpen

subroutine simple_pendulum
!=======================================================!
! Simple pendulum routine                               !
!=======================================================!
use pend_len  ! Places the module into the subroutine along the variable values as assigned by the module of main program.
implicit none
integer, parameter :: n = 2
double precision, parameter :: rad = 3.1415926/180.0
double precision ti, tf, dt, tmax
double precision xi(n), xf(n)
integer i
external spen   ! external allows other functions to be used as arguments.

open(unit=1, file='pendulum.dat')
! initial data
ti    = 0.0     ! initial time
tmax  = 1.0     ! maximum time
dt    = 0.01    ! step size
l     = 1.0     ! assigns the global value for l, it applies to any subroutines or functions called by this subroutine.
xi(1) = 90*rad  ! initial angle
xi(2) = 0.0*rad ! initial angular speed

! print initial conditions
write(1,102) ti, xi(1), xi(2), l*sin(xi(1)), -l*cos(xi(1))

! integration of ODEs
do while(ti<=tmax)
   tf = ti + dt
   call rk4n(spen,ti,tf,xi,xf,n)
   write(1,102) tf, xf(1), xf(2), l*sin(xf(1)), -l*cos(xf(1))
! prepare next step
   ti = tf
   do i = 1, n
      xi(i) = xf(i)
   end do
end do

100 format(5x,'t',11x,'x',11x,'y',11x,'dx/dt',7x,'dy/dt')
102 format(5(1pe12.3))
end subroutine simple_pendulum

subroutine spen(t,x,dx,n)
use pend_len
!=======================================================!
! System of ODEs for the rk4n subroutine.
! Daniel Celis Garza 11 Dec. 2014
!-------------------------------------------------------!
! Simple pendulum
! x(1) = theta         dx(1) = theta'
! x(2) = theta'        dx(2) = theta''
!=======================================================!
implicit none
integer n
double precision t, x(n), dx(n)
double precision, parameter :: g = 9.81                 ! acceleration in m/s^2 and string length
! first order
dx(1) = x(2)
! second order
dx(2) = (-g/l) * sin(x(1))
end subroutine spen

subroutine rk4n(f,ti,tf,xi,xf,n)
!=======================================================!
! Solve n first-order ODEs or n/2 second-order.         !
! Runge-Kutta 4                                         !
! Daniel Celis Garza 10 Dec. 2014                       !
!-------------------------------------------------------!
! f(t,x,dx,n) = parametrised equations of motion        !
! ti          = independent variable @ step i           !
! tf          = independent variable @ step i+1         !
! xi()        = array of dependent variables @ step i   !
! xf()        = array of dependent variables @ step i+1 !
! n           = # of parametrised equations of motion   !
!-------------------------------------------------------!
! j           = counter variable                        !
! h           = time step                               !
! t           = current time                            !
! ki()        = array of Runge-Kutta k's                !
!=======================================================!
implicit none
integer n, j
double precision ti, tf, h, t, xi(n), xf(n), k1(n), k2(n), k3(n), k4(n), x(n), dx(n)

h = tf - ti ! This will be replaced by the error-correcting routine.
t = ti

! Calculate k1
call f(t,xi,dx,n)            ! Call the equations of motion
do j = 1, n                  ! Go through all equations of motion
   k1(j) = h*dx(j)           ! Calculate the value of k1 for each equation of motion
   x(j)  = xi(j) + k1(j)/2.0 ! Calculate the next value of x for each equation (to be used in the next ki)
end do

! Calculate k2
call f(t+h/2.0,x,dx,n)
do j = 1, n
   k2(j) = h*dx(j)
   x(j)  = xi(j) + k2(j)/2.0
end do

! Calculate k3
call f(t+h/2.0,x,dx,n)
do j = 1, n
   k3(j) = h*dx(j)
   x(j)  = xi(j) + k3(j)/2.0
end do

! Calculate k4 and xf
call f(t+h,x,dx,n)
do j = 1, n
   k4(j) = h*dx(j)
   xf(j)  = xi(j) + k1(j)/6.0 + k2(j)/3.0 + k3(j)/3.0 + k4(j)/6.0
end do
end subroutine rk4n

!subroutine rk4n_adapt(f,ti,tf,xi,xf,n)
!=======================================================
! Dynamic adjustment of h.
! Daniel Celis 10 Dec. 2014
! ert = 0 ; absolute error
! ert = 1 ; relative error
! ert = 2 ; mixed error
!=======================================================
!integer j, n, ert
!double precision ti, tf, h, t, xi(n), xf(n), k1(n), k2(n), k3(n), k4(n), x(n), dx(n)

!end subroutine rk4nvh


module richards_functions

  use kind_parameters
  private

  public :: conductivity, pressure, pressure_deriv, saturation, cond_theta, diffusivity

  real(kind=r8), parameter, private :: THETA_R = 0.075_r8
  real(kind=r8), parameter, private :: THETA_S = 0.287_r8
  real(kind=r8), parameter, private :: ALPHA   = 1.611e6_r8
  real(kind=r8), parameter, private :: BETA    = 3.96_r8

  real(kind=r8), parameter, private :: K_S     = 0.00944_r8
  real(kind=r8), parameter, private :: A       = 1.175e6_r8
  real(kind=r8), parameter, private :: GAMMA   = 4.74_r8

  contains

    function cond_theta (theta) result (value)

      real(kind=r8), intent(in) :: theta
      real(kind=r8) :: value
      real(kind=r8) :: p

      p = - (ALPHA * (THETA_S - theta) / (theta - THETA_R)) ** (1.0_r8 / BETA)

      value = (K_S * A) / (A + abs(p) ** GAMMA)

    end function cond_theta

    function diffusivity (theta) result (value)

      real(kind=r8), intent(in) :: theta
      real(kind=r8) :: value
      real(kind=r8) :: p

      p = - (ALPHA * (THETA_S - theta) / (theta - THETA_R)) ** (1.0_r8 / BETA)

      value = (K_S * A * (THETA_S - THETA_R) * ALPHA / BETA) / &
              (((theta-THETA_R) ** 2) * (abs(p) ** (BETA-1.0_r8)) * (A + abs(p) ** GAMMA))

    end function diffusivity

    function conductivity (p) result (value)

      real(kind=r8), intent(in) :: p
      real(kind=r8) :: value

      value = (K_S * A) / (A + abs(p) ** GAMMA)

    end function conductivity

    function pressure (s) result (value)

      real(kind=r8), intent(in) :: s
      real(kind=r8) :: value

      value = - (ALPHA * (THETA_S - s) / (s - THETA_R)) ** (1.0_r8 / BETA)

    end function pressure

    function pressure_deriv (s) result (value)

      real(kind=r8), intent(in) :: s
      real(kind=r8) :: value

      value = (ALPHA ** (1.0_r8 / BETA) * (THETA_S - THETA_R) / BETA) * &
              ((THETA_S - s) / (s - THETA_R)) ** ((1.0_r8 - BETA)/ BETA) / &
              (s - THETA_R) ** 2

    end function pressure_deriv

    function saturation (p) result (value)

      real(kind=r8), intent(in) :: p
      real(kind=r8) :: value

      value = ALPHA * (THETA_S - THETA_R) / (ALPHA + abs(p)**BETA) + THETA_R

    end function saturation

end module richards_functions

module write_functions

  use kind_parameters
  use richards_functions
  private

  public :: write_conductivity, write_diffusivity, write_saturation

  contains

    subroutine write_conductivity (s0, s1, ds, filename)

      real(kind=r8), intent(in) :: s0, s1, ds
      character(len=*), intent(in) :: filename

      integer :: j
      real(kind=r8) :: s

      open(unit=10, file=filename, action="write", position="rewind", status="replace")

      j = 0

      do
        s = s0 + j * ds
        if (s > s1) then
          exit
        end if
        write(unit=10, fmt=*) s, cond_theta(s)
        j = j + 1
      end do

      close(unit=10)

    end subroutine write_conductivity

    subroutine write_diffusivity (s0, s1, ds, filename)

      real(kind=r8), intent(in) :: s0, s1, ds
      character(len=*), intent(in) :: filename

      integer :: j
      real(kind=r8) :: s

      open(unit=10, file=filename, action="write", position="rewind", status="replace")

      j = 0

      do
        s = s0 + j * ds
        if (s > s1) then
          exit
        end if
        write(unit=10, fmt=*) s, diffusivity(s)
        j = j + 1
      end do

      close(unit=10)

    end subroutine write_diffusivity

    subroutine write_saturation (p0, p1, dp, filename)

      real(kind=r8), intent(in) :: p0, p1, dp
      character(len=*), intent(in) :: filename

      integer :: j
      real(kind=r8) :: p

      open(unit=10, file=filename, action="write", position="rewind", status="replace")

      j = 0

      do
        p = p0 + j * dp
        if (p > p1) then
          exit
        end if
        write(unit=10, fmt=*) p, saturation(p)
        j = j + 1
      end do

      close(unit=10)

    end subroutine write_saturation

end module write_functions

program plot_em

  use kind_parameters
  use richards_functions
  use write_functions

  real(kind=r8), parameter :: s0 = 0.076_r8, s1 = 0.286_r8, ds = 0.001_r8

  call write_diffusivity (s0=0.1_r8, s1=0.27_r8, ds=0.001_r8, filename="diff")
  call write_conductivity (s0=0.1_r8, s1=0.27_r8, ds=0.001_r8, filename="cond")
  !call write_saturation (p0=-61.5_r8, p1=-20.7_r8, dp=0.1_r8, filename="sat")

end program plot_em


program main
    use plantFEM
    implicit none

    type(Random_) ::random
    type(IO_) :: f
    integer(int32) :: i
    real(real64),allocatable :: histogram(:,:)
    real(real64) :: list(10000)

    do i=1,10000
        list(i) = random%gauss(mu=10.0d0,sigma=2.0d0)
    enddo

    histogram =  random%histogram(list=list,division=20)

    call f%open("gauss.txt")

    do i=1,size(histogram,1)
        write(f%fh,*) histogram(i,1),histogram(i,2)
    enddo
    call f%close()

    do i=1,10000
        list(i) = random%ChiSquared(K=10.0d0)
    enddo

    histogram =  random%histogram(list=list,division=20)

    call f%open("ChiSquared.txt")

    do i=1,size(histogram,1)
        write(f%fh,*) histogram(i,1),histogram(i,2)
    enddo

    call f%close()

    do i=1,10000
        list(i) = random%Chauchy(mu=10.0d0,gamma=2.0d0)
    enddo

    histogram =  random%histogram(list=list,division=20)

    call f%open("Chauchy.txt")

    do i=1,size(histogram,1)
        write(f%fh,*) histogram(i,1),histogram(i,2)
    enddo
    call f%close()

    do i=1,10000
        list(i) = random%Lognormal(mu=10.0d0,sigma=2.0d0)
    enddo

    histogram =  random%histogram(list=list,division=20)

    call f%open("Lognormal.txt")

    do i=1,size(histogram,1)
        write(f%fh,*) histogram(i,1),histogram(i,2)
    enddo
    call f%close()

    do i=1,10000
        list(i) = random%InverseGauss(mu=10.0d0,lambda=2.0d0)
    enddo

    histogram =  random%histogram(list=list,division=20)

    call f%open("InverseGauss.txt")

    do i=1,size(histogram,1)
        write(f%fh,*) histogram(i,1),histogram(i,2)
    enddo

    call f%close()

end program


! DART software - Copyright UCAR. This open source software is provided
! by UCAR, "as is", without charge, subject to all terms of use at
! http://www.image.ucar.edu/DAReS/DART/DART_download
!
! $Id$
!
! do a simple test that the mean distance between sample
! draws from two gaussian distributions are close to the
! expected value.  indirect test of the random number generator
! which is used in the gaussian random numbers.

program test_diff

use     types_mod,  only : r4, r8, digits12
use utilities_mod,  only : register_module, error_handler, E_ERR, E_MSG, &
                           initialize_utilities, finalize_utilities, &
                           find_namelist_in_file, check_namelist_read
use random_seq_mod, only : random_seq_type, init_random_seq, random_gaussian

implicit none

! version controlled file description for error handling, do not edit
character(len=256), parameter :: source   = &
   "$URL$"
character(len=32 ), parameter :: revision = "$Revision$"
character(len=128), parameter :: revdate  = "$Date$"

integer, parameter :: n = 1000000
integer :: i, iunit, io
type (random_seq_type) :: r

real(r8) :: r1, r2, dist2, mean_dist2
character(len=16) :: wformatI = '(A,I8)'
character(len=16) :: wformat1 = '(A,1(F25.16))'
character(len=16) :: wformat2 = '(A,2(F25.16))'

!-----------------------------------------------------------------------------
! Namelist with default values

real(r8) :: mean = 0.0, sd1 = 1.0, sd2 = 2.0, predicted
integer :: iseed = 123

namelist /test_diff_nml/ mean, sd1, sd2, iseed

call initialize_utilities('test_diff')
call register_module(source,revision,revdate)

! Read the namelist entry
call find_namelist_in_file("input.nml", "test_diff_nml", iunit)
read(iunit, nml = test_diff_nml, iostat = io)
call check_namelist_read(iunit, io, "test_diff_nml")

write(*, *) ''
write(*, wformatI) 'sample size = ', n
write(*, *) ''
write(*, wformat2) 'mean, stddev 1 = ', 0.0_r8, sd1
write(*, wformat2) 'mean, stddev 2 = ', mean, sd2
write(*, *) ''

call init_random_seq(r,iseed)
mean_dist2 = 0.0_r8
do i = 1, n
   r1 = random_gaussian(r, 0.0_r8, sd1)
   r2 = random_gaussian(r,  mean,  sd2)
   dist2 = (r1 - r2)**2
   mean_dist2 = mean_dist2 + dist2
end do

write(*, wformat1) 'predicted distance   = ', sqrt(mean**2 + sd1**2 + sd2**2)
write(*, wformat1) 'sample mean distance = ', sqrt(mean_dist2 / n)
write(*, *) ''

call finalize_utilities()

end program test_diff

! <next few lines under version control, do not edit>
! $URL$
! $Id$
! $Revision$
! $Date$


!##############################################################################
! PROGRAM piecewise_pol
!
! ## Piecewise polynomial interpolation (linear and cubic splines)
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program piecewise_pol

    use toolbox

    implicit none
    integer, parameter :: n = 10, nplot = 1000
    real*8 :: xi(0:n), yi(0:n)
    real*8 :: xplot(0:nplot), yplot(0:nplot), yreal(0:nplot)
    real*8 :: varphi, coeff(n+3)
    integer :: ix, il, ir

    ! get nodes and data for interpolation
    call grid_Cons_Equi(xi, -1d0, 1d0)
    yi = 1d0/(1d0+25*xi**2)

    ! get nodes and data for plotting
    call grid_Cons_Equi(xplot, -1d0, 1d0)
    yreal = 1d0/(1d0+25*xplot**2)
    call plot(xplot, yreal, legend='Original')

    ! piecewise linear interpolation
    do ix = 0, nplot
        call linint_Equi(xplot(ix), -1d0, 1d0, n, il, ir, varphi)
        yplot(ix) = varphi*yi(il) + (1d0-varphi)*yi(ir)
    enddo
    call plot(xplot, yplot, legend='Piecewise linear')

    ! cubic spline interpolation
    call spline_interp(yi, coeff)
    do ix = 0, nplot
        yplot(ix) = spline_eval(xplot(ix), coeff, -1d0, 1d0)
    enddo
    call plot(xplot, yplot, legend='Cubic spline')

    ! execute plot
    call execplot(xlim=(/-1d0,1d0/))

end program


C Copyright 2021 Dennis Decker Jensen
C Date: 26 April 2021
C Purpose: Find prime factors in integers
C Tectonics: gfortran --std=f95 -ffixed-form -o euler047 euler047.f primefactors.f

      PROGRAM EULER047
         PARAMETER (MX=10,MXDGS=4)
         DIMENSION IFACS(2,MX)
         DIMENSION IRES(MX,MXDGS,2),NUMS(MXDGS),NFACS(MXDGS)

C         CALL PRIMEFACTORS_TRIALDIV(441, IFACS, MX, N)
C         PRINT 50,441,N,(IFACS(1:2,J),J=1,N)

C         CALL PRIMEFACTORS_TRIALDIV(9974, IFACS, MX, N)
C         PRINT 50,9974,N,(IFACS(1:2,J),J=1,N)
C         CALL PRIMEFACTORS_TRIALDIV(9975, IFACS, MX, N)
C         PRINT 50,9975,N,(IFACS(1:2,J),J=1,N)
C         CALL PRIMEFACTORS_TRIALDIV(9976, IFACS, MX, N)
C         PRINT 50,9976,N,(IFACS(1:2,J),J=1,N)
C         STOP

         M=0
         K=0
         DO 20 I=1,2**32-1
C            CALL PRIMEFACTORS_TRIALDIV(I,IFACS,MX,N)
            CALL PRIMEFACTORS_WHEEL(I,IFACS,MX,N)
C            PRINT 50,I,N,(IFACS(1:2,J),J=1,N)
C            IF (N.EQ.MXDGS) PRINT 50,I,N,(IFACS(1:2,J),J=1,N)

            ISP=1
            DO 05 J=1,N
               ISP=ISP*IFACS(1,J)**IFACS(2,J)
   05       CONTINUE
            IF (ISP.NE.I) THEN
               PRINT *, 'WRONG!',I,'.NE.',ISP
               STOP
            ENDIF

            IF (N.EQ.MXDGS .AND. I.EQ.K+1) THEN
               M=M+1
               NUMS(M)=I
               NFACS(M)=N
               DO 10 L=1,N
                  IRES(L,M,1)=IFACS(1,L)
                  IRES(L,M,2)=IFACS(2,L)
   10          CONTINUE
               IF (M.EQ.MXDGS) GOTO 30
            ELSE
               M=0
            ENDIF
            K=I
   20    CONTINUE
   30    DO 40 I=1,M
            PRINT 50, NUMS(I), NFACS(I),
     1                (IRES(J,I,1:2),J=1,NFACS(I))
   40    CONTINUE
   50    FORMAT (I0,' HAS ',I0,' FACTORS: ',4(I0,'**',I0,' '))
      END