program newton
use funcs
implicit none

real(kind=8) :: Er, x_old, x_new, true_x
real(kind=8) :: TrueError, TrueRelativeError, Tolerance
integer :: itermax, i

true_x = -3.024185183530358

x_old = -3.0 ! starting value of x
itermax = 20

i = 1
Er = 1
write(*,*) "iteration    x       |f(x)|      Err"
do while (Er > 0.0001)
   ! determine the new x and the error:
   x_new = x_old - f(x_old)/df_dx(x_old)
   Er = dabs((x_new-x_old) / x_old)
   write(*,'(A2,I2,A2,3F12.7)') "  ", i, "  ", x_new, dabs(f(x_new)), Er

   ! check if the maximum number of iterations has been exceeded:
   i = i+1
   if (i > itermax) then
      write(*,*) "The maximum number of iterations has been exceeded."
      exit
   end if

   x_old = x_new
end do
write(*,*)

TrueError = true_x - x_new
write(*,*) "TrueError:", TrueError

TrueRelativeError = dabs( (true_x-x_new) / true_x )*100
write(*,*) "TrueRelativeError:", TrueRelativeError

Tolerance = dabs(f(x_new))
write(*,*) "Tolerance:", Tolerance

end program newton


real*8 function Wl(l, half, r, d)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This function will compute the minimum amplitude downward continuation
!	filter of Wieczorek and Phillips 1998 for degree l, where the filter is assumed
!	to be equal to 0.5 at degree half.
!
!	Calling Parameters:
!		l	spherical harmonic degree
!		half 	spherical harmonic degree where the filter is 0.5
!		r 	reference radius for surface gravity field
!		d	mean radius of downward continuation
!
!	Dependencies:	None
!
!	Written by Mark Wieczorek (May 2004)
!
!	Copyright (c) 2005-2006, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	integer, intent(in) ::	l, half
	real*8, intent(in) ::	r, d
	real*8 ::		const

	if (half == 0) then

		wl=1.0d0

	else

		const = ( dble(2*half+1) * (r/d)**half )**2
		const = 1.0d0/const

		wl = 1.0d0 + const * ( dble(2*l+1)*(r/d)**l )**2
		wl = 1.0d0/wl

	endif

end function Wl

real*8 function WlCurv(l, half, r, d)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This function will compute a minimum curvature downward continuation
!	filter for degree l, where the filter is assumed to be equal to 0.5 at degree half.
!
!	Calling Parameters:
!		l	spherical harmonic degree
!		half 	spherical harmonic degree where the filter is 0.5
!		r 	reference radius for surface gravity field
!		d	mean radius of downward continuation
!
!	Dependencies:	None
!
!	Note: This filter is analogous to (and numerically very similar to)
!		the minimum curvature filter in Phipps Morgan and Blackman (1993)
!
!	Written by Mark Wieczorek (May 2004)
!
!	Copyright (c) 2005-2006, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	implicit none
	integer, intent(in) ::	l, half
	real*8, intent(in) ::	r, d
	real*8 ::	const

	if (half == 0) then
		WlCurv=1.0d0
	else
		const = dble(half*half+half) * ( dble(2*half+1) * (r/d)**half )**2
		const = 1.0d0/const

		WlCurv = 1.0d0 + const * dble(l*l+l) * ( dble(2*l+1)*(r/d)**l )**2
		WlCurv = 1.0d0/WlCurv
	endif

end function WlCurv


module module_triSolve

implicit none
contains
	subroutine triSolve(a,b,c,d,x,n)
		implicit none
		integer::i
		integer,intent(IN) ::n
		real(8) ::a(n),b(n),c(n),d(n),x(n)
		! a is the lower diagonal of the tridiagonal matrix
	  ! b is the main diagonal of the tridiagonal matrix
	  ! c is the upper diagonal of the tridiagonal matrix
	  ! d is the right hand side of the equations of the tridiagonal matrix
	  ! x is the numerical value calculated from the thomas algorithm
	  ! n is the number of discritizations

		do i=2,n
			b(i)=b(i)-((a(i)/b(i-1))*c(i-1))
			d(i)=d(i)-((a(i)/b(i-1))*d(i-1))
		end do
			x(n)=d(n)/b(n)
		do i=n-1,1,-1
			x(i)=(d(i)-(c(i)*x(i+1)))/b(i)
		end do
	end subroutine triSolve

end module module_triSolve

!USAGE: USE module_triSolve
	!way to define in main program
	!a=-1.0d0
	!a(1)=0.0d0
	!b=2.0d0
	!c=-1.0d0
	!c(n)=0.0d0
	!call  triSolve(a,b,c,d,u,n)


! HOW TO COMPILE THROUGH COMMAND LINE (CMD OR TERMINAL)
! gfortran -c trapezoidal.f95
! gfortran -o trapezoidal trapezoidal.o
!
! The program is open source and can use to numeric study purpose.
! The program was build by Aulia Khalqillah,S.Si
!
! email: auliakhalqillah.mail@gmail.com
! ==============================================================================
program trapz
  implicit none
  real :: xi,xf,xn,h,lt,li,f
  real,dimension (1000) :: x,fa,fori,result,estimate_i,er
  integer :: i,j,n
  character(len=100) :: save_file

  write(*,*)""
  write(*,*)"--------------------------------"
  write(*,*)"TRAPEZOIDAL METHOD - INTEGRATION"
  write(*,*)"--------------------------------"
  write(*,*) ""
  write(*,"(a)",advance="no") "Insert Initial Boundary (XI):"
  read*, xi
  write(*,"(a)",advance="no") "Insert Final Boundary (XF):"
  read*, xf
  write(*,"(a)",advance="no") "Insert Data Length (ex: N=100):"
  read*, n

  write(*,*)""
  ! Calculate step data point
  h = (xf-xi)/n
  ! Generate the data with h step data point and subtitute in original function
  x(1) = xi
  do i = 1,n
    x(i+1) = x(i) + h
    fori(i) = f(x(i))
  end do

  ! Sum the second part of the trapezoidal equation
  fa(1) = f(xi)
  do j = 1,n-1
    fa(j+1) = fa(j) + f(x(j+1))
  end do

  ! Calculate the trapezoidal integration
  do i = 1,n
    result(i) = (h/2)*(f(xi) + (2*fa(i)) + f(xf))
  end do

  ! Calculate error between final result(n) with each iteration
  do i = 1,n
    er(i) = abs((result(n)-result(i))/result(n))*100
  end do

  write(*,*) "Trapezoidal Integration Result: ", result(n)
  write(*,*) "error: ",er(n), " %"
  write(*,*) ""

  ! Save integration result to file
  save_file = 'trapz.txt'
  open (10,file=save_file,status='replace')
  do i = 1,n
    write(10,*) i,x(i),fori(i),result(i),er(i)
  end do
  write(*,*)"Result has been saved in > ",save_file
  write(*,*) ""
  close(10)
end program

real function f(x)
  implicit none
  real :: x
  f = 0.2 + (25*x) - (200*(x**2)) + (675*(x**3)) - (900*(x**4)) + (400*(x**5))
  ! f = 2*x
end function


MODULE GROUND
	!Different ground profiles
 	USE NRTYPE
 	IMPLICIT NONE
 	!-----------------------------------------------------------
 	CONTAINS
 	!-----------------------------------------------------------
	!Gaussian Hill (Default)
 	FUNCTION GHILL(H0,X0,S,X) RESULT(H)
  	IMPLICIT NONE
  	REAL(DP), INTENT(IN) :: H0, x0, s, x
  	REAL(DP) :: H
  	H = H0*EXP(-(x-x0)**2/s**2)
 	END FUNCTION GHILL
 	!-----------------------------------------------------------
	!Symmetric Triangular Hill
 	FUNCTION STHILL(H0,X0,D,X) RESULT(H)
 	IMPLICIT NONE
 	REAL(DP), INTENT(IN) :: H0, X0, D, X
 	REAL(DP) :: H
  	IF ((X.LE.(X0-D)).OR.(X.GE.(X0+D))) THEN
    		H = 0
	ELSEIF (X.LE.X0) THEN
		H = H0*((X-X0)/D+1)
	ELSEIF (X.GT.X0) THEN
		H = H0*((X0-X)/D+1)
	ENDIF
	END FUNCTION STHILL
 	!-----------------------------------------------------------
	!Unsymmetric Triangular Hill
	FUNCTION THILL(H0,X0,D1,D2,X) RESULT(H)
 	IMPLICIT NONE
 	REAL(DP), INTENT(IN) :: H0, X0, D1, D2, X
 	REAL(DP) :: H
  	IF ((X.LE.(X0-D1)).OR.(X.GE.(X0+D2))) THEN
    		H = 0
	ELSEIF (X.LE.X0) THEN
		H = H0*((X-X0)/D1+1)
	ELSEIF (X.GT.X0) THEN
		H = H0*((X0-X)/D2+1)
	ENDIF
	END FUNCTION THILL
	!-----------------------------------------------------------
	!Rectangular Hill
	FUNCTION RHILL(H0,X1,X2,X) RESULT(H)
	IMPLICIT NONE
	REAL(DP), INTENT(IN) :: H0, X1, X2, X
	REAL(DP) :: H
	IF ((X.LT.X1).OR.(X.GT.X2)) THEN
		H = 0
	ELSE
		H = H0
	ENDIF
	END FUNCTION RHILL
 	!-----------------------------------------------------------
	!Slope
	FUNCTION SLOPE(H1,H2,X1,X2,X) RESULT(H)
 	IMPLICIT NONE
 	REAL(DP), INTENT(IN) :: H1, H2, X1, X2, X
 	REAL(DP) :: H
  	IF ((X.LT.X1).OR.(X.GT.X2)) THEN
		H = 0
	ELSE
		H = ((H2-H1)*X+X2*H1-X1*H2)/(X2-X1)
	ENDIF
	END FUNCTION SLOPE
	!-----------------------------------------------------------
!	FUNCTION REALTERR
!	END FUNCTION REALTERR
 	!-----------------------------------------------------------
END MODULE GROUND


module bspline
  use num_integration
  use utils, only : wp

  implicit none

contains

  !--------------------
  ! New implementation
  !--------------------
  function cubic_spline_basis(x)
    real(wp) :: cubic_spline_basis
    real(wp), intent(in) :: x

    if ( x <= -2.0 ) then
      cubic_spline_basis = 0
    elseif ( -2.0 < x .and. x <= -1.0 ) then
      cubic_spline_basis = (1.0/4.0)*(2.0+x)**3
    elseif ( -1.0 < x .and. x <= 0.0 ) then
      cubic_spline_basis = (1.0/4.0)*((2.0+x)**3 - 4*(1.0+x)**3)
    elseif ( 0.0 < x .and. x <= 1.0 ) then
      cubic_spline_basis = (1.0/4.0)*((2.0-x)**3 - 4.0*(1-x)**3)
    elseif ( 1.0 < x .and. x <= 2.0 ) then
      cubic_spline_basis = (1.0/4.0)*(2.0-x)**3
    elseif( 2.0 < x ) then
      cubic_spline_basis = 0
    end if

  end function cubic_spline_basis

  function cubic_spline_basis_deriv(x)
    real(wp) :: cubic_spline_basis_deriv
    real(wp), intent(in) :: x

    if ( x <= -2.0 ) then
      cubic_spline_basis_deriv = 0.0
    elseif ( -2.0 < x .and. x <= -1.0 ) then
      cubic_spline_basis_deriv = (1.0/4.0)*3.0*(2.0+x)**2
    elseif ( -1.0 < x .and. x <= 0.0 ) then
      cubic_spline_basis_deriv = -(1.0/4.0)*((9*x**2)+(12*x))
    elseif ( 0.0 < x .and. x <= 1.0 ) then
      cubic_spline_basis_deriv = (1.0/4.0)*(3*x*(3*x-4.0))
    elseif ( 1.0 < x .and. x <= 2.0 ) then
      cubic_spline_basis_deriv = -(1.0/4.0)*3.0*(2.0-x)**2
    elseif( 2.0 < x ) then
      cubic_spline_basis_deriv = 0.0
    end if

  end function cubic_spline_basis_deriv

  function linear_spline_basis(x)
    real(wp) :: linear_spline_basis
    real(wp), intent(in) :: x

    if ( x < -1.0 .or. x > 1.0 ) then
      linear_spline_basis = 0.0
    elseif ( x <= 0.0 ) then
      linear_spline_basis = (x+1.0)
    elseif ( x <= 1.0 ) then
      linear_spline_basis = (1.0-x)
    end if

  end function linear_spline_basis

  ! ------------------
  ! Old implementation
  ! ------------------
  function linear_spline(y,x)
    !---------------
    ! Variables
    !---------------
    ! y are the three points on top of which
    ! the linear spline sits. Everywhere else
    ! it is zero.
    ! x is used for computing the desired value
    ! this spline assumes in this given point.
    real(wp), intent(in) :: y(3),x
    real(wp) :: h
    real(wp) :: linear_spline
    h = y(2) - y(1)
    linear_spline = 0

    if ( x < y(1) ) then
      linear_spline = 0
    elseif ( x <= y(2) ) then
      linear_spline = (x - y(1))/h
    elseif ( x <= y(3) ) then
      linear_spline =  (y(3) - x)/h
    end if
  end function linear_spline

  function linear_spline_deriv(y,x)
    !---------------
    ! Variables
    !---------------
    ! y are the three points on top of which
    ! the linear spline sits. Everywhere else
    ! it is zero.
    ! x is used for computing the desired value
    ! this spline assumes in this given point.
    real(wp), intent(in) :: y(3),x
    real(wp) :: h
    real(wp) :: linear_spline_deriv
    h = y(2) - y(1)
    linear_spline_deriv = 0.0_wp

    if ( x < y(1) ) then
      linear_spline_deriv = 0
    elseif ( x <= y(2) ) then
      linear_spline_deriv = 1.0_wp/h
    elseif ( x <= y(3) ) then
      linear_spline_deriv =  -1.0_wp/h
    end if
  end function linear_spline_deriv

  function cubic_spline(y, x)
    !---------------
    ! Variables
    !---------------
    ! y are the five points on top of which
    ! the cubi spline sits. Everywhere else
    ! it is zero.
    ! x is used for computing the desired value
    ! this spline assumes in this given point.
    real(wp), intent(in) :: y(5), x
    real(wp) :: h
    integer :: i,j
    real(wp) :: cubic_spline

    h = y(2) - y(1)
    if ( x < y(1) .or. x > y(5)) then
      cubic_spline = 0

    elseif ( x >= y(1) .and. x < y(2) ) then
      cubic_spline = ((x-y(1))**3)/(6*h**3)

    elseif ( x >= y(2) .and. x < y(3) ) then
      cubic_spline = &
      ( ((x-y(1))**2)*(y(3)-x) &
          + (x-y(1))*(y(4)-x)*(x-y(2))   &
      + ( (y(5)-x)*(x-y(2))**2 ) )/(6*h**3)

    elseif ( x >= y(3) .and. x < y(4) ) then
      cubic_spline = &
        ( (y(5)-x)*(x-y(2))*(y(4)-x) &
          + ((y(5)-x)**2)*(x-y(3))  &
      + (x-y(1))*(y(4)-x)**2 )/(6*h**3)

    elseif ( x >= y(4) .and. x < y(5) ) then
      cubic_spline = ((y(5)-x)**3)/(6*h**3)

    end if

  end function cubic_spline

  function cubic_spline_deriv(y, x)
    !---------------
    ! Variables
    !---------------
    ! y are the five points on top of which
    ! the cubi spline sits. Everywhere else
    ! it is zero.
    ! x is used for computing the desired value
    ! this spline assumes in this given point.
    real(wp), intent(in) :: y(5), x
    real(wp) :: h
    integer :: i,j
    real(wp) :: cubic_spline_deriv

    h = y(2) - y(1)
    if ( x < y(1) .or. x > y(5)) then
      cubic_spline_deriv = 0.0_wp

    elseif ( x >= y(1) .and. x < y(2) ) then
      cubic_spline_deriv = ((x-y(1))**2)/(2*h**3)

    elseif ( x >= y(2) .and. x < y(3) ) then
      cubic_spline_deriv = &
        - (9*x**2 - ( 2*y(5) + 2*y(4) + 2*y(3) + 6*y(2) + 6*y(1))*x &
        + 2*y(2)*y(5) &
        +( y(2) + y(1) )*y(4) + 2*y(1)*y(3) &
        + y(2)**2 + y(1)*y(2) + y(1)**2) / (6*h**3)

    elseif ( x >= y(3) .and. x < y(4) ) then
      cubic_spline_deriv = &
        (9*x**2 - ( 6*y(5) + 6*y(4) + 2*y(3) + 2*y(2) + 2*y(1) )*x &
        + y(5)**2 &
        + ( y(4)+2*y(3)+y(2) )*y(5) + y(4)**2 &
        + ( y(2)+2*y(1) )*y(4)) / (6*h**3)

    elseif ( x >= y(4) .and. x < y(5) ) then
      cubic_spline_deriv = (-(y(5)-x)**2)/(2*h**3)

    end if
  end function cubic_spline_deriv

end module bspline


module modpk_rng
  !Module that contains routines for random number generation.
  !Some of this has been taken (where indicated) from
  !RosettaCode.org and from other sites on the net.
  use modpkparams, only : dp
  implicit none

interface init_random_seed
	module procedure init_random_seed_parallel
	module procedure init_random_seed_serial
end interface

interface shuffle
	module procedure shuffle_dp_dimn
	module procedure shuffle_int_dimn
	module procedure shuffle_dp_1
	module procedure shuffle_int_1
end interface

interface normal
  module procedure normal_array
  module procedure normal_scalar
end interface

!Default to public.

contains

!Generate an array of n numbers sampled from a Gaussian normal distribution with mean and standard deviation given.
!Adapted from RosettaCode.org.
function normal_array(n,mean,std) result(normal)
  implicit none

  integer, intent(in) :: n
  integer :: i
  real(dp) :: normal(n), temp
  real(dp), intent(in) :: mean, std
  real(dp), parameter :: pi = 4.0*ATAN(1.0)

  !Get uniform distribution.
  call random_number(normal)

  !Now convert to normal distribution
  do i = 1, n-1, 2
    temp = std * SQRT(-2.0*LOG(normal(i))) * COS(2*pi*normal(i+1)) + mean
    normal(i+1) = std * SQRT(-2.0*LOG(normal(i))) * SIN(2*pi*normal(i+1)) + mean
    normal(i) = temp
  end do

end function normal_array

!Generate a scalar sampled from a Gaussian normal distribution with mean and standard deviation given.
!Adapted from RosettaCode.org.
function normal_scalar(mean,std) result(scalar)
  implicit none

  integer :: i
  integer, parameter :: n=4
  real(dp) :: normal(n), temp, scalar
  real(dp), intent(in) :: mean, std
  real(dp), parameter :: pi = 4.0*ATAN(1.0)

  !Get uniform distribution.
  call random_number(normal)

  !Now convert to normal distribution
  do i = 1, n-1, 2
    temp = std * SQRT(-2.0*LOG(normal(i))) * COS(2*pi*normal(i+1)) + mean
    normal(i+1) = std * SQRT(-2.0*LOG(normal(i))) * SIN(2*pi*normal(i+1)) + mean
    normal(i) = temp
  end do

  scalar = normal(1)

end function normal_scalar

!Generate a random seed based on the clock time.
!Adapted from GNU site.
subroutine init_random_seed_serial()
implicit none
	integer :: i, n, clock
	integer, dimension(:), allocatable :: seed

	call random_seed(size = n)
	allocate(seed(n))

	call system_clock(count=clock)

	seed = clock + 37* (/ (i - 1, i = 1, n) /)
	call random_seed(PUT = seed)

	deallocate(seed)
end subroutine init_random_seed_serial

!Generate a random seed based on the clock time --- For use in parallel.
subroutine init_random_seed_parallel(rank)
implicit none
	integer :: i, n, clock
	integer, dimension(:), allocatable :: seed
	integer, intent(in) :: rank

	call random_seed(size = n)
	allocate(seed(n))

	call system_clock(count=clock)

	seed = clock + 37*rank* (/ (i - 1, i = 1, n) /)
	call random_seed(PUT = seed)

	deallocate(seed)
end subroutine init_random_seed_parallel

!Subroutine to shuffle an array by Knuth Shuffle.
!Inspired by RosettaCode.org.
subroutine shuffle_int_1(a)
implicit none
	integer, intent(inout) :: a(:)
	integer :: i, randpos, temp
	real :: r

	!Count backwards
	do i = size(a), 2, -1
		!Get a random number.
		call random_number(r)
		randpos = int(r * i) + 1
		!Exchange the rows.
		temp = a(randpos)
		a(randpos) = a(i)
		a(i) = temp
	end do

end subroutine shuffle_int_1

subroutine shuffle_dp_dimn(a)
  implicit none

  real(dp), dimension(:,:), intent(inout) :: a
	real(dp), dimension(size(a,2)) :: temp
	integer :: i, hold
	real(dp) :: rand

	!Count backwards.
	do i=size(a,1), 1, -1
		!Generate a random int from 1-i.
		call random_number(rand)
		hold=int(rand*i)+1
		!Swap the ith row with the rand row.
		temp(:)=a(hold,:)
		a(hold,:)=a(i,:)
		a(i,:) = temp(:)
	end do

end subroutine shuffle_dp_dimn

subroutine shuffle_dp_1(a)
  implicit none

	real(dp), dimension(:), intent(inout) :: a
	real(dp) :: temp
	integer :: i, hold
	real(dp) :: rand

	!Count backwards.
	do i=size(a,1), 1, -1
		!Generate a random int from 1-i.
		call random_number(rand)
		hold=int(rand*i)+1
		!Swap the ith row with the rand row.
		temp=a(hold)
		a(hold)=a(i)
		a(i) = temp
	end do

end subroutine shuffle_dp_1

subroutine shuffle_int_dimn(a)
  implicit none

	integer, dimension(:,:), intent(inout) :: a
	integer, dimension(size(a,2)) :: temp
	integer :: i, hold
	real(dp) :: rand

	!Count backwards.
	do i=size(a,1), 1, -1
		!Generate a random int from 1-i.
		call random_number(rand)
		hold=int(rand*i)+1
		!Swap the ith row with the rand row.
		temp(:)=a(hold,:)
		a(hold,:)=a(i,:)
		a(i,:) = temp(:)
	end do

end subroutine shuffle_int_dimn

!Subroutine that takes two sets, shuffles them together n times, then divides them along the columns, returning same sized arrays that are a mix of both sets.
subroutine shuffle_cut(setA, setB, n)
  implicit none

	real(dp), dimension(:,:), intent(inout) :: setA, setB
	integer, optional, intent(in) :: n
	real(dp), dimension((size(setA,1)+size(setB,1)),size(setA,2)) :: work
	real(dp) ::  rand
	integer :: i, iend

	!Load the work function.
	do i=1,size(work,1)
		if (i .le. size(setA,1)) then
			work(i,:)=setA(i,:)
		else
			work(i,:)=setB(i-size(setA,1),:)
		end if
	end do

	!Shuffle the set.
	if (present(n)) then
		iend=n
	else
		iend=2
	end if
	do i=1,iend
		call shuffle(work)
	end do

	!Unload work.
	do i=1,size(work,1)
		if (i .le. size(setA,1)) then
			setA(i,:)=work(i,:)
		else
			setB(i-size(setA,1),:)=work(i,:)
		end if
	end do

end subroutine shuffle_cut

!Function to make a cluster of "n" points centered at "center" with given std "sigma."
function make_blob(n, center, sigma)
  implicit none

	real(dp), dimension(:), intent(in) :: center
	real(dp), optional, intent(in) :: sigma
	real(dp):: std
	integer, intent(in) :: n
	real(dp), dimension(:,:), allocatable :: make_blob
	integer :: i,j

	!Optional argument for standard deviation.
	if (present(sigma)) then
		std = sigma
	else
		std = 1e0_dp
	end if

	call init_random_seed()

	allocate(make_blob(n,size(center)))

	do j=1,size(center)
		make_blob(:,j) = normal(n,center(j),std)
	end do

end function make_blob

function rand_sign() result(sign)

  real(dp) :: sign
  real(dp) :: rand

  call random_number(rand)

  if (rand >0.5) then
    sign = -1.0e0_dp
  else
    sign = 1.0e0_dp
  end if

end function rand_sign

end module modpk_rng


      MODULE stel_constants

      USE stel_kinds

!----------------------------------------------------------------------
!  Mathematical constants
!----------------------------------------------------------------------

      REAL(rprec), PARAMETER :: pi=3.14159265358979323846264338328_rprec
      REAL(rprec), PARAMETER :: pio2=pi/2
      REAL(rprec), PARAMETER :: twopi=2*pi
      REAL(rprec), PARAMETER :: sqrt2=1.41421356237309504880168872_rprec
      REAL(rprec), PARAMETER :: degree=twopi / 360
      REAL(rprec), PARAMETER :: one=1
      REAL(rprec), PARAMETER :: zero=0

!----------------------------------------------------------------------
!  Physical constants
!------------------------------------------------------------------

      REAL(rprec), PARAMETER :: mu0 = 2 * twopi * 1.0e-7_rprec

      END MODULE stel_constants


module continuous_functions
  use nrtype
contains
  pure function polynomial(x)
    implicit none
    real(dp), intent(in) :: x
    real(dp)             :: polynomial

    polynomial = (x-2)*(x+5)*x   !(x-1.)*(x+1.)*(x-2.)*(x+2.)*(x-3.)*(x+3.)
    !1.*x**6.-1./3.*x**5.+ 1./5.*x**4.-1./7.*x**3.+1./9.*x**2.-1./11.*x+1./13.
  end function polynomial
end module continuous_functions


! HOW TO COMPILE THROUGH COMMAND LINE (CMD OR TERMINAL)
! gfortran -c falseposition.f95
! gfortran -o falseposition falseposition.o
!
! The program is open source and can use to numeric study purpose.
! The program was build by Aulia Khalqillah,S.Si.,M.Si
!
! email: auliakhalqillah.mail@gmail.com
! ==============================================================================
program bisection_method
    implicit none
    real :: xi,xf,xr,error,xrold,f,limiterror
    real :: start,finish
    integer :: iter, condition
    character(len=100) :: fmt

    write(*,*)""
    write(*,*)"---------------------------------"
    write(*,*)"FALSE POSITION - FINDING ROOT"
    write(*,*)"---------------------------------"
    write(*,*) ""
    write(*,"(a)",advance="no") "Insert Initial Boundary (XI):"
    read*, xi
    write(*,"(a)",advance="no") "Insert Final Boundary (XF):"
    read*, xf

    fmt = "(a12,a13,a13,a20,a13,a17,a20,a17,a17,a20)"
    write(*,*)""

    ! Start root calculation
    call cpu_time(start)
    limiterror = 1e-20
    open(20, file='falsepoint.txt', status='replace')
        iter = 1
        xrold = xi
        ! Calculate the root by using false position method (secant method approximation)
        xr = xf - ((f(xf)*(xf-xi))/(f(xf)-f(xi)))
        error = abs((xr-xrold)/xr) * 100
        condition = 0
        write(*,fmt)"ITER","Xi","Xf","F(Xi)","F(Xf)","XROLD","XR[ROOT]","F(XR)","ERROR","CONDITION"
        do while (error > limiterror .or. isnan(error))
            ! write the result on terminal and save to the file
            write(*,*) iter,xi,xf,f(xi),f(xf),xrold,xr,f(xr),error,condition
            write(20,*) iter,xi,xf,f(xi),f(xf),xrold,xr,f(xr),error,condition
            ! Check first condition by using bisection approximation
            if ((f(xi)*f(xr)) < 0) then
                xf = xr
                xrold = xr
                xr = xf - ((f(xf)*(xf-xi))/(f(xf)-f(xi)))
                if (xr == 0) then
                    error = 100
                else
                    error = abs((xr-xrold)/xr) * 100
                end if
                condition = 1
            ! Check second condition by using bisection approximation
            elseif ((f(xi)*f(xr)) > 0) then
                xi = xr
                xrold = xr
                xr = xf - ((f(xf)*(xf-xi))/(f(xf)-f(xi)))
                if (xr == 0) then
                    error = 100
                else
                    error = abs((xr-xrold)/xr) * 100
                end if
                condition = 2
            ! Check third condition by using bisection approximation
            elseif (f(xi)*f(xr) == 0) then
                xr = xr
                if (f(xr) == 0) then
                    xr = xr
                else
                    xr = xi
                endif
                xrold = xr
                if (xr == 0) then
                    error = 100
                else
                    error = abs((xr-xrold)/xr) * 100
                end if
                condition = 3
            end if
            iter = iter + 1
        end do
    close(20)
    call cpu_time(finish)
    print '("Time = ",f12.8," seconds.")',finish-start
    end program

    function f(x)
    implicit none
    real::x,f
    ! f = (x**2)-16
    f = (x**2)-(2*x)+1
    ! f = (x**3) - (x**2) - (10*x) + 2
    end


program main
    use LinearSolverClass
    implicit none

    ! Create Ax=B and solve x = A^(-1) B
    integer(int32), parameter :: N = 4 ! rank = 3
    real(real64)  :: t1,t2 ! time measure
    real(real64) :: A(1:N,1:N), B(1:N), X(1:N) ! A, x and B
    real(real64) :: Val(1:10)
    integer(int32) :: index_i(1:10),index_j(1:10)
    type(LinearSolver_) :: solver ! linear solver instance.

    ! creating A, x, and B
    A(1,1:4) = (/  2.0d0, -1.0d0,  0.0d0, 0.0d0 /)
    A(2,1:4) = (/ -1.0d0,  2.0d0, -1.0d0, 0.0d0 /)
    A(3,1:4) = (/  0.0d0,  2.0d0,  3.0d0, 1.0d0 /)
    A(4,1:4) = (/  0.0d0,  0.0d0,  1.0d0, 2.0d0 /)

    X(1:4)   = (/  0.0d0,  0.0d0,  0.0d0, 0.0d0 /)

    B(1:4)   = (/  1.0d0,  2.0d0,  3.0d0, 4.0d0 /)

    ! CRS-format
    Val(1:10) = (/  2.0d0, -1.0d0,  -1.0d0,  2.0d0, -1.0d0, 2.0d0, 3.0d0, &
        1.0d0, 1.0d0,  2.0d0/)
    index_i(1:10) = (/ 1, 1, 2, 2, 2, 3, 3, 3, 4, 4/)
    index_j(1:10) = (/ 1, 2, 1, 2, 3, 2, 3, 4, 3, 4/)

    ! import Ax=B into the linear solver instance.
    call solver%import(a = A, x = X, b = B)

    ! get a cpu-time
    call cpu_time(t1)
    ! solve Ax=B by Gauss-Jordan
    call solver%solve(Solver="GaussJordan")
    ! get a cpu-time
    call cpu_time(t2)
    ! show result
    ! X is stored in solver%X(:) (solver.x[])
    print *, "Solved by GaussJordan",solver%X(:),"/",t2-t1," sec."

    ! Similarly ...

    X(1:4)   = (/  0.0d0,  0.0d0,  0.0d0, 0.0d0 /)
    call solver%import(a = A, x = X, b = B, val=val, index_i=index_i, index_j=index_j)
    call cpu_time(t1)
    call solver%solve(Solver="GaussSeidel")
    call cpu_time(t2)
    print *, "Solved by GaussSeidel",solver%X(:),"/",t2-t1," sec."

    X(1:4)   = (/  0.0d0,  0.0d0,  0.0d0, 0.0d0 /)
    call solver%import(a = A, x = X, b = B, val=val, index_i=index_i, index_j=index_j)
    call cpu_time(t1)
    call solver%solve(Solver="BiCGSTAB",CRS=.true.)
    call cpu_time(t2)
    print *, "Solved by BiCGSTAB(CRS)",solver%X(:),"/",t2-t1," sec."

    X(1:4)   = (/  0.0d0,  0.0d0,  0.0d0, 0.0d0 /)
    call solver%import(a = A, x = X, b = B, val=val, index_i=index_i, index_j=index_j)
    call cpu_time(t1)
    call solver%solve(Solver="BiCGSTAB",CRS=.false.)
    call cpu_time(t2)
    print *, "Solved by BiCGSTAB   ",solver%X(:),"/",t2-t1," sec."

    X(1:4)   = (/  0.0d0,  0.0d0,  0.0d0, 0.0d0 /)
    call solver%import(a = A, x = X, b = B)
    call cpu_time(t1)
    call solver%solve(Solver="GPBiCG")
    call cpu_time(t2)
    print *, "Solved by GPBiCG     ",solver%X(:),"/",t2-t1," sec."

    ! Under construction!
    !X(1:3)   = (/  0.0d0,  0.0d0,  0.0d0 /)
    !call solver%import(a = A, x = X, b = B)
    !call cpu_time(t1)
    !call solver%solve(Solver="GPBiCG",preconditioning=.true.)
    !call cpu_time(t2)
    !print *, "Solved by pre-GPBiCG ",solver%X(:),"/",t2-t1," sec."
end program


! File: MATH_FUNCS.f95
!
! Provides root-finding capability in Fortran for cubic equations by
! an analytical solution, based on equations at:
!     http://en.wikipedia.org/wiki/Cubic_function
!
! S. Socolofsky
! June 2013
! Texas A&M University
!

module Math_Constants

    ! Define constants for use by the contained math routines
    implicit none
    integer, parameter :: DP = 8

end module Math_Constants

subroutine cubic_roots(p, x0)

    !
    ! Computes the roots of a cubic polynomial with coefficients p().
    !
    ! Computes the roots of an 3rd-order polynomial with real-valued
    ! coefficients specified in p().  The order of the coefficients in
    ! p() are given by
    !
    !     p(1) * x**3 + p(2) * x**2 + p(3) * x + p(4) = 0
    !
    ! Input variables are:
    !     p = array (order 4) of polynomial coefficients (must be real)
    !
    ! Output variable is:
    !     x0 = array (order 3) of roots (real or complex)
    !
    ! S. Socolofsky
    ! June 2013
    !

    use Math_Constants
    implicit none

    ! Declare the input and output variable types
    integer, parameter :: N = 3
    real(kind = DP), intent(in), dimension(N + 1) :: p
    complex(kind = DP), intent(out), dimension(N) :: x0

    ! Declare the variables internal to the function
    integer :: k
    real(kind = DP) :: Delta, a, b, c, d, eps
    real(kind = DP), dimension(N) :: Dk
    complex(kind = DP), parameter :: I = cmplx(0.0, 1.0)
    complex(kind = DP) :: C0
    complex(kind = DP), dimension(N) :: u

    ! Extract the coefficient values for easier reference and understanding
    ! in the code
    a = p(1)
    b = p(2)
    c = p(3)
    d = p(4)

    ! Compute the ingredients to the solution
    Delta = 18.0D0 * a * b * c * d - 4.0D0 * b**3 * d + b**2 * c**2 - &
        &   4.0D0 * a * c**3 - 27.0D0*a**2*d**2
    Dk = [b**2 - 3.0D0 * a * c, &
        & 2.0D0 * b**3 - 9.0D0 * a * b * c + 27.0D0 * a**2 * d, &
        & -27.0D0 * a**2 * Delta]
    u = [1.0D0 + 0.0D0*I, (-1.0D0 + I * sqrt(3.0D0)) / 2.0D0, &
        & (-1.0D0 - I * sqrt(3.0D0)) / 2.0D0]
    C0 = ((Dk(2) + sqrt(Dk(3)+0.0D0*I)) / 2.0D0)**(1.0D0/3.0D0)

    ! Compute the solution
    x0(:) = -1.0D0 / (3.0D0 * a) * (b + u(:) * C0 + Dk(1) / (u(:) * C0))

    ! Get the machine precision
    eps = epsilon(0.0)

    ! Convert appropriately small numbers to zero
    do k = 1, N
        ! Real part first
        if (abs(real(x0(k))) < eps) then
            x0(k) = cmplx(0.0D0, aimag(x0(k)), kind = DP)
        end if
        ! And imaginary part
        if (abs(aimag(x0(k))) < eps) then
            x0(k) = cmplx(real(x0(k)), 0.0D0, kind = DP)
        end if
    end do

end subroutine cubic_roots

! End File: MATH_FUNCS.f95


program main
  ! Default
  implicit none

  ! Parameters
  integer(4), parameter :: target_num_div = 500

  ! Variables
  integer(8) :: i,tri_num,num_div

  ! Do work
  i       = 1
  tri_num = 0
  do
     tri_num = tri_num + i
     num_div = number_of_divisors(tri_num)

     if (num_div > target_num_div) then
        exit
     else
        i = i + 1
     endif
  enddo

  ! Write out answer
  write(*,*) "Smallest triangle number with more than ",target_num_div,&
       "divisors: ",tri_num

contains

  pure function number_of_divisors(i)
    ! Default
    implicit none

    ! Function arguments
    integer(8), intent(in) :: i
    integer(4)             :: number_of_divisors

    ! Local variables
    integer(8) :: max_try,test

    ! Find max factor to try
    max_try = nint(sqrt(1D0*i))

    ! We know that 1 and the number are trivial factors
    ! Protect against the case where i==1
    ! Since we start the checks below at n==2, the case of i==2
    !   is another special case we need to deal with properly
    if (i==1) then
       number_of_divisors = 1
       return
    else if (i==2) then
       number_of_divisors = 2
       return
    else
       number_of_divisors = 2
    endif

    ! Check to see if a number is a divisor
    ! We are testing from 2 to sqrt(i)
    ! For each number we find, we know there is going to be a pair of factors
    ! E.g.: for the case of i=36, we test from 2 to 6
    !   mod(36,2)==0 (so we've found 2 factors: 2 and 18)
    !   mod(36,3)==0 (another 2 factors: 3 and 12)
    !   mod(36,4)==0 (4 and 9)
    !   mod(36,5)/=0 (no factors)
    !   mod(36,6)==0 (but! 36/6==6, so we have caught the perfect-square case)
    ! Add to this the trivial factors of 1 and 36, and we have found all
    !   9 factors, while only having to test up through sqrt(36)
    test = 2
    do
       if (mod(i,test)==0) then
          ! Test for perfect-square case
          ! This should also be the end of the line, so we exit just in case
          !   rounding for max_int has introduced rouding errors
          if (i/test==test) then
             number_of_divisors = number_of_divisors + 1
             return
          else
             number_of_divisors = number_of_divisors + 2
          endif
       endif

       test = test + 1
       if (test > max_try) exit
    enddo

    return
  end function number_of_divisors

end program main


PROGRAM RectangleRuleForIntegration
    IMPLICIT NONE
    REAL:: a, b, Area
    INTEGER::  N      ! N is number of points
    WRITE(*, fmt = '(/A)', ADVANCE = 'NO') "Enter the number of points: "
    READ(*, *) N
    WRITE(*, fmt = '(/A)') "Enter the value of a & b"
    READ(*, *) a, b

    CALL RectangleRule(a, b, Area, N)
    WRITE(*, *) "Area under the curve is: ", Area

    CONTAINS
    SUBROUTINE RectangleRule(a, b, Area, N)
        IMPLICIT NONE
        REAL:: a, b, Area, h, Xi
        INTEGER:: N, i
        ! N is number of points
        h = (b-a)/(N-1)
        Area = 0.00
        DO i = 1, N-1
            Xi = a + (i-1)*h
            Area = Area + f(Xi) * h
        ENDDO
    END SUBROUTINE RectangleRule

    REAL FUNCTION f(x)
        IMPLICIT NONE
        REAL:: x
        f = 1.0/x
        return
    END FUNCTION f

END PROGRAM RectangleRuleForIntegration


! This file is provided as part of the "projet long" for the "Calcul Scientifique et Analyse de Données" course
! at INP-ENSEEIHT
! Date: 02/2019
! Authors: P. Amestoy, P. Berger, A. Buttari, Y. Diouane, S. Gratton, R. Guivarch, F.H. Rouet, E. Simon
!
! This file contains the implementation of
! - one routine for computing the eigenpairs of a symmetric matrix with the subspace iteration method
!   with Rayleigh-Ritz projection
!
!--------------------------------------------------------------------------------------------------------------------
!
!! subspace_iter_v1
! -----------------
!
! routine that computes a certain amount of eigenvalues and eigenvectors of a matrix A
! using the subspace iteration method with Rayleigh-Ritz projection (v1)
!
! ..Input arguments
!    n : integer, size of the matrix A
!    m : integer, size of the searched subspace
!    a : double precision matrix
!
!    percentage : double precision, fraction of the trace we would like to obtain
!
!    maxit : integer, maximum number of iterations of the power method
!    eps : the tolerance for the stopping criterion of the power method
!
! ..Input/Output arguments
!    v : double precision matrix, (input) the starting subspace
!                                 (output) the eigenvectors corresponding
!                                          to the dominant eigenvalues
!
! ..Output arguments
!    w : double precision vector, the eigenvalues
!    n_ev : integer, the number of computed eigenvalues
!    acc_ev : double precision vector, accuracy for each eigenvalues
!    it_ev : integer vector, number of iterations for each eigenvalues
!
!    ierr : integer, indicates how the routine ends
!           O : OK
!           1 : the maximum number of eigenvalues is reached before obtaining the percentage (WARNING)
!          -1 : inconsistancy of the values of the arguments (ERROR)
!          -2 : allocation problem (ERROR)
!          -3 : maxit reached (ERROR)
!          -4 : problem in dsyev (ERROR)
!-------------------------------------------------------------------------------------------------------------------
  subroutine subspace_iter_v1(n, m, a, percentage, maxit, eps, v, w, n_ev, acc_ev, it_ev, ierr)
    implicit none
    !! the subspace dimensions
    integer,          intent(in)                     :: n, m
    !! the target matrix
    double precision, dimension(n, n), intent(in)    :: a
    !! the percentage of the trace we want to obtain
    double precision, intent(in)                     :: percentage
    !! maximum # of iteration
    integer,          intent(in)                     :: maxit
    !! the tolerance for the stopping criterion
    double precision, intent(in)                     :: eps
    !! the starting subspace. The computed eigenvectors will be
    !! returned in this array
    double precision, dimension(n, m), intent(inout) :: v
    !! the m dominant eigenvalues
    double precision, dimension(m), intent(out)      :: w
    !! number of computed eigenvalues
    integer,          intent(out)                    :: n_ev
    !! accuracy for each eigenvalues
    double precision, dimension(m),   intent(out)    :: acc_ev
    !!  number of iterations for each eigenvalues
    integer,          dimension(m),   intent(out)    :: it_ev
    !! a flag for signaling errors
    integer,          intent(out)                    :: ierr

    ! external functions
    double precision, external                       :: dlange, ddot

    ! constants
    integer, parameter                               :: ione = 1
    double precision, parameter                      :: done = 1.d0, dzero = 0.d0, dmoins = -1.d0

    !! local variables
    integer                                          :: i, j
    double precision, allocatable, dimension(:,:)    :: y
    double precision, allocatable, dimension(:,:)    :: h, x
    double precision, allocatable, dimension(:)      :: aux_acc, w_aux, t
    double precision                                 :: trace, p_trace, eig_sum, normF_A
    integer                                          :: conv
    integer                                          :: k
    double precision                                 :: acc
    logical                                          :: ok
    double precision                                 :: beta
    !! the length of the workspace for dsyev
    integer                                          :: lwork
    !! the workspace
    double precision, allocatable, dimension(:)      :: work

    ierr = 0

    if(m.gt.n)then
       ierr = -1
       return
    end if

    lwork = m*m + 5*m + n*n
    allocate(y(n, m), h(m, m), x(m, m), w_aux(m), aux_acc(n), t(m), work(lwork), stat=ierr)
    if(ierr .ne. 0) then
      ierr = -2
      return
    end if

    trace = 0.d0
    do i = 1, n
      trace = trace + a(i,i)
    end do
    p_trace = percentage * trace
    eig_sum = 0.d0

    normF_A = dlange('f', n, n, a, n, work)

    it_ev = 0
    acc_ev = 0.D0
    n_ev = 0
    k = 0

    !! Initial set of orthonormal vectors
    call gram_schmidt(v, n, m, y)
    v = y

    do while((eig_sum .lt. p_trace) .and. (n_ev .lt. m) .and. (k .lt. maxit))

      k = k + 1

      !! A. Compute  y = a*v
      call dgemm('n','n', n, m, n, done, a, n, v, n, dzero, y, n)

      !! B. Orthonormalisation
      call gram_schmidt(y, n, m, v)

      !! C. Rayleigh-Ritz projection
      !!   1. H = V^T A V
      !!     Y = A V
      call dgemm('n','n', n, m, n, done, a, n, v, n, dzero, y, n)
      !!     H = V'*Y
      call dgemm('t', 'n', m, m, n, done, v, n, y, n, dzero, h, m)
      !!   2. Spectral decomposition
      call dsyev('v', 'u', m, h, m, w_aux, work, lwork, ierr)
      if( ierr .ne.0 )then
        write(*,'("Error in dsyev")')
        ierr = -4
        goto 999
      end if

      !! Sort in the decreasing order
      !! (we suppose that all the eigen values are positve)
      do i = 1, m
        t(i) = w_aux(m-i+1)
        x(:, i)  = h(:, m-i+1)
      end do

      !!   3. V = VX
      y = v
      call dgemm('n', 'n', n, m, m, done, y, n, x, m, dzero, v, n)

      !! D. Convergence analysis step
      conv = 0
      i = n_ev + 1
      !! the larger eigenvalue will converge more swiftly than
      !! those corresponding to the smaller eigenvalue.
      !! for this reason, we test the convergence in the order
      !! i=1,2,.. and stop with the first one to fail the test
      ok = .false.
      do while(.not. ok)
        if( i .gt. m) then
          ok = .true.
        else
          !!compute acc=norm(a*v(:,i) - v(:,i)*t(i),2)/lambda;
          !!--compute aux_acc=a*v(:,i) - v(:,i)*t(i)
          !!--compute acc=||aux_acc||/||a||
          aux_acc = v(:,i)
          beta = -t(i)
          call dgemv('n', n, n, done, a, n, v(1,i), ione, beta, aux_acc, ione)
          acc = sqrt(ddot(n, aux_acc, ione, aux_acc, ione))/normF_A
          ! write(*,*) i, acc

          if(acc.gt.eps) then
            ok = .true.
          else
            ! write(*,*) 'vector', i, 'converges', acc
            conv = conv + 1
            w(i) = t(i)
            acc_ev(i) = acc
            it_ev(i) = k
            eig_sum = eig_sum + w(i)
            i = i + 1
            if( eig_sum .ge. p_trace) ok = .true.
          end if
        end if
      end do

      n_ev = n_ev + conv
      !write(*,*) n_ev

    end do

    if(n_ev .eq. m) then
      ierr = 1
    end if
    if(k .eq. maxit) then
      ierr = -3
    end if

999 continue
    deallocate(y, h, x, w_aux, aux_acc, t)
    write(*,*)

    return
  end subroutine subspace_iter_v1


FUNCTION sinc ( x )
!
!  Purpose:
!    To calculate the sinc function
!       sinc(x) = sin(x) / x
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/23/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare calling parameter types & definitions
REAL, INTENT(IN) :: x        ! Value for which to evaluate sinc
REAL :: sinc                 ! Output value sinc(x)

! Data dictionary: declare local constants
REAL, PARAMETER :: EPSILON = 1.0E-30  ! the smallest value for which
                                      ! to calculate SIN(x)/x

! Check to see of ABS(x) > EPSILON.
IF ( ABS(x) > EPSILON ) THEN
   sinc = SIN(x) / x
ELSE
   sinc = 1.
END IF

END FUNCTION sinc


! A Pythagorean triplet is a set of
! three natural numbers, a < b < c, for which,
! a^2 + b^2 = c^2
! For example, 32 + 42 = 9 + 16 = 25 = 52.
! There exists exactly one Pythagorean triplet
! for which a + b + c = 1000.
! Find the product abc.
!
! Project Euler: 9
! Answer: 31875000

program main

use euler

implicit none

        ! a + b + c = 1000
        ! 1000 - (a + b) = c

        integer (kind=8), parameter :: PERIMETER = 1000
        integer (kind=8) :: a, b, c

        outer: do a = 1, PERIMETER, 1

                inner: do b = 1, PERIMETER, 1

                        c = PERIMETER - (a + b)

                        if(c <= 0) then
                                exit inner
                        endif

                        if(pythag_triplet(a, b, c)) then
                                exit outer
                        endif

                end do inner

        end do outer

        print*, a * b * c

contains

        ! Test whether a triple is pythagorean - the long way

        pure function pythag_triplet(a, b, c)

                integer (kind=8), intent(in) :: a, b, c
                logical :: pythag_triplet

                pythag_triplet = (a ** 2 + b ** 2 == c ** 2)

                return

        end function pythag_triplet

        ! It can be shown that;
        !
        ! 500 = (a + b) - (a*b) / 1000
        !
        ! In this notion, we can check if a*b is divisible
        ! by 1000 and then if the above equation holds
        !
        ! More generally, Perimeter / 2 = (a + b) - (a * b) / perimeter
        !
        ! @param: PERIMETER must be defined to

        pure function special_pythag(a, b)

                integer (kind=8), intent(in) :: a, b
                integer (kind=8) :: prod
                logical :: special_pythag

                special_pythag = .false.

                prod = a * b

                if(mod(prod, PERIMETER) /= 0) then
                        return
                endif

                special_pythag = (PERIMETER / 2 == (a + b) - prod / PERIMETER)

                return

        end function special_pythag

end program main


MODULE precision
    ! dp = double precision
    INTEGER, PARAMETER:: dp = SELECTED_REAL_KIND(12)
END MODULE precision

PROGRAM Secant_Method
    USE precision
    IMPLICIT NONE

    REAL(KIND = dp):: x1, x2, x3, f1, f2, f3, error, root
    WRITE(*, *) "Enter value of 2 initial point "
    ! For this question enter 2 initial point x1 and x2
    READ *, x1, x2

    error = 1e-6
    f1 = Func(x1)
    f2 = Func(x2)

    DO
        x3 = (f2*x1 - f1*x2) / (f2 - f1)
        f3 = Func(x3)
        IF (f3 .EQ. 0.0) THEN
            root = x3
            WRITE(*, *) "Root is: ", root
            RETURN
        ENDIF

        IF (abs((x3 - x2)/x3) .LT. error) THEN
            root = x3
            WRITE(*, *) "Root is: ", root
            RETURN
        ELSE
            x1 = x2
            f1 = f2
            x2 = x3
            f2 = f3
        ENDIF
    ENDDO

    CONTAINS
    REAL(KIND = dp) FUNCTION Func(x)
        USE precision
        IMPLICIT NONE
        REAL(KIND = dp):: x
        Func = x**2 - 4*x - 10
        RETURN
    END FUNCTION Func

END PROGRAM Secant_Method

Roots of Nonlinear Equation/Secant Method.f90


program area_mandelbrot
  implicit none
!
  integer, parameter :: sp = kind(1.0)
  integer, parameter :: dp = kind(1.0d0)
  integer :: i, j, iter, numoutside
  integer, parameter :: npoints = 4000, maxiter = 4000
  real (kind=dp) :: area, error
  complex (kind=dp) :: c , z
  real :: starttime, endtime
!
! Calculate area of mandelbrot set
!
!    Outer loops runs over npoints, initialize z=c
!
!    Inner loop has the iteration z=z*z+c, and threshold test
!

  numoutside = 0

  call cpu_time(starttime)

  do i = 0,npoints-1
     do j= 0,npoints-1
        c = cmplx(-2.0+(2.5*i)/npoints + 1.0d-07,(1.125*j)/npoints + 1.0d-07)
        z = c
        iter = 0
        do while (iter < maxiter)
           z = z*z + c
           iter = iter + 1
           if (real(z)*real(z)+aimag(z)*aimag(z) > 4) then
              numoutside = numoutside + 1
              exit
           endif
        end do
     end do
  end do

  call cpu_time(endtime)
!
! Output results
!
  area = 2.0*2.5*1.125 * real(npoints*npoints-numoutside)/real(npoints*npoints)
  error = area/real(npoints)
  print *, "Area of Mandelbrot set = ",area," +/- ",error
  print *, "Tome taken for calculation: ",endtime-starttime
!
  stop
end program area_mandelbrot


!program main
!    implicit real*4(a-h, o-z) ! The pppack is in single precision
!    real tau(201), c(4, 201)
!    f(x) = exp(x) * cos(2*x)
!    fderiv(x) = exp(x) * (cos(2*x) - 2 * sin(2*x))
!    ibcbeg = 2 ! Natural Cubic Spline
!    ibcend = 2
!    a = 0. ! Starting point
!    b = 2.0 ! End point
!    write(*,*) '-- Enter Number of SubIntervals --'
!    read(*,*) N
!    h = (b-a)/N ! h is the length of the subinterval
!    do i = 1, N+1
!        tau(i) = a + (i-1)*h
!        c(1, i) = f(tau(i))
!    enddo
!    c(2,1) = 0. ! Natural Cubic Spline
!    c(2,N+1) = 0. ! Natural Cubic Spline
!    call cubspl(tau, c, N, ibcbeg, ibcend)
!    ! Using the coefficient computed above, we actually
!    ! evaluate function values
!    ! at mid-points and compare with the exact values.
!    k = 4
!    jderiv = 0 ! Compute the 0-th derivative, i.e,
!    ! The function values.
!    do i= 1, N-1
!        x = a + (i+0.5)*h ! At the mid-point of the subintervals.
!        y = f(x) ! The Exact Value
!        y2 = ppvalu(tau, c, N, k, x, jderiv) ! Cubic Spline Value
!        write(*,*)' Value at x = ', x, y, y2
!    enddo
!    write(*,*) ' -- Derivatives --'
!    k = 4
!    jderiv = 1 ! Compute the 1-th derivative, i.e,
!    ! The first-derivative values.
!    do i= 1, N-1
!        x = a + (i+0.5)*h ! At the mid-point of the subintervals.
!        y = fderiv(x) ! The Exact Value
!        y2 = ppvalu(tau, c, N, k, x, jderiv) ! Cubic Spline Value
!        write(*,*)' Value at x = ', x, y, y2
!    enddo
!    stop
!end program main

program main
    !====================================================================
    ! Spline interpolation
    ! Comments: values of function f(x) are calculated in n base points
    ! then: spline coefficients are computed
    !       spline interpolation is computed in 2n-1 points,
    !       a difference sum|f(u)-ispline(u)|
    !====================================================================
    implicit none
    integer, parameter :: n=11      ! base points for interpolation
    integer, parameter :: nint=11   ! compute interpolation in nint points
    double precision xmin, xmax     ! given interval of x()
    double precision, dimension (n) :: xi(n), yi(n), b(n), c(n), d(n)
    double precision x, y, step, ys, error, errav
    integer i
    double precision f, ispline

    ! open files
    !open (unit=1, file='tablex1.dat')
    !open (unit=2, file='tablex2.dat')

    xmin = 0.0
    xmax = 2.0

    ! step 1: generate xi and yi from f(x), xmin, xmax, n
    step = (xmax-xmin)/(n-1)
    do i=1,n
        xi(i) = xmin + step*float(i-1)
        yi(i) = f(xi(i))
        !  write (*,200) xi(i), yi(i)
    end do

    !  step 2: call spline to calculate spline coeficients
    call spline (xi, yi, b, c, d,n)

    !  step 3: interpolation at nint points
    errav = 0.0
    step = (xmax-xmin)/(nint-1)
    write(*,201)
    do i=1, nint
        x = xmin + step*float(i-1)
        y = f(x)
        ys = ispline(x, xi, yi, b, c, d, n)
        error = ys-y
        write (*,200) x, ys, error
        ! step 4: calculate quality of interpolation
        errav = errav + abs(y-ys)/nint
    end do
    write (*,202) errav
    200 format (3f12.5)
    201 format ('        x        spline      error')
    202 format ('           Average error',f12.5)

end program main

!
!  Function f(x)
!
function f(x)
    double precision f, x
    f = exp(x) * cos(2*x)
end function f

subroutine spline (x, y, b, c, d, n)
    !======================================================================
    !  Calculate the coefficients b(i), c(i), and d(i), i=1,2,...,n
    !  for cubic spline interpolation
    !  s(x) = y(i) + b(i)*(x-x(i)) + c(i)*(x-x(i))**2 + d(i)*(x-x(i))**3
    !  for  x(i) <= x <= x(i+1)
    !  Alex G: January 2010
    !----------------------------------------------------------------------
    !  input..
    !  x = the arrays of data abscissas (in strictly increasing order)
    !  y = the arrays of data ordinates
    !  n = size of the arrays xi() and yi() (n>=2)
    !  output..
    !  b, c, d  = arrays of spline coefficients
    !  comments ...
    !  spline.f90 program is based on fortran version of program spline.f
    !  the accompanying function fspline can be used for interpolation
    !======================================================================
    implicit none
    integer n
    double precision x(n), y(n), b(n), c(n), d(n)
    integer i, j, gap
    double precision h

    gap = n-1
    ! check input
    if ( n < 2 ) return
    if ( n < 3 ) then
        b(1) = (y(2)-y(1))/(x(2)-x(1))   ! linear interpolation
        c(1) = 0.
        d(1) = 0.
        b(2) = b(1)
        c(2) = 0.
        d(2) = 0.
        return
    end if
    !
    ! step 1: preparation
    !
    d(1) = x(2) - x(1)
    c(2) = (y(2) - y(1))/d(1)
    do i = 2, gap
        d(i) = x(i+1) - x(i)np.array
        b(i) = 2.0*(d(i-1) + d(i))
        c(i+1) = (y(i+1) - y(i))/d(i)
        c(i) = c(i+1) - c(i)
    end donp.array
    !
    ! step 2: end conditions
    !
    b(1) = -d(1)
    b(n) = -d(n-1)
    c(1) = 0.0
    c(n) = 0.0
    if(n /= 3) then
        c(1) = c(3)/(x(4)-x(2)) - c(2)/(x(3)-x(1))
        c(n) = c(n-1)/(x(n)-x(n-2)) - c(n-2)/(x(n-1)-x(n-3))
        c(1) = c(1)*d(1)**2/(x(4)-x(1))
        c(n) = -c(n)*d(n-1)**2/(x(n)-x(n-3))
    end if
    !
    ! step 3: forward elimination
    !
    do i = 2, n
        h = d(i-1)/b(i-1)
        b(i) = b(i) - h*d(i-1)
        c(i) = c(i) - h*c(i-1)
    end do
    !
    ! step 4: back substitution
    !
    c(n) = c(n)/b(n)
    do j = 1, gap
        i = n-j
        c(i) = (c(i) - d(i)*c(i+1))/b(i)
    end do
    !
    ! step 5: compute spline coefficients
    !
    b(n) = (y(n) - y(gap))/d(gap) + d(gap)*(c(gap) + 2.0*c(n))
    do i = 1, gap
        b(i) = (y(i+1) - y(i))/d(i) - d(i)*(c(i+1) + 2.0*c(i))
        d(i) = (c(i+1) - c(i))/d(i)
        c(i) = 3.*c(i)
    end do
    c(n) = 3.0*c(n)
    d(n) = d(n-1)
end subroutine spline

function ispline(u, x, y, b, c, d, n)
    !======================================================================
    ! function ispline evaluates the cubic spline interpolation at point z
    ! ispline = y(i)+b(i)*(u-x(i))+c(i)*(u-x(i))**2+d(i)*(u-x(i))**3
    ! where  x(i) <= u <= x(i+1)
    !----------------------------------------------------------------------
    ! input..
    ! u       = the abscissa at which the spline is to be evaluated
    ! x, y    = the arrays of given data points
    ! b, c, d = arrays of spline coefficients computed by spline
    ! n       = the number of data points
    ! output:
    ! ispline = interpolated value at point u
    !=======================================================================
    implicit none
    double precision ispline
    integer n
    double precision  u, x(n), y(n), b(n), c(n), d(n)
    integer i, j, k
    double precision dx

    ! if u is ouside the x() interval take a boundary value (left or right)
    if(u <= x(1)) then
        ispline = y(1)
        return
    end if
    if(u >= x(n)) then
        ispline = y(n)
        return
    end if

    !*
    !  binary search for for i, such that x(i) <= u <= x(i+1)
    !*
    i = 1
    j = n+1
    do while (j > i+1)
        k = (i+j)/2
        if(u < x(k)) then
            j=k
        else
            i=k
        end if
    end do
    !*
    !  evaluate spline interpolation
    !*
    dx = u - x(i)
    ispline = y(i) + dx*(b(i) + dx*(c(i) + dx*d(i)))
end function ispline


!    File:    PrimeNumberModule.f90
!    Author:  Marvin Smith
!    Date:    4/25/2015
!
!    Purpose:  Contains Prime Number Utilities.
!
MODULE PrimeNumberModule

!  Define Everything As Public
PUBLIC

!  List of Procedures in the PrimeNumber Module
CONTAINS

!  Find the Number of Primes below a given value
FUNCTION Find_Number_Primes_Below_Value (max_value) result (Pmax)
    integer, intent(in) :: max_value
    integer :: Pmax

!  Iterate over range, looking for primes

END FUNCTION

!  Find the List of Primes Below a Number
FUNCTION Prime_Sieve( max_value ) result ( prime_list )
    integer max_value, i,j,start_j
    logical, allocatable, dimension(:) :: prime_list

!  Allocate Memory
allocate( prime_list(2:max_value))

!  Initialize the array
prime_list(2:max_value) = (/(.TRUE., i=2,max_value)/)

!  Start the sieve
do i=2,max_value
    do j = (i+i), max_value, i
        prime_list(j) = .FALSE.
    end do
end do

END FUNCTION

!  End of the Module
END MODULE PrimeNumberModule


      module interpolation
      contains
      ! From Numerical Recipes Chapter 3 - Interpolation and Extrapolation - polint
      ! Polynomial Interpolation using Nevilles algorithm.
      !ms: f90tified it, +implicit none, +intent(*)
      !   Given arrays xa and ya, each of length n, and
      !   given a value x, this routine returns a value y, and
      !   an error estimate dy. If P (x) is the polynomial of
      !   degree N − 1 such that P (xai ) = yai ,
      !   i = 1, . . . , n, then the returned value y = P (x).
      SUBROUTINE polint(xa,ya,x,y,dy)
      implicit none
      !integer,intent(in) :: n
      real*8,intent(in)  :: x,xa(:),ya(:)
      real*8,intent(out) :: dy,y
      !integer,parameter  :: NMAX=10 ! Largest anticipated value of n.
      integer :: i,m,ns,n
      real*8 :: den,dif,dift,ho,hp,w,c(size(xa)),d(size(xa))
      ns=1
      n=size(xa)
      dif=abs(x-xa(1))
      do i=1,n                !  Here we ﬁnd the index ns of the closest table entry,
          dift=abs(x-xa(i))
          if (dift.lt.dif) then
                ns=i
                dif=dift
          endif
          c(i)=ya(i)             !  and initialize the tableau of c’s and d’s.
          d(i)=ya(i)
      enddo
      y=ya(ns)                    !  This is the initial approximation to y.
      ns=ns-1
      L13:do m=1,n-1              !  For each column of the tableau,
          do i=1,n-m         !  we loop over the current c’s and d’s and update them.
                ho=xa(i)-x
                hp=xa(i+m)-x
                w=c(i+1)-d(i)
                den=ho-hp
                !  This error can occur only if two input xa’s are (to within roundoff) identical.
                if(den.eq.0.) stop 'polint: failure: xa not unique'
                den=w/den
                d(i)=hp*den           !  Here the c’s and d’s are updated.
                c(i)=ho*den
          enddo
          if (2*ns.lt.n-m)then   ! After each column in the tableau is completed, we decide
                dy=c(ns+1)        !  which correction, c or d, we want to add to our accu-
          else                   !  mulating value of y, i.e., which path to take through
                dy=d(ns)          !  the tableau—forking up or down. We do this in such a
                ns=ns-1           !  way as to take the most “straight line” route through the
          endif                  !  tableau to its apex, updating ns accordingly to keep track
          y=y+dy                 !  of where we are. This route keeps the partial approxima-
      enddo L13                   !  tions centered (insofar as possible) on the target x. The
      return                      !  last dy added is thus the error indication.
      END SUBROUTINE POLINT

      FUNCTION POLINT_F(xa,ya,x) result(y)
      real*8,intent(in) :: xa(:),ya(:),x
      real*8 :: y,dy
      call polint(xa,ya,x,y,dy)

      END FUNCTION
      end module

      !PROGRAM MAIN
      !   use interpolate
      !   integer,parameter :: n=3
      !   real*8 :: xa(n),ya(n),x,y,dy
      !   do i=1,n
      !     xa(i)=i;
      !   enddo
      !   ya(1)=1; ya(2)=4; ya(3)=9; ya(4)=16;
      !
      !   x=2.0; call polint(xa,ya,n,x,y,dy);  print *,x,y,dy
      !   x=3.0; call polint(xa,ya,n,x,y,dy);  print *,x,y,dy
      !   x=2.1; call polint(xa,ya,n,x,y,dy);  print *,x,y,dy
      !   x=2.2; call polint(xa,ya,n,x,y,dy);  print *,x,y,dy
      !   x=2.3; call polint(xa,ya,n,x,y,dy);  print *,x,y,dy
      !   x=2.4; call polint(xa,ya,n,x,y,dy);  print *,x,y,dy
      !   x=2.5; call polint(xa,ya,n,x,y,dy);  print *,x,y,dy
      !end PROGRAM


module ode
  use nrtype
  implicit none
contains
  subroutine rk4g(derivs, x, yi, yf, h)
    !=========================================================!
    ! Solve n first-order ODEs or n/2 second-order.           !
    ! Runge-Kutta 4 Gill's method                             !
    ! Daniel Celis Garza 24 Sept. 2015                        !
    !---------------------------------------------------------!
    ! f(x,y,dydx) = ODEs to be solved                         !
    ! Let n := size(y) then for a k'th order system           !
    ! y(1+i*n/k:(i+1)*n/k) := i'th order derivative           !
    !---------------------------------------------------------!
    ! Inputs:                                                 !
    ! derivs = derivatives                                    !
    ! h      = step size                                      !
    ! x      = independent variable @ step i                  !
    ! yi()   = array of dependent variables @ step i          !
    !---------------------------------------------------------!
    ! Outputs:                                                !
    ! yf() = array of dependent variables @ step i+1          !
    !---------------------------------------------------------!
    ! Locals:                                                 !
    ! ys() = array of dependent variables @ stage s of step i !
    ! ki() = array of Runge-Kutta k/h                         !
    ! ho2  = h/2                                              !
    ! ci   = Butcher table parameters                         !
    !=========================================================!
    implicit none
    real(dp), intent(in)          :: x, h, yi(:)
    real(dp), intent(out)         :: yf(:)
    real(dp), dimension(size(yi)) :: k1, k2, k3, k4, ys
    real(dp)                      :: ho2, c1, c2, c3, c4, c5, c6, c7
    parameter ( c1 = sqrt(2.0_dp), c2 = -0.5_dp * c1, c3 = 2.0_dp - c1, &
               c4 = 2.0_dp + c1, c5 = c2 - 0.5_dp, c6 = 0.5_dp * c3, &
               c7 = 0.5_dp * c4 )
    interface derivatives
      subroutine derivs(x, y, dydx)
        use nrtype
        implicit none
        real(dp), intent(in)  :: x, y(:)
        real(dp), intent(out) :: dydx(:)
      end subroutine derivs
    end interface derivatives

    ho2 = 0.5_dp * h

    ! Calculate k1.
    call derivs(x, yi, k1) ! Call the derivatives.
    ys = yi + ho2 * k1     ! Go through all equations and prepare for the next stage.

    ! Calculate k2.
    call derivs(x + ho2, ys, k2)
    ys = yi + h*(c5 * k1 + c6 * k2)

    ! Calculate k3.
    call derivs(x + ho2, ys, k3)
    ys = yi + h * (c2 * k2 + c7 * k3)

    ! Calculate k4 and yf.
    call derivs(x + h, ys, k4)
    yf  = yi + h*(k1 + c3 * k2 + c4 * k3 + k4) / 6.0_dp
  end subroutine rk4g

  subroutine rkck(derivs, x, yi, yf, er, h)
    !=========================================================!
    ! Solve n first-order ODEs or n/2 second-order.           !
    ! Cash-Karp RK45                                          !
    ! Daniel Celis Garza 24 Sept. 2015                        !
    !---------------------------------------------------------!
    ! f(x,y,dydx) = ODEs to be solved                         !
    ! Let n := size(y) then for a k'th order system           !
    ! y(1+i*n/k:(i+1)*n/k) := i'th order derivative           !
    !---------------------------------------------------------!
    ! Inputs:                                                 !
    ! derivs = derivatives                                    !
    ! h      = step size                                      !
    ! x      = independent variable @ step i                  !
    ! yi()   = array of dependent variables @ step i          !
    !---------------------------------------------------------!
    ! Outputs:                                                !
    ! yf() = array of dependent variables @ step i+1          !
    ! er() = array of integration errors                      !
    !---------------------------------------------------------!
    ! Locals:                                                 !
    ! ys() = array of dependent variables @ stage s of step i !
    ! ki() = array of Runge-Kutta k/h                         !
    ! ci   = Butcher Table c-vector                           !
    ! aij  = Butcher Table A-matrix                           !
    ! bi   = Butcher Table b-vector                           !
    ! dbi  = b-b* vector difference for error calculation     !
    !=========================================================!
    implicit none
    real(dp), intent(in)          :: x, yi(:), h
    real(dp), intent(out)         :: yf(:), er(:)
    real(dp), dimension(size(yi)) :: k1, k2, k3, k4, k5, k6, ys
    real(dp)                      :: c2, c3, c4, c5, c6, a21, a31, a32, a41, &
                                     a42, a43, a51, a52, a53, a54, a61, a62, &
                                     a63, a64, a65, b1, b3, b4, b6, db1, db3, &
                                     db4, db5, db6
    parameter ( c2 = .2_dp, c3 = .3_dp, c4 = .6_dp, c5 = 1._dp, c6 = .875_dp, &
                a21 = .2_dp, a31 = .075_dp, a32 = .225_dp, &
                a41 = .3_dp, a42 = -.9_dp, a43 = 1.2_dp, &
                a51 = -11._dp / 54._dp, a52 = 2.5_dp, a53 = -70._dp / 27._dp, &
                a54 = 35._dp / 27._dp, a61 = 1631._dp / 55296._dp, &
                a62 = 175._dp / 512._dp, a63 = 575._dp / 13824._dp, &
                a64 = 44275. / 110592._dp, a65 = 253. / 4096._dp, &
                b1 = 37._dp / 378._dp, b3 = 250._dp / 621._dp, &
                b4 = 125._dp / 594._dp, b6 = 512._dp / 1771._dp, &
                db1 = b1-2825._dp / 27648._dp, &
                db3 = b3 - 18575._dp / 48384._dp, &
                db4 = b4 - 13525._dp / 55296._dp, &
                db5 = -277._dp / 14336._dp, &
                db6 = b6 - 0.25_dp )
    interface derivatives
      subroutine derivs(x, y, dydx)
        use nrtype
        implicit none
        real(dp), intent(in)  :: x, y(:)
        real(dp), intent(out) :: dydx(:)
      end subroutine derivs
    end interface derivatives

    ! Calculate k1.
    call derivs(x, yi, k1)
    ys = yi + h * a21 * k1

    ! Calculate k2.
    call derivs(x + c2 * h, ys, k2)
    ys = yi + h * (a31 * k1 + a32 * k2)

    ! Calculate k3.
    call derivs(x + c3 * h, ys, k3)
    ys = yi + h * (a41 * k1 + a42 * k2 + a43 * k3)

    ! Calculate k4.
    call derivs(x + c4 * h, ys, k4)
    ys = yi + h * (a51 * k1 + a52 * k2 + a53 * k3 + a54 * k4)

    ! Calculate k5.
    call derivs(x + c5 * h, ys, k5)
    ys = yi + h * (a61 * k1 + a62 * k2 + a63 * k3 + a64 * k4 + a65 * k5)

    ! Calculate k6.
    call derivs(x + c6 * h, ys, k6)
    yf = yi + h * (b1 * k1 + b3 * k3 + b4 * k4 + b6 * k6)

    ! Calculate error.
    er = db1 * k1 + db3 * k3 + db4 * k4 + db5 * k5 + db6 * k6
  end subroutine rkck

  subroutine rkcka(derivs, x, y, der, h, hmin)
    !============================================================!
    ! Adaptive-step Cash-Karp RK45                               !
    ! Daniel Celis Garza 24 Sept. 2015                           !
    !------------------------------------------------------------!
    ! f(x,y,dydx) = ODEs to be solved                            !
    ! Let n := size(y) then for a k'th order system              !
    ! y(1+i*n/k:(i+1)*n/k) := i'th order derivative              !
    !------------------------------------------------------------!
    ! Inputs:                                                    !
    ! derivs = derivatives                                       !
    ! der    = desired error                                     !
    !------------------------------------------------------------!
    ! Inputs-Outputs:                                            !
    ! h   = current step size                                    !
    ! x   = independent variable                                 !
    ! y() = array of dependent variables                         !
    !------------------------------------------------------------!
    ! Locals:                                                    !
    ! loc_der = local desired error                              !
    ! ht      = trial step size                                  !
    ! hn      = new step size                                    !
    ! dydx()  = array of derivatives                             !
    ! tiny    = prevent division by zero                         !
    ! s       = safety factor for changing h                     !
    ! shrink  = (-1/(p-1)) where p is the error's order          !
    ! grow    = (-1/p) where p is the error's order              !
    ! ercor   = (5/s)**(1/grow), know when to increase h greatly !
    ! yscal() = scaling the error to the function's range        !
    !============================================================!
    implicit none
    real(dp), intent(inout)      :: x, y(:), h
    real(dp), intent(in)         :: der, hmin
    real(dp), dimension(size(y)) :: yn, yscal, dydx, er
    real(dp)                     :: loc_der, ht, hn, maxer, tiny, &
                                    s, shrink, grow, ercor
    parameter ( tiny = 1.d-30, s = 0.9_dp, shrink = -0.25_dp, &
                grow = -0.2_dp, ercor = 1.89d-4 )
    interface derivatives
      subroutine derivs(x, y, dydx)
        use nrtype
        implicit none
        real(dp), intent(in)  :: x, y(:)
        real(dp), intent(out) :: dydx(:)
      end subroutine derivs
    end interface derivatives

    ! Local error for numeric underflow prevention.
    loc_der = der
    call derivs(x, y, dydx)
    yscal = abs( y ) + abs( h * dydx ) + tiny
    ! When global errors are a concern use:
    ! yscal(:) = abs( h * dydx ) + tiny

    ! Integrate and Adjust H (IAH).
    IAH: do
      call rkck(derivs, x, y, yn, er, h)
      ! Calculate the adjusted maximum error.
      maxer = maxval( abs( er / yscal ) ) / loc_der
      ! If the maximum adjusted error is sufficiently small, exit loop.
      if (maxer <= 1._dp) exit IAH
      ! If the maximum error is too big then shrink the step size.
      ht = s * h * maxer ** shrink
      ! Prevent jumps of more than an order of magnitude.
      h = sign( max( abs( ht ), 0.1_dp * abs( h ) ), h)
      ! Prevent Numerical Underflow (PNU).
      PNU: if (abs( h ) < hmin .or. x + h == x) then
        ! This means that the error is so strict h is effectively zero,
        ! so the program enters an infinite loop.
        ! Increasing h to the minimum value.
        h = hmin
        ! By locally increasing the desired error, we further prevent the infinite loop.
        ! The error goes back to normal for the next integration step.
        loc_der = loc_der + der
      end if PNU
    end do IAH

    ! Check size of the maximum error.
    if (maxer > ercor) then
      ! If the maximum error is greater than an error parameter, increase it slightly.
      hn = s * h * maxer ** grow
    else
      ! Else, increase it greatly.
      hn = 5. * h
    end if

    ! Prevent numeric underflow.
    if(abs( hn ) < abs( hmin )) hn = hmin

    ! Updating for the next step.
    x = x + h ! Taking a step.
    h = hn    ! Setting the next step length.
    y = yn    ! Setting all the dependent variables to their new starting points.
  end subroutine rkcka

  subroutine basic_verlet(derivs, x, yi, yf, h)
    !============================================================!
    ! Basic Verlet Integrator (2nd order equations)              !
    ! Daniel Celis Garza 2nd Feb. 2016                           !
    ! This works best with constant acceleration.                !
    !------------------------------------------------------------!
    ! f(x,y,dy) = ODEs to be solved                              !
    ! y         = positions                                      !
    !------------------------------------------------------------!
    ! Inputs:                                                    !
    ! derivs = derivatives                                       !
    ! h      = step size                                         !
    ! x      = independent variable                              !
    !------------------------------------------------------------!
    ! Inputs-Outputs:                                            !
    ! yi() = array of dependent variables @ step i               !
    ! yf() = array of dependent variables @ step i+1             !
    !------------------------------------------------------------!
    ! Locals:                                                    !
    ! dxdy() = array of derivatives                              !
    ! ys()   = array of dependent variables for storage purposes !
    !============================================================!
    implicit none
    real(dp), intent(in)          :: x, h
    real(dp), intent(inout)       :: yi(:), yf(:)
    real(dp), dimension(size(yi)) :: dydx, ys
    real(dp)                      :: h2
    interface derivatives
      subroutine derivs(x, y, dydx)
        use nrtype
        implicit none
        real(dp), intent(in)  :: x, y(:)
        real(dp), intent(out) :: dydx(:)
      end subroutine derivs
    end interface derivatives

    ! Calculate h^2.
    h2 = h * h
    ! Save current values of y.
    ys = yf
    call derivs(x, yf, dydx)
    ! Calculate the next step.
    yf = 2. * yf - yi + dydx * h2
    yi = ys
  end subroutine basic_verlet

  subroutine velocity_verlet(derivs,x,yi,yf,h)
    !==================================================!
    ! Velocity Verlet Integrator (2nd order equations) !
    ! Daniel Celis Garza 2nd Feb. 2016                 !
    !--------------------------------------------------!
    ! f(x,y,dy) = ODEs to be solved                    !
    ! Let n := size(y), then y(1:n/2) := velocities    !
    ! and y(n/2+1:n) := accelerations                  !
    !--------------------------------------------------!
    ! Inputs:                                          !
    ! derivs = derivatives                             !
    ! h      = step size                               !
    ! x      = independent variable                    !
    ! yi() = array of dependent variables @ step i     !
    !--------------------------------------------------!
    ! Outputs:                                         !
    ! yf() = array of dependent variables @ step i+1   !
    !--------------------------------------------------!
    ! Locals:                                          !
    ! dxdy() = array of derivatives                    !
    !==================================================!
    implicit none
    real(dp), intent(in)            :: x, h, yi(:)
    real(dp), intent(out)           :: yf(:)
    integer                         :: n_coords, n_derivs
    real(dp), dimension(size(yi)/2) :: dydx, dydxs
    real(dp)                        :: h2
    interface derivatives
      subroutine derivs(x,y,dydx)
        use nrtype
        implicit none
        real(dp), intent(in)  :: x, y(:)
        real(dp), intent(out) :: dydx(:)
      end subroutine derivs
    end interface derivatives

    n_coords = size(yi) / 2
    n_derivs = size(yi)
    h2 = h*h

    ! Calculating a(t) from -\nabla V(x(t+dt)) = F = m*a.
    call derivs(x, yi, dydx)

    ! Save the acceleration for the current step.
    dydxs = dydx

    ! Calculating x(t+dt)
    ! x(t+dt) = x(t) + v(t)*dt + 0.5*a(t)*dt^2
    yf(1: n_coords) = yi(1: n_coords) + yi(n_coords + 1: n_derivs) * h + 0.5_dp * dydx * h2

    ! Calculating a(t+dt) from -\nabla V(x(t+dt)) = F = m*a.
    call derivs(x, yf, dydx)

    ! Calculating v(t+dt)
    ! v(t+dt) = v(t) + 0.5*(a(t) + a(t+dt))*dt
    yf(n_coords + 1: n_derivs) = yi(n_coords + 1 : n_derivs) + 0.5_dp * (dydxs + dydx) * h

  end subroutine velocity_verlet
end module ode


PROGRAM F010

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER, PARAMETER :: N = 2E+6
    INTEGER :: I, J
    INTEGER (KIND=8) :: PRIMES_SUM
    LOGICAL, DIMENSION(N+1) :: INTEGERS_LIST

    ! USING THE ALGORITHM OF SIEVE OF EROSTHENES
    INTEGERS_LIST = .TRUE.
    I = 2
    DO WHILE ((I*I) <= N)
        IF (INTEGERS_LIST(I)) THEN
            J = I * I
            DO WHILE (J <= N)
                INTEGERS_LIST(J) = .FALSE.
                J = J + I
            END DO
        END IF
        I = I + 1
    END DO
    PRIMES_SUM = 0
    DO I = 2, N
        IF (INTEGERS_LIST(I)) THEN
            PRIMES_SUM = PRIMES_SUM + I
        END IF
    END DO

    PRINT ('(I0)'), PRIMES_SUM

END PROGRAM F010


! Explanation of constants and variables used in this program:
!   DARTS               = number of throws at dartboard
!   ROUNDS              = number of times "DARTS" is iterated
!   pi                  = average of pi for this iteration
!   avepi               = average pi value for all iterations
!
program pi_calc

  integer, parameter :: DARTS = 100000
  integer, parameter :: ROUNDS = 10000
  double precision, parameter :: realpi=3.1415926535897
  real ::     seednum
  double precision ::     pi, avepi

  print *, 'Starting serial version of pi calculation...'

  avepi = 0
  do i = 1, ROUNDS
     pi = dboard(DARTS)
     avepi = ((avepi*(i-1)) + pi)/ i
     write(*,32) DARTS*i, avepi
  end do

  print *, ' '
  print *,'Error:', abs(avepi-realpi)/realpi
  print *, ' '

32 format('   After',i8,' throws, average value of pi = ', &
       &           f10.8,$)

contains

  ! Explanation of constants and variables used in this function:
  !   darts       = number of throws at dartboard
  !   score       = number of darts that hit circle
  !   n           = index variable
  !   r           = random number between 0 and 1
  !   x_coord     = x coordinate, between -1 and 1
  !   x_sqr       = square of x coordinate
  !   y_coord     = y coordinate, between -1 and 1
  !   y_sqr       = square of y coordinate
  !   pi          = computed value of pi

  real function dboard(darts)

    integer :: darts, score, n
    real ::   r
    double precision ::  x_coord, x_sqr, y_coord, y_sqr, pi

    score = 0

    !  Throw darts at board.  Done by generating random numbers
    !  between 0 and 1 and converting them to values for x and y
    !  coordinates and then testing to see if they "land" in
    !  the circle."  If so, score is incremented.  After throwing the
    !  specified number of darts, pi is calculated.  The computed value
    !  of pi is returned as the value of this function, dboard.
    !  Note:  the seed value for rand() is set in pi_calc.

    !    Note: Requires Fortran90 compiler due to random_number() function
    print *, ' '
    do n = 1, darts
       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

       if ((x_sqr + y_sqr) .le. 1.0) then
          score = score + 1
       endif
    end do
    pi = 4.0 * score / darts
    dboard = pi
  end function dboard

end program pi_calc


FUNCTION determinant(jac)RESULT(det)
!
! This function returns the determinant of a 1x1, 2x2 or 3x3
! Jacobian matrix.
!
 IMPLICIT NONE
 !SELECTED_REAL_KIND: https://gcc.gnu.org/onlinedocs/gcc-7.1.0/gfortran/SELECTED_005fREAL_005fKIND.html#SELECTED_005fREAL_005fKIND
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::jac(:,:)
 REAL(iwp)::det
 INTEGER::it
 it=UBOUND(jac,1)
 SELECT CASE(it)
 CASE(1)
   det=1.0_iwp
 CASE(2)
   det=jac(1,1)*jac(2,2)-jac(1,2)*jac(2,1)
 CASE(3)
!rank = 3
   det=jac(1,1)*(jac(2,2)*jac(3,3)-jac(3,2)*jac(2,3))
   det=det-jac(1,2)*(jac(2,1)*jac(3,3)-jac(3,1)*jac(2,3))
   det=det+jac(1,3)*(jac(2,1)*jac(3,2)-jac(3,1)*jac(2,2))
 CASE DEFAULT
   WRITE(*,*)' wrong dimension for Jacobian matrix'
 END SELECT
RETURN
END FUNCTION determinant


REAL FUNCTION sinc(x)
IMPLICIT NONE
  REAL, INTENT(IN) :: x
  REAL, PARAMETER :: EPSILON = 1.0E-30
  IF (ABS(x) > EPSILON) THEN
    sinc = SIN(x) / x
  ELSE
    sinc = 1
  END IF
END FUNCTION sinc

PROGRAM test_sinc
IMPLICIT NONE
  REAL :: x, sinc
  INTEGER :: i, num_results, offset, adj

  WRITE(*, *) "We will calculate sinc over a range of positive and negative values."
  WRITE(*, *) "How many results would you like to see?"
  READ(*, *) num_results

  offset = num_results / 2
  IF (MOD(num_results, 2) .eq. 0) THEN
    adj = 0
  ELSE
    adj = 1
  END IF

  DO i = 1, num_results
    WRITE(*, '(F9.6)') sinc(REAL(i - adj - offset))
  END DO
  !WRITE(*, 100) "sinc(", x, ") = ", sinc(x)
  !100 FORMAT (A, F12.6, A, F12.6)
END PROGRAM test_sinc


module factorial_module
    implicit none

    contains
    recursive integer function factorial(i) result(answer)
        implicit none

        integer, intent(in) :: i

        if (i==0) then
            answer = 1
        else
            answer = i*factorial(i-1)
        end if
    end function
end module

program ch1208
    ! Recursive Factorial Evaluation
    use factorial_module
    implicit none

    integer :: i, f

    print *, 'type in the number, integer only'
    read *, i
    do while (i<0)
        print *, 'positive integer respected: re-input'
        read *, i
    end do
    f = factorial(i)
    print *, 'answer is ', f
end program


MODULE precision
    ! dp = double precision
    INTEGER, PARAMETER:: dp = SELECTED_REAL_KIND(12)
END MODULE precision

PROGRAM Secant_Method
    USE precision
    IMPLICIT NONE

    REAL(KIND = dp):: x1, x2, x3, f1, f2, f3, error, root
    WRITE(*, *) "Enter value of 2 initial point "
    ! For this question enter 2 initial point x1 and x2
    READ(*, *) x1, x2

    error = 1e-6
    f1 = Functn(x1)
    f2 = Functn(x2)

    DO
        x3 = (f2*x1 - f1*x2) / (f2 - f1)
        f3 = Functn(x3)
        IF (f3 .EQ. 0.0) THEN
            root = x3
            WRITE(*, *) "Root is: ", root
            RETURN
        ENDIF

        IF (abs((x3 - x2)/x3) .LT. error) THEN
            root = x3
            WRITE(*, *) "Root is: ", root
            RETURN
        ELSE
            x1 = x2
            f1 = f2
            x2 = x3
            f2 = f3
        ENDIF
    ENDDO

    CONTAINS
    REAL(KIND = dp) FUNCTION Functn(x)
        USE precision
        IMPLICIT NONE
        REAL(KIND = dp):: x, rho
        rho = 4.0_dp
        Functn = x*tan(x) - sqrt(rho**2 - x ** 2)
        RETURN
    END FUNCTION Functn

END PROGRAM Secant_Method


!\file mbd_helper_dev.f90
!\author M. Sadhukhan
module mbd_helper_dev

use mbd_interface, only: pi

contains

recursive function legendre(n, x)result(res)
! Provides P_n(x)
implicit none
integer, intent(in):: n
double precision, intent(in) :: x
double precision :: res
integer :: i

if (n == 0) then
 res = 1.d0
else if (n == 1) then
 res = x
else
 res = ((2.d0*n-1.d0)*x*legendre(n-1, x)-(n-1)*legendre(n-2, x))/(n*1.d0)
end if
!
end function legendre
!
recursive function derivlegendre(n, x)result(res)
! Provides first derivative of P_n(x) wrt x
implicit none
integer, intent(in):: n
double precision, intent(in) :: x
double precision :: res
integer :: i

if (n == 0) then
res = 0.d0
else if (n == 1) then
res = 1.d0
else
res = ((2.d0*n-1.d0)*legendre(n-1, x)+ (2.d0*n-1.d0)*x*derivlegendre(n-1, x)-(n-1)*derivlegendre(n-2, x))/(n*1.d0)
end if
!
end function derivlegendre
!
subroutine gl_points(n, x, w)
implicit none
! provides Gauss-Legendre abcissa and weights
integer, parameter ::  m = 10
integer, intent(in) :: n
double precision, dimension(n), intent(out) :: x, w
integer :: i
do i = 1, n
 x(i) = root_Legendre(n, i)
 w(i) = 2.d0/((1.d0-x(i)**2)*(derivlegendre(n,x(i)))**2)
end do
end subroutine gl_points
!
function root_Legendre(n, k)result(res)
! provides the kth root for P_n(n)
implicit none
double precision, parameter :: lim_err=1.d-12
integer, intent(in) :: n, k
double precision :: err, res,root_guess_l,root_guess_u, x

err = 1.d0
! guess from A&S 22.16.6
root_guess_l= cos(pi*(2*k-1)/(2.d0*n+1))
root_guess_u= cos((pi*2*k)/(2.d0*n+1))
! Newton-Raphson
x =root_guess_u
!print*, "Guess", x
do while (err >= dabs(lim_err))
!print*, "P = ",legendre(n, x),"P' = ",derivlegendre(n, x)
x = x - legendre(n, x)/derivlegendre(n, x)
!Print*, "err = ", abs(legendre(n, x))
err =abs(legendre(n, x))
end do
!
res = x
end function root_Legendre
integer recursive function factorial(n)result(res)
implicit none
integer :: n

if (n == 0)then
 res = 1
else
 res= n*factorial(n-1)
end if
end function factorial

subroutine diag_double(vector, matrix)
! provides matrix with the diagonal containing vector
! suitable for double precision
implicit none
integer :: i
double precision, dimension(:), intent(in) :: vector
double precision, dimension(size(vector), size(vector)), intent(out):: matrix
matrix = 0.d0

do i = 1, size(vector)
 matrix(i,i) = vector(i)
end do
end subroutine diag_double
!
subroutine det(A, dt)
! provides determinant dt of matrix A
implicit none
integer :: n, info, i
double precision, dimension(:, :) :: A
double precision :: dt
integer, dimension(size(A, 1)) :: ipiv
dt = 1.d0
n = size(A, 1)
!do i = 1, n
!print*, A(i, :)
!end do
call dgetrf(n, n, A, n, ipiv, info)

!print*, "ipiv :", ipiv

if (info == 0)then
 do i = 1, n
   if(ipiv(i) == i)then
    dt = dt*A(i, i)
   else
    dt = -dt*A(i, i)
   end if
 end do
else
 print*, "dgertf did not exited sucessfully"
 print*, "info =", info
 stop
end if
!print*, "dt = ",dt
end subroutine det
!
function i_matrix(n) result(matrix)
! provides identity matrix of dimension n
implicit none
integer, intent(in) :: n
double precision, dimension(n, n) :: matrix
integer :: i
double precision, dimension(n) :: diag1
diag1 = 1.d0
call diag_double(diag1, matrix)
end function i_matrix
!
function matrix_combine( n, matA, matB)result(matAB)
implicit none
! combine two nxn matrices
integer, intent(in) ::  n
double precision, dimension(n, n), intent(in) :: matA, matB
double precision, dimension(2*n, n) :: matAB

matAB(1:n, :) = matA
matAB(n+1:2*n, : ) = matB
end function matrix_combine
!
function matrix_embed(n, matA, Bign, rpos, cpos)result(Bigmatrix)
implicit none
integer, intent(in) :: n, Bign, rpos, cpos
double precision, dimension(n, n), intent(in) :: matA
double precision, dimension(Bign, Bign) :: Bigmatrix
if (rpos+n-1 > Bign .or. cpos+n-1 > Bign) then
 print*, "Matrix sizes are not fit for embedding ... aborting execusion"
 stop
end if
Bigmatrix = 0.d0
Bigmatrix(rpos:, cpos:) =matA

end function matrix_embed
!
function Matrix_invert(A)result(Ainv)
! Provides matrix inversion of A
implicit none
double precision, dimension(:,:), intent(in) :: A
double precision, dimension(size(A, 1),size(A, 1)):: Ainv

integer :: n, info, i
integer, dimension(size(A,1)) :: ipiv
double precision, dimension(size(A,1)**2) :: work
ipiv= 1
work = 0.d0
n = size(A, 1)
Ainv = 0.d0
if (n>1)then
call DGETRI(n, A, n, ipiv, work, n**2, info)
if(info /=0)then
 print*, "Matrix inversion failed ... Aborting, info =", info
 stop
end if
 Ainv= A
else if (n == 1)then
 Ainv= A
end if

end function Matrix_invert
!
function repeat(n, number)result(vector)
implicit none
integer, intent(in) :: n
double precision,intent(in) :: number
double precision, dimension(n) :: vector
vector = number
end function repeat
!
function combine_vector(nA, vA, nB, vB)result(vAB)
implicit none
integer, intent(in) ::  nA, nB
double precision, dimension(na), intent(in) :: vA
double precision, dimension(nb), intent(in) :: vB
double precision, dimension(na+nb) :: vAB
vAB = 0.d0
vAB(1:na) = vA
vAB(na+1:nb+na) = vB
end function combine_vector

subroutine printmat(A, message)
implicit none
double precision, dimension(:, :), intent(in) :: A
character(len=*), optional :: message
character(len=20) :: fmt
integer :: i, n

if(present(message))print*, message
n = size(A, 1)
write (fmt, *) n
fmt = "(1x,"//trim(adjustl(fmt))//"f8.4)"
!print*, fmt
!stop
do i = 1, n
 write(*, trim(fmt)) A(i, :)
end do
end subroutine printmat

end module


Module MathFuncMod

contains
recursive Function factorial(n) result(f)
    implicit none
    integer :: n
    integer  (kind = 4) :: f
    if (n<0) then
      f=0
    else
      select case (n)
          case (0)
              f =  1
          case (1)
              f =  1
          case (2)
              f =  2
          case ( 3)
              f =  6
          case ( 4)
              f =  24
          case ( 5)
              f =  120
          case ( 6)
              f =  720
          case ( 7)
              f =  5040
          case ( 8)
              f =  40320
          case ( 9)
              f =  362880
          case ( 10)
              f =  3628800
          case ( 11)
              f =  39916800
          case ( 12)
              f =  479001600
          case default
              f =  n*factorial(n-1)
      end select
    endif
end function factorial

recursive Function doublefactorial(n)  result(f)
    integer, intent(in):: n
    integer  (kind = 4) :: f
    if (n<0) then
      f=0
      return
    else
      select case (n)
        case (0)
            f =  1
        case (1)
            f =  1
        case (2)
            f =  2
        case (3)
            f =  3
        case (4)
            f =  8
        case (5)
            f =  15
        case (6)
            f =  48
        case (7)
            f =  105
        case (8)
            f =  384
        case (9)
            f =  945
        case (10)
            f =  3840
        case (11)
            f =  10395
        case (12)
            f =  46080
        case (13)
            f =  135135
        case (14)
            f =  645120
        case (15)
            f =  2027025
        case (16)
            f =  10321920
        case (17)
            f =  34459425
        case (18)
            f =  185794560
        case default
            f =  n*doublefactorial(n-2)
      end select
    endif
end function doublefactorial

recursive Function binomial(n, m) result(f)
    implicit none
    integer :: n,m,ml
    integer  (kind = 4) :: f
    if (n<=0 .or. m>n .or. m<0) then
        f = 0;
        return
    endif

    if (m>n/2) then
      ml=n-m;
    else
      ml=m;
    endif

    select case (ml)
        case (0)
            f = 1
            return
        case (1)
            f = n
            return
        case (2)
            f = n*(n-1)/2
            return
        case (3)
            f = n*(n-1)*(n-2)/6
            return
    end select

    if (n<=12) then
        f = factorial(n)/factorial(m)/factorial(n-m)
    else
        f = (n*binomial(n-1,ml-1)/ml)
    endif

end function binomial

End Module MathFuncMod


program pascalsTriangle

    ! This program prints n number of lines in pascal's triangle. 'line' represents the line number of pascal's triangle,
    ! 'spaces' is the number of spaces that are required, k is the iterable number/ number of element in each line in triangle,
    ! and c is the actual coefficient/number to be printed.
    ! This program prints in a pretty triangle, if the triangle is skewed adjust line 17 and 14.

    implicit none
    integer:: n
    integer(kind =16) :: line, spaces, k, c
    write(*,*) "Enter the number of rows of the Pascal Triangle: "
    read (*,*) n
    do line = 0,n-1
        c = 1
        do spaces = 0,n-line-1         !write total n-lines (-1 is with experiment for adjusting) spaces before printing number
            write(*,'(a)',advance="no") "   "
        end do
        do k = 0,line
            write(*,'(i5,a)',advance="no") c, " "   ! i5 works best for me, otherwise i have to change the number of spaces in above loop
            c = c * (line-k)/(k+1)                !c calculates the coefficient to write every step
        end do
        write(*,*) " "                      ! this is there to end the line finally and move to next line
    end do
end program pascalsTriangle


    program demo_epsilon
    use,intrinsic :: iso_fortran_env, only : dp=>real64,sp=>real32
    implicit none
    real(kind=sp) :: x = 3.143
    real(kind=dp) :: y = 2.33d0

       ! so if x is of type real32, epsilon(x) has the value 2**-23
       print *, epsilon(x)
       ! note just the type and kind of x matter, not the value
       print *, epsilon(huge(x))
       print *, epsilon(tiny(x))

       ! the value changes with the kind of the real value though
       print *, epsilon(y)

       ! adding and subtracting epsilon(x) changes x
       write(*,*)x == x + epsilon(x)
       write(*,*)x == x - epsilon(x)

       ! these next two comparisons will be .true. !
       write(*,*)x == x + epsilon(x) * 0.999999
       write(*,*)x == x - epsilon(x) * 0.999999

       ! you can calculate epsilon(1.0d0)
       write(*,*)my_dp_eps()

    contains

    function my_dp_eps()
    ! calculate the epsilon value of a machine the hard way
    real(kind=dp) :: t
    real(kind=dp) :: my_dp_eps

       ! starting with a value of 1, keep dividing the value
       ! by 2 until no change is detected. Note that with
       ! infinite precision this would be an infinite loop,
       ! but floating point values in Fortran have a defined
       ! and limited precision.
       my_dp_eps = 1.0d0
       SET_ST: do
          my_dp_eps = my_dp_eps/2.0d0
          t = 1.0d0 + my_dp_eps
          if (t <= 1.0d0) exit
       enddo SET_ST
       my_dp_eps = 2.0d0*my_dp_eps

    end function my_dp_eps

    end program demo_epsilon


module vector
implicit none
contains
  subroutine get_vec_cross(v1, v2, m, cross)

    integer,intent(in)::m
    real(kind=4),intent(in),dimension(m)::v1,v2
    real(kind=4),intent(out),dimension(m)::cross

    cross(1)=v1(2)*v2(3)-v1(3)*v2(2)
    cross(2)=v1(3)*v2(1)-v1(1)*v2(3)
    cross(3)=v1(1)*v2(2)-v1(2)*v2(1)

    return

  end subroutine get_vec_cross

  subroutine get_vec_len(vec,vec_len,m)

    integer::i
    integer,intent(in)::m
    real(kind=4)::sum_value
    real(kind=4),intent(in),dimension(m)::vec
    real(kind=4),intent(out)::vec_len

    sum_value=0.0
    do i=1,m
      sum_value=sum_value+vec(i)**2
    end do
    vec_len = sqrt(sum_value)

    return

  end subroutine get_vec_len

  subroutine norm_vec(vec,new_vec,m)

    integer::i
    integer,intent(in)::m
    real(kind=4)::sum_value
    real(kind=4),intent(in),dimension(m)::vec
    real(kind=4),intent(out),dimension(m)::new_vec

    sum_value = 0.0
    do i=1,m
      sum_value=sum_value+vec(i)**2
    end do
    do i=1,m
      new_vec(i)=vec(i)/sqrt(sum_value)
    end do

    return

  end subroutine norm_vec

  subroutine project_vec(vec_1,vec_2,m,vec_1_proj_vec_2,sign_value)
  ! project vec_1 on the basis of vec_2

    integer,intent(in)::m
    real(kind=4)::a,b
    real(kind=4),intent(out)::sign_value
    real(kind=4),intent(in),dimension(m)::vec_1,vec_2
    real(kind=4),intent(out),dimension(m)::vec_1_proj_vec_2

    a=DOT_PRODUCT(vec_1,vec_2)
    b=DOT_PRODUCT(vec_2,vec_2)
    vec_1_proj_vec_2=a*vec_2/b

    if ( a<0.0 ) then
      sign_value=-1.0
    else
      sign_value=1.0
    end if

    return

  end subroutine project_vec

  subroutine center_of_mass(mass,data_array,data_center,n,m)

    integer::i,j
    integer,intent(in)::n,m
    real(kind=4)::sum_value
    real(kind=4)::sum_value_mass
    real(kind=4),intent(in),dimension(n)::mass
    real(kind=4),intent(in),dimension(n,m)::data_array
    real(kind=4),intent(out),dimension(m)::data_center

    sum_value_mass=0.0

    do i=1,n
      sum_value_mass=sum_value_mass+mass(i)
    end do

    do i=1,m
      sum_value=0.0
      do j=1,n
        sum_value=sum_value+mass(j)*data_array(j,i)
      end do
      data_center(i)=sum_value/sum_value_mass
    end do

    return

  end subroutine center_of_mass

end module vector


MODULE m_statist

! ----------------------------------------------------------------------
! MODULE: m_statist.f03
! ----------------------------------------------------------------------
! Purpose:
!  Module for computing of representative statistical quantities of a data series
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	13 October 2017
! ----------------------------------------------------------------------

      IMPLICIT NONE
      !SAVE

Contains

SUBROUTINE statist (dx, RMSdx, Sigmadx, MEANdx, MINdx, MAXdx)

! ----------------------------------------------------------------------
! SUBROUTINE: statist.f03
! ----------------------------------------------------------------------
! Purpose:
!  Compute the statistical quantities (RMS, Min, Max) of a series matrix of numerical differences
! ----------------------------------------------------------------------
! Input arguments:
! - dx:			Matrix with the x series differences (dynamic allocatable array)
!
! Output arguments:
! - RMSdx: 		Root Mean Square of dx
! - Sigmadx: 	Standard Deviation of dx
! - MEANdx: 	Mean value of dx
! - MINdx: 		Minimum value of dx
! - MAXdx: 		Maximum value of dx
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou, Cooperative Research Centre for Spatial Information, Australia
! Created:	13 October 2017
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN), ALLOCATABLE, DIMENSION(:) :: dx
! ----------------------------------------------------------------------
! OUT
      REAL (KIND = prec_d), INTENT(OUT) :: RMSdx, Sigmadx, MEANdx, MINdx, MAXdx
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_d) :: sum_dx, sum_dx2, sum_dxx
      INTEGER (KIND = prec_int8) :: sz1, sz2, size_dx, i
      INTEGER (KIND = prec_int2) :: AllocateStatus, DeAllocateStatus
! ----------------------------------------------------------------------

sz1 = size(dx, DIM = 1)
!sz2 = size(dx, DIM = 2)

size_dx = sz1
sum_dx = 0.0D0
sum_dx2 = 0.0D0
MINdx = dx(1)
MAXdx = dx(1)
Do i = 1 , size_dx
   sum_dx2 = sum_dx2 + dx(i)**2
   sum_dx = sum_dx + dx(i)
   If (dx(i) < MINdx) Then
      MINdx = dx(i)
   End IF
   If (dx(i) > MAXdx) Then
      MAXdx = dx(i)
   End IF

End Do

! RMS
RMSdx = sqrt(sum_dx2 / size_dx)

! Mean
MEANdx = sum_dx / size_dx

! Standard Deviation
sum_dxx = 0.0D0
DO i = 1 , size_dx
   sum_dxx = sum_dxx + (dx(i) - MEANdx)**2
END DO
Sigmadx = sqrt(sum_dxx / size_dx)
Sigmadx = sqrt(sum_dxx / (size_dx - 1) )

END SUBROUTINE

End Module


SUBROUTINE linint (x1, y1, x2, y2, x3, y3, x4, y4, xc, yc, &
 &                   intersect, coincide)

  !   m o d u l e s

  USE kind_param, ONLY: double
  IMPLICIT NONE

  !   d u m m y   a r g u m e n t s

  REAL (double) :: x1
  REAL (double) :: y1
  REAL (double) :: x2
  REAL (double) :: y2
  REAL (double) :: x3
  REAL (double) :: y3
  REAL (double) :: x4
  REAL (double) :: y4
  REAL (double) :: xc
  REAL (double) :: yc
  LOGICAL, INTENT (OUT) :: intersect
  LOGICAL, INTENT (OUT) :: coincide

  !   i n t e r f a c e   b l o c k s

  INTERFACE
  INCLUDE 'linequ.h'
  INCLUDE 'insidf.h'
  END INTERFACE

  !-----------------------------------------------
  !   l o c a l   v a r i a b l e s

  REAL (double) :: w, a1, b1, c1, a2, b2, c2, wx, wy
  LOGICAL :: between1, between2
  !-----------------------------------------------

  intersect = .FALSE.
  coincide = .FALSE.

  ! equation of the 1st line: a1*x + b1*y = c1
  !                 2nd line: a2*x + b2*y = c2

  IF (x1 == x2 .AND. y1 == y2) RETURN ! line is reduced to a point

  CALL linequ (x1, y1, x2, y2, a1, b1, c1)
  CALL linequ (x3, y3, x4, y4, a2, b2, c2)

  !     solution of the set of the two equations
  !       a1*x + b1*y = c1
  !       a2*x + b2*y = c2
  !
  !     w, wx, wy - determinants

  w  = a1 * b2 - a2 * b1
  wx = c1 * b2 - c2 * b1
  wy = a1 * c2 - a2 * c1

  IF (w /= 0.) THEN         ! not parallel

     wy = a1 * c2 - a2 * c1
     xc = wx / w
     yc = wy / w
     CALL insidf (x1, y1, x2, y2, xc, yc, between1)
     CALL insidf (x3, y3, x4, y4, xc, yc, between2)
     IF (between1 .AND. between2) intersect = .TRUE.

  ELSE IF (w == 0 .AND. wx == 0 .AND. wy == 0) THEN !coinciding

     coincide = .TRUE.

  END IF

  RETURN

END SUBROUTINE linint