module etox_module
    implicit none

    contains
    real function etox(x)
        implicit none

        real, intent(in) :: x
        real :: term
        integer :: n
        real, parameter :: tol = 1.e-6

        etox = 1.
        term = 1.
        n = 0
        do
            n = n+1
            term = term*(x/n)
            etox = etox+term
            if (abs(term)<=tol) exit
        end do
    end function
end module

program ch1306
    ! The Evaluation of e**x
    use etox_module
    implicit none

    real, parameter :: x = 1.
    real :: y

    print *, 'Fortran intrinsic ', exp(x)
    y = etox(x)
    print *, 'User defined etox ', y
end program


module euler
  implicit none
  private
  public :: binomial
  public :: digit
  public :: digit16
  public :: gcd
  public :: is_factor
  public :: is_palindrome
  public :: is_palindrome16
  public :: is_prime
  public :: number_length
  public :: sum_of_divisors
  public :: tau
  public :: is_triangular
  public :: is_square
  public :: is_pentagonal
  public :: is_hexagonal
  public :: is_heptagonal
  public :: is_octagonal

contains

  ! Binomial coefficient
  pure function binomial(n,k)
    implicit none
    integer*8, intent(in) :: n,k
    integer*16            :: temp
    integer*8             :: i,binomial

    temp=1
    do i=n-k+1,n
       temp=temp*i
    end do
    do i=1,n-k
       temp=temp/i
    end do
    binomial=temp
  end function binomial

  ! Get the dth digit from the decimal representation of n.
  pure function digit(n,d)
    implicit none
    integer, intent(in) :: n, d
    integer             :: digit
    digit = mod(n,10**d)/(10**(d-1))
  end function digit

  ! Get the dth digit from the decimal representation of n.
  pure function digit16(n,d)
    implicit none
    integer*16, intent(in) :: n
    integer, intent(in)    :: d
    integer                :: digit16
    digit16 = mod(n,10_16**d)/(10_16**(d-1))
  end function digit16

  ! gcd
  pure function gcd(a0,b0)
    implicit none
    integer*8, intent(in) :: a0, b0
    integer               :: a, b, t, gcd

    a=a0
    b=b0
    do while (b /= 0)
       t=b
       b=mod(a,b)
       a=t
    end do
    gcd=a
  end function gcd

  ! Returns .true. if f is a factor of n, otherwise returns .false.
  pure function is_factor(f,n)
    implicit none
    integer*8, intent(in) :: n
    integer, intent(in)   :: f
    logical               :: is_factor
    is_factor = (mod(n,f)==0)
  end function is_factor

  ! Returns .true. if the decimal representation of n is a palindrome,
  ! otherwise returns .false.
  pure function is_palindrome(n)
    implicit none
    integer, intent(in) :: n
    integer             :: i, j, digits
    logical             :: is_palindrome

    digits = ceiling(log10(dble(n)))
    is_palindrome = .true.

    do i=1,digits
       j = digits+1-i
       if (digit(n,i) /= digit(n,j)) then
          is_palindrome = .false.
          exit
       end if
    end do
  end function is_palindrome

  ! Returns .true. if the decimal representation of n is a palindrome,
  ! otherwise returns .false.
  pure function is_palindrome16(n)
    implicit none
    integer*16, intent(in) :: n
    real*16                :: temp
    integer                :: i, j, digits
    logical                :: is_palindrome16

    temp=n*1.0
    digits = ceiling(log10(temp))
    is_palindrome16 = .true.

    do i=1,digits
       j = digits+1-i
       if (digit16(n,i) /= digit16(n,j)) then
          is_palindrome16 = .false.
          exit
       end if
    end do
  end function is_palindrome16

  ! Returns .true. if n is a prime number, otherwise return .false.
  pure function is_prime(n)
    implicit none
    integer*8, intent(in) :: n
    integer               :: i
    logical               :: is_prime

    if (n == 1) then
       is_prime = .false.
    else
       is_prime = .true.
       do i=2,min(n-1,ceiling(sqrt(dble(n))))
          if (mod(n,i) == 0) then
             is_prime = .false.
             exit
          end if
       end do
    end if
  end function is_prime

  ! Get the length of the decimal representation of a number
  pure function number_length(n)
    implicit none
    integer*8, intent(in) :: n
    integer               :: number_length
    real*8                :: temp

    temp=log10(dble(n))
    if (mod(temp,1.0_8)==0.0_8) temp=temp+0.01
    number_length = ceiling(temp)
  end function number_length

  ! Returns the sum of proper divisors
  pure function sum_of_divisors(n)
    implicit none
    integer*8, intent(in) :: n
    integer*8             :: i
    integer*8             :: sum_of_divisors

    sum_of_divisors=1
    do i=2,n-1
       if (mod(n,i) == 0) then
          sum_of_divisors=sum_of_divisors+i
       end if
    end do
  end function sum_of_divisors

  ! Euler tau function: The number of divisors of n
  pure function tau(n)
    implicit none
    integer*8, intent(in) :: n
    integer*8             :: current_n,p
    integer               :: a,tau

    tau=1
    current_n=n

1   if (is_prime(current_n)) then ! shortcut for prime numbers
       tau=tau*2
       current_n=1
    end if
    do p=2,current_n
       if (is_prime(p) .and. (mod(current_n,p) == 0)) then
          do a=ceiling(log(dble(n))/log(dble(p))),1,-1
             if (mod(current_n,p**a) == 0) then
                exit
             end if
          end do
          tau=tau*(a+1)
          current_n=current_n/(p**a)
          go to 1
       end if
    end do
  end function tau

  pure function is_triangular(m)
    implicit none
    integer, intent(in) :: m
    double precision    :: temp
    logical             :: is_triangular,plus,minus

    temp=(1 + sqrt(1.0 + 4*2*m))/2
    plus=(temp>0) .and. (mod(temp,1.0)==0.0)
    temp=(1 - sqrt(1.0 + 4*2*m))/2
    minus=(temp>0) .and. (mod(temp,1.0)==0.0)
    is_triangular=plus .or. minus

  end function is_triangular

  pure function is_square(m)
    implicit none
    integer, intent(in) :: m
    logical             :: is_square

    is_square=mod(sqrt(dble(m)),1.0)==0.0

  end function is_square

  pure function is_pentagonal(m)
    implicit none
    integer, intent(in) :: m
    double precision    :: temp
    logical             :: is_pentagonal,plus,minus

    temp=(1 + sqrt(1.0 + 4*3*2*m))/6
    plus=(temp>0) .and. (mod(temp,1.0)==0.0)
    temp=(1 - sqrt(1.0 + 4*3*2*m))/6
    minus=(temp>0) .and. (mod(temp,1.0)==0.0)
    is_pentagonal=plus .or. minus

  end function is_pentagonal

  pure function is_hexagonal(m)
    implicit none
    integer, intent(in) :: m
    double precision    :: temp
    logical             :: is_hexagonal,plus,minus

    temp=(1 + sqrt(1.0 + 4*2*m))/4
    plus=(temp>0) .and. (mod(temp,1.0)==0.0)
    temp=(1 - sqrt(1.0 + 4*2*m))/4
    minus=(temp>0) .and. (mod(temp,1.0)==0.0)
    is_hexagonal=plus .or. minus

  end function is_hexagonal

  pure function is_heptagonal(m)
    implicit none
    integer, intent(in) :: m
    double precision    :: temp
    logical             :: is_heptagonal,plus,minus

    temp=(3 + sqrt(9.0 + 4*5*2*m))/10
    plus=(temp>0) .and. (mod(temp,1.0)==0.0)
    temp=(3 - sqrt(9.0 + 4*5*2*m))/10
    minus=(temp>0) .and. (mod(temp,1.0)==0.0)
    is_heptagonal=plus .or. minus

  end function is_heptagonal

  pure function is_octagonal(m)
    implicit none
    integer, intent(in) :: m
    double precision    :: temp
    logical             :: is_octagonal,plus,minus

    temp=(2 + sqrt(4.0 + 4*3*m))/6
    plus=(temp>0) .and. (mod(temp,1.0)==0.0)
    temp=(2 - sqrt(4.0 + 4*3*m))/6
    minus=(temp>0) .and. (mod(temp,1.0)==0.0)
    is_octagonal=plus .or. minus

  end function is_octagonal

end module euler


PROGRAM LargestFactorialInteger
!---
! This Program determines the largest n for which n! can be stored in a 32 bit integer
!---
IMPLICIT NONE

INTEGER :: v, n
REAL :: r, rprev

!- First, the largest possbile signed 32bit integer value is 2**31-1
v = 2**31-1
PRINT *, "The largest integer is:"
PRINT  *, v
!- Next, we'll start with n = 1, n! == 1
n = 1
r = 1
!- continue computing n! with incresing n, until we surpass v
DO WHILE (v .gt. r)
    n = n + 1
  	rprev = r
    r = r * n
END DO
!- Now notice n will increase even if r becomes greater than v, so n--
n = n -1
v = rprev
PRINT *, "The largest possible values of n and n! within the 32bit integer is:"
PRINT *, "n:", n
PRINT *, "n!:", v

END PROGRAM LargestFactorialInteger


program meanVarianceSD

   implicit none;
   integer ,parameter:: MAX_SIZE = 50;
   integer n;
   integer i;
   real  sum, mean, variance, sd;
   real ,dimension(MAX_SIZE)::arr

   print *, 'Enter no of terms'
   read *, n

   !read input
   i = 1
   do while(i <= n)
    read *, arr(i);
    i = i + 1
   end do
   !or read/write directly
   !read  (*,*),(arr(i),i = 1, n)
   !write (*,*),(arr(i),i = 1, n)

  ! print elements
  ! print *, 'Array elements are as :'
  ! do i = 1 , n, 1
  !  print *, arr(i) , " *"
  ! end do

   sum = 0;
   do i = 1, n, 1
      sum = sum + arr(i);
   end do

   mean = sum / n;

   variance = 0
   do i = 1, n, 1
      variance = variance + (arr(i) - mean)**2; ! ** === ^
   end do
   variance = variance / (n - 1)
   sd = SQRT(variance)

   print *, "Mean     : " ,mean
   print *, "Variance : " ,variance
   print *, "SD       : " ,sd

   end program meanVarianceSD


	!>@author
	!>Paul Connolly, The University of Manchester
	!>@brief
	!>code to do a linear interpolation based on neville's algorithm
	!> https://en.wikipedia.org/wiki/Neville%27s_algorithm
	!>param[in] xarr,yarr,x: arrays and position
	!>param[inout] y,dy: value of y and error in y
	subroutine poly_int(xarr,yarr,x,y,dy)
	    use numerics_type
        use numerics, only : assert_eq,iminloc,numerics_error
        implicit none
        real(wp), dimension(:), intent(in) :: xarr,yarr
        real(wp), intent(in) :: x
        real(wp), intent(out) :: y,dy
        integer(i4b) :: m,n,ns
        real(wp), dimension(size(xarr)) :: c,d,factor,dx
        n=assert_eq(size(xarr),size(yarr),'poly_int')
        c=yarr
        d=yarr
        dx=xarr-x
        ns=iminloc(abs(dx))
        y=yarr(ns) ! nearest neighbour
        ns=ns-1
        do m=1,n-1 ! there are n-1 additional terms
            factor(1:n-m)=dx(1:n-m)-dx(1+m:n)
            if (any(factor(1:n-m) == 0.0)) &
                call numerics_error('poly_int: calculation failure')
            factor(1:n-m)=(c(2:n-m+1)-d(1:n-m))/factor(1:n-m) ! 3.1.3 recurrence relation
            d(1:n-m)=dx(1+m:n)*factor(1:n-m) ! 3.1.5 formulae
            c(1:n-m)=dx(1:n-m)*factor(1:n-m)
            if (n-m > 2*ns) then
                dy=c(ns+1)
            else
                dy=d(ns)
                ns=ns-1
            end if
            y=y+dy
        end do
	end subroutine poly_int


!
! newton1d.f95
!
! Josh Kaplan
!
! This is a generic implementation of Newton's Method in 1-dimension.
! Edit the function, f, and it's derivative, df, for your specific problem.
!
! Compile: run "gfortran newton1d.f95 -o newton"
! Execute: run "./newton"
!

program NewtonsMethod

integer :: N
real :: tol, x, f, df

x   = 10                    ! Initial guess       <= EDIT THIS LINE
N   = 100                   ! Maximum Iterations  <= EDIT THIS LINE
tol = 1e-3                  ! Tolerance           <= EDIT THIS LINE

! Netwon's Method
do i = 1, N
    f  = 2*x**2 - 32        ! Function f(x)       <= EDIT THIS LINE
    df = 4*x                ! Derivative f'(x)    <= EDIT THIS LINE
    x = x - f/df            ! Improved guess

    ! If close enough, exit loop
    if (ABS(f) < tol)  then
        exit
    end if
end do
print '("Converged to",f6.3," in",i2," iterations")', x, i

end program NewtonsMethod


function Interpolate(opt,N,dx,F,x)

implicit none

real (kind=8)    :: Interpolate,dx,x
real (kind=8)    :: aux1,aux2
real (kind=8)    :: Fbefore,Fafter,Fcurr
integer (kind=4) :: opt
integer (kind=4) :: N,ix

real (kind=8),dimension (0:N+1) :: F

ix   = int(x/dx)+1
aux1 = x-(ix-1)*dx
aux2 = dx-aux1

if (opt==0) then

   Interpolate = (aux1*F(ix)+aux2*F(ix-1))/dx

else if (opt==1) then

   Fbefore = (aux1*F(ix-1)+aux2*F(ix-2))/dx
   Fafter  = (aux1*F(ix+1)+aux2*F(ix))/dx

   Interpolate = 0.5d0*(Fafter-Fbefore)/dx

else if (opt==2) then

   Fbefore = (aux1*F(ix-1)+aux2*F(ix-2))/dx
   Fcurr   = (aux1*F(ix)+aux2*F(ix-1))/dx
   Fafter  = (aux1*F(ix+1)+aux2*F(ix))/dx

   Interpolate = (Fafter-2.d0*Fcurr+Fbefore)/(dx*dx)

else

   print *, 'Parameter opt in function interpolate crash!!!!!'

end if

return
end function Interpolate


FUNCTION in_circle(pos_x, pos_y, r)
    IMPLICIT NONE
    REAL(16), INTENT(IN) :: pos_x, pos_y, r
    LOGICAL              :: in_circle

    in_circle = (pos_x ** 2 + pos_y ** 2) < r ** 2

END FUNCTION in_circle

PROGRAM monte_carlo

    IMPLICIT NONE

    INTERFACE
        FUNCTION in_circle(pos_x, pos_y, r)
            IMPLICIT NONE
            REAL(16), INTENT(IN) :: pos_x, pos_y, r
            LOGICAL              :: in_circle
        END FUNCTION in_circle
    END INTERFACE

    INTEGER  :: i,n
    REAL(16) :: pos_x,pos_y, r, pi_est, pi_count, pi_error, pi

    ! Calculate Pi from trigonometric functions as reference
    pi       = DACOS(-1.d0)
    n        = 1000000
    r        = 1d0
    pos_x    = 0d0
    pos_y    = 0d0
    pi_count = 0d0

    DO i=0,n

        CALL RANDOM_NUMBER(pos_x)
        CALL RANDOM_NUMBER(pos_y)

        IF (in_circle(pos_x, pos_y, r) .EQV. .TRUE.) THEN

            pi_count = pi_count + 1d0

        END IF
    END DO

    pi_est   = 4d0 * pi_count / n
    pi_error = 100d0 * (abs(pi_est - pi)/pi)

    WRITE(*,'(A, F12.4)') 'The pi estimate is: ', pi_est
    WRITE(*,'(A, F12.4, A)') 'Percent error is: ', pi_error, ' %'

END PROGRAM monte_carlo


SUBROUTINE CANS( T, omega, Pulse, SF, NSD, IT, PulseTitle )

  !     Computes the source time series

  !     T      is the time
  !     omega  is some frequency characterizing the pulse
  !     Pulse  is the letter indicating which pulse
  !     S      is the time series

  IMPLICIT NONE
  REAL, PARAMETER :: pi = 3.141592

  INTEGER,   INTENT( IN  ) :: NSD, IT
  REAL,      INTENT( IN  ) :: T, omega
  CHARACTER, INTENT( IN  ) :: Pulse*1
  COMPLEX,   INTENT( OUT ) :: SF( NSD, * )
  CHARACTER, INTENT( OUT ) :: PulseTitle*( * )
  INTEGER  :: NSIG
  REAL     :: S, F, A, T0, TS, TC, U

  S = 0.0
  F = omega / ( 2.0 * pi )

  IF ( T > 0.0 ) THEN    ! Evaluate selected Pulse
     SELECT CASE ( Pulse )
     CASE ( 'P' )   ! Pseudo gaussian
        ! (peak at 0, support [0, 3F]
        IF ( T <= 1.0 / F ) S = 0.75 - COS( omega * T ) + 0.25*COS( 2.0 * omega * T )
        PulseTitle = 'Pseudo gaussian'

     CASE ( 'R' )   ! Ricker wavelet
        ! (peak at F, support [0, 2F]
        U = omega * T - 5.0
        S = 0.5 * ( 0.25*U*U - 0.5 ) * SQRT( pi ) * EXP( -0.25*U*U )
        PulseTitle = 'Ricker wavelet'

     CASE ( 'A' )    ! Approximate Ricker wavelet
        ! (peak at F, support [0, 2.5F]
        TC = 1.55 / F
        IF ( T <= TC ) &
             &   S = 0.48829 *    COS( 2.0 * pi * T / TC ) &
             &      -0.14128 * 4* COS( 4.0 * pi * T / TC ) &
             &      +0.01168 * 9* COS( 6.0 * pi * T / TC )
        PulseTitle = 'Approximate Ricker wavelet'

     CASE ( 'S' )   ! Single sine
        ! (peak at F, support [0, infinity], nulls at nF
        IF ( T <= 1.0 / F ) S = SIN( omega * T )
        PulseTitle = 'Single sine'

     CASE ( 'H' )   ! Hanning weighted four sine
        ! (peak at F, support [0, infinity], first null at about 1.5F
        IF ( T <= 4.0 / F ) S = 0.5 * SIN( omega * T ) * ( 1 - COS( omega * T / 4.0 ) )
        PulseTitle = 'Hanning weighted four sine'

     CASE ( 'N' )   ! N-wave
        ! (peak at 1 F, support [0, 4F], [0,3F] OK
        IF ( T <= 1.0 / F ) S = SIN( omega * T ) - 0.5 * SIN( 2.0 * omega * T )
        PulseTitle = 'N-wave'

     CASE ( 'M' )   ! Miracle wave (has a Hilbert transform?)
        ! (peak at 0, support [0, infinity]
        A  = 1.0 / ( 6.0 * F )
        T0 = 6.0 * A
        TS = ( T - T0 ) / A
        S  = 1.0 / ( 1.0 + TS * TS )
        ! HS is the Hilbert transform of the time series
        ! HS = TS / ( 1.0 + TS * TS )
        PulseTitle = 'Miracle wave'

     CASE ( 'G' )   ! Gaussian
        ! (peak at 0, support [0, infinity]
        ! T0 is the peak time
        ! A is the 3dB down time
        ! NOTE S(0) = EXP( -NSIG ** 2 )

        NSIG = 3
        A    = 1.0 / F / ( 2.0 * NSIG )
        T0   = NSIG * A
        S    = EXP( -( ( T - T0 ) / A ) ** 2 )
        PulseTitle = 'Gaussian'
     CASE ( 'T' )   ! Tone
        ! (peak at F, support [0, infinity]

        IF ( T <= 0.4 ) S = SIN( omega * T )
        PulseTitle = 'Tone'
     CASE ( 'C' )   ! Sinc
        ! ( uniform spectrum from [0, F]

        S = SIN( omega * T ) / ( omega * T )
        PulseTitle = 'Sinc'
     END SELECT
  END IF

  SF( :, IT ) = S ! Copy into source vector (waveform duplicated for every source depth)

END SUBROUTINE CANS


!
! Implementation of the iterative Jacobi method.
!
! Given a known, diagonally dominant matrix A and a known vector b, we aim to
! to find the vector x that satisfies the following equation:
!
!     Ax = b
!
! We first split the matrix A into the diagonal D and the remainder R:
!
!     (D + R)x = b
!
! We then rearrange to form an iterative solution:
!
!     x' = (b - Rx) / D
!
! More information:
! -> https://en.wikipedia.org/wiki/Jacobi_method
!

! Module which contains the Jacobi solver subrountine
module solve_mod

  contains

  ! Solve Ax=b according to the Jacobi method
  subroutine solve(N, A, b, x, xtmp, itr, MAX_ITERATIONS, CONVERGENCE_THRESHOLD)

    implicit none

    ! Input variables
    integer :: N                          ! Matrix order
    real(kind=8) :: A(N,N)                ! The matrix
    real(kind=8) :: b(N)                  ! The right hand side vector
    real(kind=8), pointer :: x(:)         ! Initial solution
    real(kind=8), pointer :: xtmp(:)      ! Next solution
    integer :: itr                        ! Iterations to solve
    integer :: MAX_ITERATIONS             ! Iteration limit
    real(kind=8) :: CONVERGENCE_THRESHOLD ! Convergence criteria

    ! Local variables
    real(kind=8), pointer :: ptrtmp(:) ! Used for pointer swapping
    integer :: row, col                ! Matrix index
    real(kind=8) :: dot
    real(kind=8) :: diff, sqdiff=huge(0.0_8)

    ! Loop until converged or maximum iterations reached
    itr = 0
    do while (itr .lt. MAX_ITERATIONS .and. sqrt(sqdiff) .gt. CONVERGENCE_THRESHOLD)
      ! Perfom Jacobi iteration
      do row = 1, N
        dot = 0.0_8
        do col = 1, N
          if (row .ne. col) then
            dot = dot + (A(row,col) * x(col))
          end if
        end do
        xtmp(row) = (b(row) - dot) / A(row,row)
      end do

      ! Swap pointers
      ptrtmp => x
      x      => xtmp
      xtmp   => ptrtmp

      ! Check for convergence
      sqdiff = 0.0_8
      do row = 1, N
        diff = xtmp(row) - x(row)
        sqdiff = sqdiff + (diff * diff)
      end do

      itr = itr + 1
    end do

  end subroutine solve
end module solve_mod

! Main program
program jacobi

  use timer
  use solve_mod     ! Include solver (above)

  implicit none

  ! Solver settings
  integer :: MAX_ITERATIONS=20000
  real(kind=8) :: CONVERGENCE_THRESHOLD=0.0001

  ! Timers
  real(kind=8) :: total_start, total_end
  real(kind=8) :: solve_start, solve_end

  ! Matrix size
  integer :: N=1000

  ! Data arrays
  real(kind=8), allocatable :: A(:,:) ! The matrix
  real(kind=8), allocatable :: b(:)   ! The right hand size vector
  real(kind=8), pointer :: x(:)       ! Initial solution
  real(kind=8), pointer :: xtmp(:)    ! Temporary solution storage
  integer :: itr                      ! Iteration count

  ! Local variables
  integer :: row, col
  real(kind=8) :: rowsum, value
  real(kind=8) :: err, tmp

  ! Read in any command line arguments which set problem variables
  call parse_arguments(MAX_ITERATIONS, CONVERGENCE_THRESHOLD, N)

  ! Allocate memory
  allocate(A(N,N))
  allocate(b(N))
  allocate(x(N))
  allocate(xtmp(N))

  ! Print header
  write(*,"(A)")         "------------------------------------"
  write(*,"(A,I0,A,I0)") "Matrix size:           ", N, " x ", N
  write(*,"(A,I0)")      "Maximum iterations:    ", MAX_ITERATIONS
  write(*,"(A,F7.5)")    "Convergence threshold: ", CONVERGENCE_THRESHOLD
  write(*,"(A)")         "------------------------------------"
  write(*,*)

  ! Start the program timer
  call wtime(total_start)

  ! Initialize data randomly
  ! A needs to be a diagonally dominant square matrix, so diagonal entries are biased
  do row = 1, N
    rowsum = 0.0_8
    do col = 1, N
      call random_number(value)
      A(row,col) = value
      rowsum = rowsum + value
    end do
    A(row,row) = A(row,row) + rowsum
    call random_number(b(row))
    x(row) = 0.0_8
  end do

  ! Run Jacobi solver
  call wtime(solve_start)
  call solve(N, A, b, x, xtmp, itr, MAX_ITERATIONS, CONVERGENCE_THRESHOLD)
  call wtime(solve_end)

  ! Check error of final solution
  err = 0.0_8
  do row = 1, N
    tmp = 0.0_8
    do col = 1, N
      tmp = tmp + (A(row,col) * x(col))
    end do
    tmp = b(row) - tmp
    err = err + (tmp*tmp)
  end do
  err = sqrt(err)

  ! Stop the program timer
  call wtime(total_end)

  ! Print results
  write(*,"(A,F13.7)") "Solution error = ", err
  write(*,"(A,I0)")    "Iterations     = ", itr
  write(*,"(A,F10.3)") "Total runtime  = ", total_end-total_start
  write(*,"(A,F10.3)") "Solver runtime = ", solve_end-solve_start
  if (itr .eq. MAX_ITERATIONS) write(*,"(A)") "WARNING: solution did not converge"
  write(*,"(A)")       "------------------------------------"

  ! Free memory
  deallocate(A, b, x, xtmp)

end program jacobi

! Parse the command line arguments, setting the problem size, etc.
subroutine parse_arguments(MAX_ITERATIONS, CONVERGENCE_THRESHOLD, N)

  implicit none

  integer :: MAX_ITERATIONS
  real(kind=8) :: CONVERGENCE_THRESHOLD
  integer :: N

  character(len=32) :: arg

  integer :: i=1
  integer :: err

  do while (i .le. command_argument_count())
    call get_command_argument(i, arg)
    arg = trim(arg)

    if ("--convergence" .eq. arg .or. &
        "-c"            .eq. arg) then
      i = i + 1
      call get_command_argument(i, arg, status=err)
      if (err .ne. 0) then
        write (*,*) "Error: no convergence threshold given"
        stop
      end if
      read(arg,*) CONVERGENCE_THRESHOLD

    else if ("--iterations" .eq. arg .or. &
             "-i" .eq. arg) then
      i = i + 1
      call get_command_argument(i, arg, status=err)
      if (err .ne. 0) then
        write (*,*) "Error: no max iterations given"
        stop
      end if
      read(arg,*) MAX_ITERATIONS

    else if ("--norder" .eq. arg .or. &
             "-n" .eq. arg) then
      i = i + 1
      call get_command_argument(i, arg, status=err)
      if (err .ne. 0) then
        write (*,*) "Error: no matrix order given"
        stop
      end if
      read(arg,*) N

    else if ("--help" .eq. arg) then
      write(*,"(A)") "Usage: ./jacobi [OPTIONS]"
      write(*,*)
      write(*,"(A)") "Options:"
      write(*,"(2X,A)") "-h  --help               Print this message"
      write(*,"(2X,A)") "-c  --convergence  C     Set convergence threshold"
      write(*,"(2X,A)") "-i  --iterations   I     Set maximum number of iterations"
      write(*,"(2X,A)") "-n  --norder       N     Set maxtrix order"
      write(*,*)
      stop

    else
      write (*,"(A,A)") "Unrecognized argument (try '--help'): ", arg
      stop
    end if

    i = i + 1
  end do
end subroutine parse_arguments


! Even Fibonacci numbers
! Problem 2
! Each new term in the Fibonacci sequence is generated by adding the previous two terms. By starting with 1 and 2, the first 10 terms will be:
!
! 1, 2, 3, 5, 8, 13, 21, 34, 55, 89, ...
!
! By considering the terms in the Fibonacci sequence whose values do not exceed four million, find the sum of the even-valued terms.

! Answer: 4613732

program ex002
   implicit none

   integer, parameter :: num = 4000000
   integer(8) :: res = 0

   call iterate_fib(num, sum_if_even)

   print *, 'Answer:', res
contains
   subroutine iterate_fib(limit, callback)
      implicit none

      integer, intent(in) :: limit
      interface
         subroutine callback(arg)
            integer, intent(in) :: arg
         end subroutine callback
      end interface
      integer :: f1 = 0, f2 = 1

      do
         f1 = f1 + f2
         if (f1 > limit) exit
         call callback(f1)

         f2 = f1 + f2
         if (f1 > limit) exit
         call callback(f2)
      end do
   end subroutine iterate_fib

   subroutine sum_if_even(n)
      implicit none

      integer, intent(in) :: n

      if (mod(n, 2) == 0) res = res + n
   end subroutine sum_if_even
end program ex002


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! z_scalar_random_normal
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine provides a pseudo-random complex number independent, standard,
! normally distributed (expected value 0, standard deviation 1). The routine
! generates two uniformly distributed random numbers using Fortran's built-in
! routine and then uses the Box-Muller transform.
! Call u_randomseed_initialize(INFO) first to set the seed of the number
! generator.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! OUTPUT VARIABLES:
!
!  RE              REAL(8)
!                    real part of random complex number
!
!  CO              REAL(8)
!                    complex part of random complex number
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine z_scalar_random_normal(RE, CO)

  implicit none

  ! input variables
  real(8), intent(inout) :: RE, CO

  ! compute variables
  double precision :: u,v,s,pi = EISCOR_DBL_PI
  integer :: ii

  do ii = 1, 100
     call random_number(u)
     call random_number(v)
     s = u**2 + v**2

     ! Box-Muller transform
     if ((s > 0d0) .AND. (s < 1d0)) then
        RE = dcos(2.d0*pi*u)*dsqrt(-2.d0*dlog(v))
        CO = dsin(2.d0*pi*u)*dsqrt(-2.d0*dlog(v))
        exit
     end if
  end do

end subroutine z_scalar_random_normal


program problem_7
    implicit none
    logical :: isPrime
    integer :: i
    integer :: counter
    integer :: limit
    integer :: num

    counter = 1
    limit = 10001
    num = 3

    do while (counter .LT. limit)
        if (isPrime(num)) then
            counter = counter + 1
        endif
        num = num + 2
    enddo

    print *, num - 2
    print *, counter

end program problem_7

logical function isPrime(number)
    implicit none
    integer :: number
    integer :: i

    if ((number .EQ. 0) .OR. (number .EQ. 1) .OR. ((number .NE. 2) .AND. (modulo(number, 2) .EQ. 0))) then
        isPrime = .FALSE.
        return
    endif

    do i=3, number / 3, 2
        if (modulo(number, i) .EQ. 0) then
            isPrime = .FALSE.
            return
        endif
    enddo

    isPrime = .TRUE.
    return

end function isPrime


PROGRAM A3Q2
!--
!Finds values of x where f(x)(x^2-2x-1) = 0 using the secant method.
!--
IMPLICIT NONE
REAL :: a, b, eps, root
INTEGER :: limit, iter

eps = .001
limit = 50
iter = 0
PRINT *, 'Attempts to solve f(x) = x^2-2x-1 for f(x)=0 using the secant method.'
PRINT *, 'Precision:', eps, 'loop limit:', limit
DO
	PRINT *, 'Enter your values for a and b. (enter 0 0 to stop)'
    READ *, a, b
    IF (a .eq. 0.0 .and. b .eq. 0.0) STOP
    root = Secant(a, b, eps, limit, iter)
    PRINT *, 'root:', root, 'iterations:', iter
END DO

CONTAINS
!- Secant method
REAL FUNCTION Secant(a, b, eps, limit, iter)
	REAL, INTENT(IN) :: a, b, eps
    INTEGER, INTENT(IN) :: limit
    INTEGER, INTENT(OUT) :: iter
    REAL :: x, x0, x1, fraction

    fraction = 0
    iter = 0
    x = 0
	x0 = a
    x1 = b
    fraction = fun(x1) / (fun(x1) - fun(x0))
    DO WHILE (abs(x0-x1) .gt. eps .and. iter .lt. limit)
    	x = x1 - (x1 - x0) * fraction
        x0 = x1
        x1 = x
        fraction = fun(x1) / (fun(x1) - fun(x0))
        iter = iter + 1
        ! Print additional information
        ! PRINT *, x, x0, x1, iter, abs(x0-x1)
    END DO
    Secant = x

END FUNCTION Secant
!- fun(x) = x^2-2x-1
REAL FUNCTION fun(x)
    REAL, INTENT(IN) :: x

	fun = (x - 2) * x - 1

END FUNCTION fun
END PROGRAM A3Q2


! -*- Mode: Fortran90; -*-
!-----------------------------------------------------------------
! Daniel R. Reynolds
! SMU Mathematics
! Math 4370/6370
! 7 February 2015
!=================================================================

program ComputePi
  !-----------------------------------------------------------------
  ! Description:
  !    Computes pi through numerical integration via
  !        pi = 4*int_0^1 1/(1+x^2) dx
  !    We use a simple midpoint rule for integration, over
  !    subintervals of fixed size 1/n, where n is a user-input
  !    parameter.
  !-----------------------------------------------------------------
  !======= Inclusions ===========

  !======= Declarations =========
  implicit none
  integer :: n
  integer :: i
  double precision :: pi, h, x, f, a, stime, ftime
  double precision, parameter :: pi_true = 3.14159265358979323846d0

  !======= Internals ============

  ! set the integrand function
  f(a) = 4.d0 / (1.d0 + a*a)

  ! input the number of intervals
  write(*,*) 'Enter the number of intervals (0 quits):'
  read(*,*) n
  if (n < 1) then
     stop
  endif

  ! start timer
  call get_time(stime)

  ! set subinterval width
  h = 1.d0/n

  ! perform integration over n intervals
  pi = 0.d0
  do i=1,n,1
     x = h*(i - 0.5d0)
     pi = pi + h*f(x)
  enddo

  ! stop timer
  call get_time(ftime)

  ! output computed value and error
  write(*,*) ' computed pi =',pi
  write(*,*) '     true pi =',pi_true
  write(*,*) '       error =',pi_true - pi
  write(*,*) '     runtime =',ftime-stime

end program ComputePi
!=================================================================


program nmdf
  use tools
  ! ----------------------------------------------------------------
  ! Newton's differentiation:
  !   Calculates the differentiation of y at a given x using newton's
  !   interpolation polynomial and the difference table calculated
  !   by the subroutine newinter()
  ! inputs:
  !   points    -- number of points for interpolation
  !   x()       -- the arrays of x's
  !   y()       -- the arrays of corresponding y's (f(x)'s)
  !   x_point   -- the value of x at which f'(x) is to be calculated
  ! output:
  !   res       -- the result of the derivation
  !   poly      -- the used interpolation polynomial
  ! Note:
  !   - used the subroutine newinter()
  !   - used forward difference table and modified the formula a bit
  !     to calculate the backward differentiation
  !   - used module "tools"
  ! env details:
  !   compiler -- gfortran v10.2.0
  !   OS       -- macOS 12.0 x86_64F
  !   Kernel   -- Darwin 21.0.0
  ! ----------------------------------------------------------------
  implicit none
  integer, parameter :: points = 8
  real(dp), dimension(points) :: x, y
  real(dp) :: x_point, res
  integer :: i
  character(len=10) :: poly

  ! given data points
  data(x(i), i=1, 8)/1.21, 1.31, 1.41, 1.51, 1.61, 1.71, 1.81, 1.91/
  data(y(i), i=1, 8)/4.43, 6.84, 10.06, 12.67, 15.73, 19.87, 21.86, 24.61/

  x_point = 1.61 ! the calculation point
  res = 0.0

  call neum_diff(points, x, y, x_point, poly, res)

  ! result printing
  print *, ''
  print *, 'result:'
  write (*, form_result2c) poly, '-- interpolation polynomial'
  write (*, form_result2r) x_point, '-- given point'
  write (*, form_result2r) res, '-- value of derivative'
end program nmdf


program main
    implicit none
    integer, parameter :: dp = selected_real_kind(8)
    real(dp), parameter :: pi = acos(-1.d0), m1 = 2.d0, m2 = 1.d0
    real(dp) :: k, omega1, omega2, dk

    dk = 1.d-2
    ! reduced zone scheme
    open(unit = 1, file = '1-ReducedZoneScheme.txt', status = 'unknown')
    k = -pi
    do while (k <= pi)
        ! acoustic mode
        omega1 = sqrt(1.d0 / m1 / m2 * ((m1 + m2) - sqrt((m1 + m2)**2 - 4.d0 * m1 * m2 * sin(k / 2.d0)**2)))
        ! optical mode
        omega2 = sqrt(1.d0 / m1 / m2 * ((m1 + m2) + sqrt((m1 + m2)**2 - 4.d0 * m1 * m2 * sin(k / 2.d0)**2)))
        write(1,'(3f20.8)') k, omega1, omega2
        k = k + dk
    end do
    close(1)

    ! extended zone scheme
    ! optical mode
    open(unit = 2, file = '1-ExtendedZoneSchemeOpticalMode.txt', status = 'unknown')
    k = 0.d0
    do while (k <= pi)
        omega1 = sqrt(1.d0 / m1 / m2 * ((m1 + m2) + sqrt((m1 + m2)**2 - 4.d0 * m1 * m2 * sin((-2.d0 * pi - k) / 2.d0)**2)))
        omega2 = sqrt(1.d0 / m1 / m2 * ((m1 + m2) + sqrt((m1 + m2)**2 - 4.d0 * m1 * m2 * sin((pi + k) / 2.d0)**2)))
        write(2,'(4f20.8)') -2.d0 * pi + k, omega1, pi + k, omega2
        k = k + dk
    end do
    close(2)
    ! acoustic mode
    open(unit = 3, file = '1-ExtendedZoneSchemeAcousticMode.txt', status = 'unknown')
    k = -pi
    do while (k <= pi)
        omega1 = sqrt(1.d0 / m1 / m2 * ((m1 + m2) - sqrt((m1 + m2)**2 - 4.d0 * m1 * m2 * sin(k / 2.d0)**2)))
        write(3,'(2f20.8)') k, omega1
        k = k + dk
    end do
    close(3)
end program main


!  Objetivo: Calcular todos os numeros primos ate um limite superior.
!  Metodo: Crivo de Eratostenes.
!  Autor: I.F.F. dos Santos
!  Exemplo de compilacao e execucao no linux:
!     gfortran crivo.f90 -o crivo && ./crivo
PROGRAM crivo
   ! O que segue serve somente para testar a rotina crivo_de_eratostenes().
   ! O verdadeiro algoritmo eh a subrotina em CONTAINS.
   ! Declaracoes
   IMPLICIT none
   INTEGER :: limite_superior
   ! Comandos executaveis
   PRINT *, "Bem vindo ao programa Crivo!"
   PRINT *, "Por favor, digite o maior numero da lista onde serao buscados os &
             &numeros primos:"
   READ *, limite_superior
   ! Chamando a rotina para o Crivo
   CALL crivo_de_eratostenes(limite_superior)

CONTAINS
   SUBROUTINE crivo_de_eratostenes(limite_superior)
      IMPLICIT none
      INTEGER, intent(IN) :: limite_superior
      INTEGER :: numero, multiplos
      LOGICAL :: lista(limite_superior)

      ! Os elementos da lista marcados como falsos,
      ! de certeza nao sao primos
      lista = .true.

      PRINT *, "Os numeros primos ate", limite_superior, "sao"

      DO numero = 2, limite_superior
         IF( lista(numero) )THEN
            PRINT *, numero ! Escreve os numeros nao "riscados" da lista
            DO multiplos = numero + numero, limite_superior, numero
               lista(multiplos) = .false. ! "Risca" os multiplos deste da lista
            END DO
         END IF
      END DO
   END SUBROUTINE
END PROGRAM crivo


      INTEGER*8 FUNCTION SUMI(N)	!Sums the integers 1 to N inclusive.
Calculates as per the young Gauss: N*(N + 1)/2 = 1 + 2 + 3 + ... + N.
       INTEGER*8 N	!The number. Possibly large.
        IF (MOD(N,2).EQ.0) THEN	!So, I'm worried about overflow with N*(N + 1)
          SUMI = N/2*(N + 1)		!But since N is even, N/2 is good.
         ELSE			!Otherwise, if N is odd,
          SUMI = (N + 1)/2*N		!(N + 1) must be even.
        END IF			!Either way, the /2 reduces the result.
      END FUNCTION SUMI		!So overflow of intermediate results is avoided.

      INTEGER*8 FUNCTION SUMF(N,F)	!Sum of numbers up to N divisible by F.
       INTEGER*8 N,F		!The selection.
       INTEGER*8 L		!The last in range. N itself is excluded.
       INTEGER*8 SUMI		!Known type of the function.
        L = (N - 1)/F		!Truncates fractional parts.
        SUMF = F*SUMI(L)	!3 + 6 + 9 + ... = 3(1 + 2 + 3 + ...)
      END FUNCTION SUMF		!Could just put SUMF = F*SUMI((N - 1)/F).

      INTEGER*8 FUNCTION SUMBFI(N)	!Brute force and ignorance summation.
       INTEGER*8 N	!The number.
       INTEGER*8 I,S	!Stepper and counter.
        S = 0		!So, here we go.
        DO I = 3,N - 1	!N itself is not a candidate.
          IF (MOD(I,3).EQ.0 .OR. MOD(I,5).EQ.0) S = S + I	!Whee!
        END DO		!On to the next.
        SUMBFI = S		!The result.
      END FUNCTION SUMBFI	!Oh well, computers are fast these days.

      INTEGER*8 SUMF,SUMBFI	!Known type of the function.
      INTEGER*8 N	!The number.
      WRITE (6,*) "Sum multiples of 3 and 5 up to N"
   10 WRITE (6,11)		!Ask nicely.
   11 FORMAT ("Specify N: ",$)	!Obviously, the $ says 'stay on this line'.
      READ (5,*) N		!If blank input is given, further input will be requested.
      IF (N.LE.0) STOP		!Good enough.
      WRITE (6,*) "By Gauss:",SUMF(N,3) + SUMF(N,5) - SUMF(N,15)
      WRITE (6,*) "BFI sum :",SUMBFI(N)		!This could be a bit slow.
      GO TO 10			!Have another go.
      END	!So much for that.


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

PROGRAM Bisection_Method
    USE precision
    IMPLICIT NONE

    REAL(KIND = dp):: x0, x1, x2, f0, f1, f2, error, root
    WRITE(*, *) "Enter value of interval (a and b)"
    ! For this question enter [0.5, 2.0]
    READ *, x1, x2

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

    IF (f1*f2 .GT. 0.0) THEN
        WRITE(*, *) "Given interval do not bracket any root"
        RETURN
    ENDIF

    DO
        x0 = (x1 + x2) / 2.0_dp
        f0 = Func(x0)

        IF (f0 .EQ. 0.0) THEN
            root = x0
            WRITE(*, *) "Root is: ", root
            RETURN
        ENDIF

        IF(f1 * f0 .LT. 0.0_dp) THEN
            x2 = x0
        ELSE
            x1 = x0
        ENDIF

        IF (abs((x2 - x1)/x2) .LT. error) THEN
            root = (x1 + x2) / 2.0_dp
            WRITE(*, *) "Root is: ", root
            RETURN
        ENDIF
    ENDDO

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

END PROGRAM Bisection_Method

Roots of Nonlinear Equation/Bisection Method.f90


      ! calculate inverse matrix
      SUBROUTINE calcInverse(dim,mat,invMat)
      IMPLICIT NONE
      INTEGER dim,i,j
      DOUBLE PRECISION mat(dim,dim),invMat(dim,dim),bufMat(dim,dim),buf
      bufMat(:,:) = mat(:,:)
      invMat(:,:) = 0.0D0
      DO i=1,dim
        invMat(i,i) = 1.0D0
      END DO
      DO i=1,dim
        buf = 1.0D0/mat(i,i)
        mat(i,:) = mat(i,:)*buf
        invMat(i,:) = invMat(i,:)*buf
        DO j=1,dim
          IF (i/=j) THEN
            buf = mat(j,i)
            mat(j,:) = mat(j,:) - mat(i,:)*buf
            invMat(j,:) = invMat(j,:) - invMat(i,:)*buf
          END IF
        END DO
      END DO
      mat(:,:) = bufMat(:,:)
      RETURN
      END SUBROUTINE calcInverse

      ! calculate invariants of stress tensor
      SUBROUTINE calcInvariants(stress,invariants)
      DOUBLE PRECISION stress(6),invariants(2)
      invariants(1) = (stress(1) + stress(2) + stress(3))/3.0D0
      invariants(2) = (stress(4)**2 + stress(5)**2 + stress(6)**2 -
     & stress(1)*stress(2) - stress(2)*stress(3) -
     & stress(3)*stress(1))/3.0D0
      RETURN
      END SUBROUTINE calcInvariants

      ! calculate principal value of matrix
      SUBROUTINE calcPrincipal(mat,principal,invariants)
      DOUBLE PRECISION mat(3,3),principal(3),invariants(3),radius,
     & theta,PI
      PI = acos(-1.0D0)
      principal(:) = 0.0D0
      invariants(:) = 0.0D0
      DO i=1,3
        invariants(1) = invariants(1) + mat(i,i)/3.0D0
      END DO
      invariants(2) = (mat(2,3)**2 + mat(3,1)**2 + mat(1,2)**2 -
      & mat(2,2)*mat(3,3) - mat(3,3)*mat(1,1) - mat(1,1)*mat(2,2))/3.0D0
      invariants(3) = (2*mat(1,2)*mat(2,3)*mat(3,1) +
      & mat(1,1)*mat(2,2)*mat(3,3) - mat(1,1)*mat(2,3)**2 -
      & mat(2,2)*mat(3,1)**2 - mat(3,3)*mat(1,2)**2)/2.0D0
      radius = 2*sqrt(invariants(1)**2 + invariants(2))
      theta = acos(((2*invariants(1)**3 + 3*invariants(1)*
      & invariants(2) + 2*invariants(3))/2.0D0)/
      & sqrt((invariants(1)**2 + invariants(2))**3))
      principal(1) = radius*cos(theta/3.0D0) + invariants(1)
      principal(2) = radius*cos((theta + 4*PI)/3.0D0) + invariants(1)
      principal(3) = radius*cos((theta + 2*PI)/3.0D0) + invariants(1)
      RETURN
      END SUBROUTINE calcPrincipal

      ! enable using same random seed, this func is just a memo
      FUNCTION random()
      DOUBLE PRECISION x
      INTEGER seedsize,seed
      ALLOCATABLE seed(:)
      CALL RANDOM_SEED(size=seedsize)
      ALLOCATE(seed(seedsize))
      CALL RANDOM_SEED(get=seed)
      CALL RANDOM_NUMBER(x)
      WRITE(*,*) x
      ! CALL sleep(1)
      CALL RANDOM_SEED(put=seed)
      CALL RANDOM_NUMBER(x)
      WRITE(*,*) x
      END FUNCTION random

      ! sort list in descending order
      RECURSIVE SUBROUTINE quickSort(vec, first, last)
      IMPLICIT NONE
      INTEGER first,last,i,j
      DOUBLE PRECISION  vec(*),x,t
      x = vec( (first+last) / 2 )
      i = first
      j = last
      DO
        DO WHILE (vec(i) > x)
          i=i+1
        END DO
        DO WHILE (x > vec(j))
          j=j-1
        END DO
        IF (i >= j) EXIT
        t = vec(i)
        vec(i) = vec(j)
        vec(j) = t
        i=i+1
        j=j-1
      END DO
      IF (first < i - 1) THEN
        CALL quicksort(vec, first, i - 1)
      END IF
      IF (j + 1 < last) THEN
        CALL quicksort(vec, j + 1, last)
      END IF
      END SUBROUTINE quickSort


program composite_trapezoidal
    ! Author : Anantha S Rao (Reg no : 20181044)
    ! Program to evaluate the integral I = Int_a^b Gaus(0,1)
    implicit none
    real*8,external::func
    ! An external function f in double precision

    real*8::a,b,h,pi,trapezoidal_integral
    ! a : Lower limit of the integral
    ! b : Upper limit of the integral
    ! h : bin size
    ! trapezoidal_integral : Value of the integral using trapezoidal technique

    integer::n,i
    ! n : number of bins
    ! i : counter

    pi= 2.0d0*ASIN(1.0d0)
    n = 1000
    print 10, n
    10 format("Welcome to this program. &
         & This program does integration on I= Int_a^b Gaus(0,1) using trapezoidal rule with n=",i5," bins" )

    a = -3
    b = 3
    h=(b-a)/real(n)   ! size of each bin
    trapezoidal_integral=(h/2)*(func(a)+func(b))
    do i=1,n-1
        trapezoidal_integral=trapezoidal_integral+h*func(a+i*h)
    end do
    print *, "The integrated value using trapezoidal rule in (-3,3) is:",trapezoidal_integral

    a = -5
    b = 5
    h=(b-a)/real(n)   ! size of each bin
    trapezoidal_integral=(h/2)*(func(a)+func(b))
    do i=1,n-1
        trapezoidal_integral=trapezoidal_integral+h*func(a+i*h)
    end do
    print *, "The integrated value using trapezoidal rule in (-5,5) is:",trapezoidal_integral

end program composite_trapezoidal

real*8 function func(x)
    implicit none
    real*8::x, pi
    pi= 2.0d0*ASIN(1.0d0)
    func= (1.0d0/SQRT(2.0d0*pi))*EXP(-(x*x)/2.0d0)
end function


module numinteg
	interface
		function simpson(H, FI) result (S)
			use kind_defs
			implicit none
			real(dbl), intent(in) :: H
			real(dbl), intent(in) :: FI(:)
			real(dbl) :: S
		end function
	end interface
end module

! Subroutine for integration over f(x) with the Simpson rule.
! FI: integrand f(x); H: interval; S: integral. Copyright (c) Tao Pang 1997.
function simpson(H, FI) result (S)
	use kind_defs
	implicit none
	real(dbl), intent(in) :: H
	real(dbl), intent(in) :: FI(:)
	real(dbl) :: S
	integer :: i, N
	real(dbl) :: S0,S1,S2

	N = size(FI)
	S  = 0.0_dbl
	S0 = 0.0_dbl
	S1 = 0.0_dbl
	S2 = 0.0_dbl
	do i = 2,N-1,2
		S1 = S1 + FI(i-1)
		S0 = S0 + FI(i)
		S2 = S2 + FI(i+1)
	enddo
	S = H*(S1+4.0_dbl*S0+S2)/3.0_dbl

	! If N is even, add the last slice separately
	if (mod(N,2) .eq. 0) then
		S = S + H*(5.0_dbl*FI(N)+8.0_dbl*FI(N-1)-FI(N-2))/12.0_dbl
	endif
end function simpson


module quadrature

    implicit none

    integer :: quadrature_type = 1
    real(kind=8) :: quadrature_relerr = 1e-6
    integer :: gaussorder = 12

    contains

    function gaussquad(func,n,a,b,tid) result(z)
        !
        ! This function computes the indefinite integral of the function func
        ! from a to b using an n-point Gauss-Legendre quadrature algorithm.
        !
        ! This function is thread-safe.
        !
        ! The function func must be an external function which takes two arguments:
        !          func(x, tid)
        ! where x is a ready kind-8 and tid is an integer. Typically tid is used
        ! for accessing data unique to a thread, available in shared memory.
        !
        ! This function is modified from its original form found on Rosettacode.org:
        !     https://rosettacode.org
        !     https://rosettacode.org/wiki/Numerical_integration/Gauss-Legendre_Quadrature
        ! which is freely available under GNU free documentation license 1.2.
        !
        implicit none

        real (kind=8), external :: func
        integer, parameter :: p=8
        integer                 :: n
        real(kind=p), parameter :: pi = 4*atan(1._p)
        real(kind=p)            :: r(2, n), x, f, df, dx
        integer                 :: i,  iter, k
        real (kind = p) :: pc0(n+1), pc1(n+1), pctmp(n+1)
        real(kind=p)            :: z, a, b, zsum, vv
        integer tid

        pc0(1) = 1._p
        pc1(1:2) = [1._p, 0._p]
        do k = 2, n
            pctmp(1:k+1) = ((2*k-1)*[pc1(1:k),0._p]-(k-1)*[0._p, 0._p,pc0(1:k-1)])/k
            pc0 = pc1; pc1 = pctmp
        end do
        do i = 1, n
            x = cos(pi*(i-0.25_p)/(n+0.5_p))
            do iter = 1, 10
                f = pc1(1); df = 0._p
                do k = 2, size(pc1)
                    df = f + x*df
                    f  = pc1(k) + x * f
                end do
                dx =  f / df
                x = x - dx
                if (abs(dx)<10*epsilon(dx)) exit
            end do
            r(1,i) = x
            r(2,i) = 2/((1-x**2)*df**2)
        end do

        zsum = 0._p
        do i = 1, n
            vv = (a+b)/2 + r(1,i)*(b-a)/2
            zsum = zsum + r(2,i) * func(vv, tid)
        end do

        z = (b-a)/2 * zsum

    end function

    function g8(func, x, h, tid)

        implicit none
        real ( kind = 8 ), external :: func
        real ( kind = 8 ) h
        real ( kind = 8 ) x
        integer tid

        real (kind = 8 ) :: g8

        real ( kind = 8 ) :: w1 = 3.62683783378361983D-01
        real ( kind = 8 ) :: w2 = 3.13706645877887287D-01
        real ( kind = 8 ) :: w3 = 2.22381034453374471D-01
        real ( kind = 8 ) :: w4 = 1.01228536290376259D-01
        real ( kind = 8 ) :: x1 = 1.83434642495649805D-01
        real ( kind = 8 ) :: x2 = 5.25532409916328986D-01
        real ( kind = 8 ) :: x3 = 7.96666477413626740D-01
        real ( kind = 8 ) :: x4 = 9.60289856497536232D-01

        g8 = h * ( ( &
                    w1 * ( func ( x - x1 * h, tid ) + func ( x + x1 * h, tid ) )   &
                  + w2 * ( func ( x - x2 * h, tid ) + func ( x + x2 * h, tid ) ) ) &
                + ( w3 * ( func ( x - x3 * h, tid ) + func ( x + x3 * h, tid ) )   &
                  + w4 * ( func ( x - x4 * h, tid ) + func ( x + x4 * h, tid ) ) ) )

    end function g8

    subroutine gaus8_threadsafe ( func, a, b, err, result, ierr, tid )

    !*****************************************************************************80
    !
    !! GAUS8 estimates the integral of a function.
    !   Modified by O. Gorton c. May 2021 for use with openMP.
    !
    !  Discussion:
    !
    !    GAUS8 integrates real functions of one variable over finite
    !    intervals using an adaptive 8-point Legendre-Gauss
    !    algorithm.
    !
    !    GAUS8 is intended primarily for high accuracy integration or
    !    integration of smooth functions.
    !
    !  Modified:
    !
    !    30 October 2000
    !
    !  Author:
    !
    !    Ron Jones,
    !    Sandia National Laboratory,
    !    Los Alamos, New Mexico
    !
    !  Reference:
    !
    !    Philip Davis, Philip Rabinowitz,
    !    Methods of Numerical Integration,
    !    Second Edition,
    !    Dover, 2007,
    !    ISBN: 0486453391,
    !    LC: QA299.3.D28.
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ), external FUNC, name of external function to
    !    be integrated.  This name must be in an external statement in the
    !    calling program.  FUNC must be a function of one real argument.  The value
    !    of the argument to FUNC is the variable of integration
    !    which ranges from A to B.
    !
    !    Input, real ( kind = 8 ) A, the lower limit of integration.
    !
    !    Input, real ( kind = 8 ) B, the upper limit of integration.
    !
    !    Input/output, real ( kind = 8 ) ERR.
    !    On input, ERR is a requested pseudorelative error
    !    tolerance.  Normally pick a value of ABS ( ERR ) so that
    !    STOL < ABS ( ERR ) <= 1.0D-3 where STOL is the single precision
    !    unit roundoff.
    !    RESULT will normally have no more error than
    !    ABS ( ERR ) times the integral of the absolute value of
    !    FUN(X).  Usually, smaller values for ERR yield more
    !    accuracy and require more function evaluations.
    !    A negative value for ERR causes an estimate of the
    !    absolute error in RESULT to be returned in ERR.  Note that
    !    ERR must be a variable (not a constant) in this case.
    !    Note also that the user must reset the value of ERR
    !    before making any more calls that use the variable ERR.
    !    On output, ERR will be an estimate of the absolute error
    !    in RESULT if the input value of ERR was negative.  ERR is
    !    unchanged if the input value of ERR was non-negative.
    !    The estimated error is solely for information to the user
    !    and should not be used as a correction to the computed integral.
    !
    !    Output, real ( kind = 8 ) RESULT, the computed value of the integral.
    !
    !    Output, integer ( kind = 4 ) IERR, a status code.
    !    Normal Codes:
    !     1 RESULT most likely meets requested error tolerance, or A = B.
    !    -1 A and B are too nearly equal to allow normal
    !        integration.  RESULT is set to zero.
    !     Abnormal Code:
    !     2 RESULT probably does not meet requested error tolerance.
    !
    !    input, real arg : extra argument for func
      implicit none

      real ( kind = 8 ) a
      real ( kind = 8 ) aa(30)
      real ( kind = 8 ) ae
      real ( kind = 8 ) anib
      real ( kind = 8 ) area
      real ( kind = 8 ) b
      real ( kind = 8 ) c
      real ( kind = 8 ) ce
      real ( kind = 8 ) ee
      real ( kind = 8 ) ef
      real ( kind = 8 ) eps
      real ( kind = 8 ) err
      real ( kind = 8 ) est
      real ( kind = 8 ), external :: func
      real ( kind = 8 ) gl
      real ( kind = 8 ) glr
      real ( kind = 8 ) gr(30)
      real ( kind = 8 ) hh(30)
      integer ( kind = 4 ), save :: icall = 0
      integer ( kind = 4 ) ierr
      integer ( kind = 4 ) k
      integer ( kind = 4 ), save :: kml = 6
      integer ( kind = 4 ), save :: kmx = 5000
      integer ( kind = 4 ) l
      integer ( kind = 4 ) lmn
      integer ( kind = 4 ) lmx
      integer ( kind = 4 ) lr(30)
      integer ( kind = 4 ) mxl
      integer ( kind = 4 ) nbits
      integer ( kind = 4 ) nib
      integer ( kind = 4 ), save :: nlmn = 1
      integer ( kind = 4 ) nlmx
      real ( kind = 8 ) result
      real ( kind = 8 ) tol
      real ( kind = 8 ) vl(30)
      real ( kind = 8 ) vr

      integer tid

      if ( a == b ) then
        err = 0.0D+00
        result = 0.0D+00
        return
      end if

    ! OCG: this error trap is no longer relevant. It prevents revursive i
    ! calling, which happens to occur in parallel execution.
    !  if ( icall /= 0 ) then
    !    write ( *, '(a)' ) ' '
    !    write ( *, '(a)' ) 'GAUS8 - Fatal error!'
    !    write ( *, '(a)' ) '  GAUS8 was called recursively.'
    !    stop 1
    !  end if

      icall = 1
    !
    !  DIGITS ( X ) = number of base 2 digits in representation of X.
    !
      k = digits ( result )

      anib = log10 ( 2.0D+00 ) * real ( k, kind = 8 ) / 0.30102000D+00
      nbits = int ( anib )
      nlmx = min ( 30, ( nbits * 5 ) / 8 )
      result = 0.0D+00
      ierr = 1
      ce = 0.0D+00
      result = 0.0D+00
      lmx = nlmx
      lmn = nlmn

      if ( b /= 0.0D+00 ) then

        if ( sign ( 1.0D+00, b ) * a <= 0.0D+00 ) then
          go to 10
        end if

        c = abs ( 1.0D+00 - a / b )
        if ( 0.1D+00 < c ) then
          go to 10
        end if

        if ( c <= 0.0D+00 ) then
          icall = 0
          if ( err < 0.0D+00 ) then
            err = ce
          end if
          return
        end if

        anib = 0.5D+00 - log ( c ) / 0.69314718D+00
        nib = int ( anib )
        lmx = min ( nlmx, nbits-nib-7 )

        if ( lmx < 1 ) then
          ierr = -1
          write ( *, '(a)' ) ' '
          write ( *, '(a)' ) 'GAUS8 - Warning!'
          write ( *, '(a)' ) '  A and B are too close to carry out integration.'
          icall = 0
          if ( err < 0.0D+00 ) then
            err = ce
          end if
          return
        end if

        lmn = min ( lmn, lmx )

      end if

    10    continue

      tol = max ( abs ( err ), 2.0D+00**(5-nbits)) / 2.0D+00
      if ( err == 0.0D+00 ) then
        tol = sqrt ( epsilon ( 1.0D+00 ) )
      end if

      eps = tol
      hh(1) = ( b - a ) / 4.0D+00
      aa(1) = a
      lr(1) = 1
      l = 1
      est = g8 (func, aa(l) + 2.0D+00 * hh(l), 2.0D+00 * hh(l), tid )
      k = 8
      area = abs ( est )
      ef = 0.5D+00
      mxl = 0
    !
    !  Compute refined estimates, estimate the error, etc.
    !
    20 continue

      gl = g8 (func, aa(l) + hh(l), hh(l), tid )
      gr(l) = g8 (func, aa(l) + 3.0D+00 * hh(l), hh(l), tid )
      k = k + 16
      area = area + ( abs ( gl ) + abs ( gr(l) ) - abs ( est ) )

      glr = gl + gr(l)
      ee = abs ( est - glr ) * ef
      ae = max ( eps * area, tol * abs ( glr ) )

      if ( ee - ae <= 0.0D+00 ) then
        go to 40
      else
        go to 50
      end if

    30 continue

      mxl = 1

    40 continue

      ce = ce + ( est - glr )

      if ( lr(l) <= 0 ) then
        go to 60
      else
        go to 80
      end if
    !
    !  Consider the left half of this level
    !
    50 continue

      if ( kmx < k ) then
        lmx = kml
      end if

      if ( lmx <= l ) then
        go to 30
      end if

      l = l + 1
      eps = eps * 0.5D+00
      ef = ef / sqrt ( 2.0D+00 )
      hh(l) = hh(l-1) * 0.5D+00
      lr(l) = -1
      aa(l) = aa(l-1)
      est = gl
      go to 20
    !
    !  Proceed to right half at this level
    !
    60 continue

      vl(l) = glr

    70 continue

      est = gr(l-1)
      lr(l) = 1
      aa(l) = aa(l) + 4.0D+00 * hh(l)
      go to 20
    !
    !  Return one level
    !
    80 continue

      vr = glr

    90 continue

      if ( l <= 1 ) then
        go to 120
      end if

      l = l - 1
      eps = eps * 2.0D+00
      ef = ef * sqrt ( 2.0D+00 )

      if ( lr(l) <= 0 ) then
        vl(l) = vl(l+1) + vr
        go to 70
      else
        vr = vl(l+1) + vr
        go to 90
      end if
    !
    !  Exit
    !
    120   continue

      result = vr

      if ( mxl == 0 .or. abs ( ce ) <= 2.0D+00 * tol * area ) then
        icall = 0
        if ( err < 0.0D+00 ) then
          err = ce
        end if
        return
      end if

      ierr = 2
      write ( *, '(a)' ) ' '
      write ( *, '(a)' ) 'GAUS8 - Warning!'
      write ( *, '(a)' ) '  RESULT is probably insufficiently accurate.'
      icall = 0

      if ( err < 0.0D+00 ) then
        err = ce
      end if

      return
    end subroutine gaus8_threadsafe

!.............................................Boole's rule
      subroutine boole(N,arr,dx,ans)
!INPUT:
!       N: DIMENSION OF FUNCTION ARRAY
!     arr: ARRAY OF FUNCTION VALUES TO BE INTEGRATED
!      dx: STEP SIZE OF FUNCTION VALUES
!OUTPUT:
!     ans: DEFINITE INTEGRAL OF FUNCTION ARRAY FROM BOOLES RULE
!CALLS:
!     NONE
!
      implicit none
      integer N, i, m
      real(kind=8) arr(N),ans
      integer x0
      real(kind=8) dboole, boole_out,dx

      m = N/4
      boole_out = 0

      do i = 1, m-1, 1
        x0 = 4*i
        dboole = ( 7d0*arr(x0+4) &
                   + 32d0*arr(x0+3) &
                   + 12d0*arr(x0+2) &
                   + 32d0*arr(x0+1) &
                   + 7d0*arr(x0) )
        boole_out = boole_out + dboole
      enddo

      ans=dx*(2d0/45d0)*boole_out

      end subroutine

end module quadrature


program tarefaa
    implicit real*8 (a-h,o-z)

    dimension h(14)

    ! Funções exatas
    f(x) = sinh(2*x)*sin(x/4)
    df(x) = 2*cosh(2*x)*sin(x/4) + cos(x/4)*sinh(2*x)/4
    d2f(x) = cos(x/4)*cosh(2*x) + 63*sin(x/4)*sinh(2*x)/16
    d3f(x) = 61*cosh(2*x)*sin(x/4)/8 + 191*cos(x/4)*sinh(2*x)/64

    ! Funções aproximaximadas
    dfrente2p(x, h_i) = ( f(x+h_i) - f(x) ) / h_i
    dtras2p(x, h_i) = ( f(x) - f(x-h_i) ) / h_i
    dsimetrica3p(x, h_i) = ( f(x+h_i) - f(x-h_i) ) / ( 2*h_i )
    dsimetrica5p(x, h_i) = ( f(x-2*h_i) -8*f(x-h_i) +8*f(x+h_i) -f(x+2*h_i) ) / ( 12*h_i )
    d2simetrica5p(x, h_i) = ( -f(x-2*h_i) +16*f(x-h_i) -30*f(x) +16*f(x+h_i) -f(x+2*h_i) ) / ( 12*h_i**2 )
    d3antisimetrica5p(x, h_i) = ( -f(x-2*h_i) +2*f(x-h_i) -2*f(x+h_i) +f(x+2*h_i) ) / ( 2*h_i**3 )

    ! vetor com os valor de h
    h = (/0.5, 0.2, 0.1, 0.05, 0.01, 0.005, 0.001, 0.0005, 0.0001, 0.00005, 0.00001, 0.000001, 0.0000001, 0.00000001/)

    ! Arquivo de saida
    open(10, file='saida-a-10407962')

    ! x para calcular a derivada
    x = 1d0

    ! valor de cada derivada analitica
    df_x  = df(x)
    d2f_x = d2f(x)
    d3f_x = d3f(x)

    ! loop para alterar o valor de h
    do i = 1, 14

        ! desvio de cada método
        erro1 = abs(dfrente2p(x, h(i)) - df_x)
        erro2 = abs(dtras2p(x, h(i)) - df_x)
        erro3 = abs(dsimetrica3p(x, h(i)) - df_X)
        erro4 = abs(dsimetrica5p(x, h(i)) - df_x)
        erro5 = abs(d2simetrica5p(x, h(i)) - d2f_x)
        erro6 = abs(d3antisimetrica5p(x, h(i)) - d3f_x)

        ! escreve no arquivo de saida
        write(10,*) h(i), erro1, erro2, erro3, erro4, erro5, erro6
    end do

    ! escreve na tela os valores exatos
    write(*,'(A,F0.11)') 'df/dx: ', df_x
    write(*,'(A,F0.11)') 'd^2f/dx^2: ', d2f_x
    write(*,'(A,F0.11)') 'd^3f/dx^3: ', d3f_x

end program tarefaa


PROGRAM decay_chain

! The following line below may be used to compile this program:
! gfortran -o decay_chain decay_chain.f -ffree-form

implicit none

integer, parameter :: max_size = 2000
integer, parameter :: output = 7
integer :: i
real :: hl_1,hl_2
real :: lambda_1,lambda_2
real :: N_0
real :: time(max_size)
real :: N_1_pop(max_size)
real :: N_2_pop(max_size)
real :: N_3_pop(max_size)
real, dimension(max_size,4) :: results

!Prompts the user for the half lives of parent and daughter and then reads them in
write (*,*) 'Enter half lives of parent and daughter nuclei (in days): '
read (*,*) hl_1, hl_2

!Prints back out user specified info for reference
write (*,*) 'The half lives are: ', hl_1, ' days and ', hl_2, ' days'

!Initializes initial population of parent nuclide
N_0 = 1E6
!Calulates the lambdas of the parent and daughter in inverse seconds
lambda_1 = log(2.)/(hl_1*24.*60.*60.)
lambda_2 = log(2.)/(hl_2*24.*60.*60.)

!Creates time array of 3600 second (1 hour) increments
do i = 1, max_size
	time(i) = (i-1)*3600.
end do
!Creates array of parent population using expression from README.md file
do i = 1, max_size
	N_1_pop(i) = N_0 * exp(-1.*lambda_1*time(i))
end do
!Creates array of daughter population using expression from README.md file
do i = 1, max_size
	N_2_pop(i) = ((lambda_1*N_0)/(lambda_2 - lambda_1)) * (exp(-1.*lambda_1*time(i)) - exp(-1.*lambda_2*time(i)))
end do
!Creates array of granddaughter population using expression from README.md file
do i = 1, max_size
	N_3_pop(i) = (N_0/(lambda_2 - lambda_1)) * ((lambda_2*(1. - exp(-1.*lambda_1*time(i)))) &
	-(lambda_1 *(1. - exp(-1.*lambda_2*time(i)))))
end do

!Fills each column of the results array with time and populations
results(:,1) = time(:)
results(:,2) = N_1_pop(:)
results(:,3) = N_2_pop(:)
results(:,4) = N_3_pop(:)

!Opening a CSV file for preparation of outputting the numbers from results array
open(unit=output,file='OUTPUT.csv')
!Writes out the first line of the CSV file which will just be the lables for the columns
write(output, '(a12,",",a17,",",a19,",",a24)') 'Time_(hours)', 'Parent_Population', 'Daughter_Population', &
     'Granddaughter_Population'
!Iterates through the results array and writes out each row
do i = 1, max_size
    write(output, '(f0.0,",",f0.4,",",f0.4,",",f0.4)') results(i,1)/3600., results(i,2), results(i,3), results(i,4)
end do

!Closes the CSV file
close (output)

!Ends the program
END PROGRAM decay_chain


RECURSIVE SUBROUTINE factorial(n, result)
IMPLICIT NONE
INTEGER, INTENT(IN) :: n
INTEGER, INTENT(OUT) :: result
INTEGER :: temp

IF (n >= 1) THEN
  CALL factorial(n-1, temp)
  result = n * temp
ELSE
  result = 1
END IF
END SUBROUTINE factorial

RECURSIVE FUNCTION fact(n) RESULT(answer)
IMPLICIT NONE
INTEGER, INTENT(IN) :: n
INTEGER :: answer
IF (n >= 1) THEN
  answer = n * fact(n-1)
ELSE
  answer = 1
END IF
END FUNCTION fact

PROGRAM test_factorial
IMPLICIT NONE
INTEGER :: i, facto
INTEGER :: fact
WRITE(*, *) "Enter an integer to calculate its factorial:"
READ(*, *) i
CALL factorial(i, facto)
WRITE(*, '(I0,A,I0)') i, "! = ", facto
WRITE(*, '(I0,A,I0)') i, "! = ", fact(i)
END PROGRAM test_factorial


  MODULE RDistributions
! Inspired from: http://www.johndcook.com/julia_rng.html
! Original author in julia : John D Cook
! coded : Sukhbinder in fortran
! Date : 28th Feb 2012
!

!
! Non uniform random Number Generators in Fortran
!
      DOUBLE PRECISION, PARAMETER :: PI=3.141592653589793238462
      CONTAINS

      FUNCTION rand_uniform(a,b) RESULT(c)
       DOUBLE PRECISION :: a,b,c,temp
       CALL RANDOM_NUMBER(temp)
       c= a+temp*(b-a)
      END FUNCTION

!
! Random Sample from normal (Gaussian) distribution
!
      FUNCTION rand_normal(mean,stdev) RESULT(c)
       DOUBLE PRECISION :: mean,stdev,c,temp(2)

      IF(stdev <= 0.0d0) THEN

        WRITE(*,*) "Standard Deviation must be +ve"
      ELSE
        CALL RANDOM_NUMBER(temp)
        r=(-2.0d0*log(temp(1)))**0.5
        theta = 2.0d0*PI*temp(2)
        c= mean+stdev*r*sin(theta)
      END IF
      END FUNCTION

!
! Random smaple from an exponential distribution
!
      FUNCTION rand_exponential(mean) RESULT(c)
      DOUBLE PRECISION :: mean,c,temp
      IF (mean <= 0.0d0) THEN

        WRITE(*,*) "mean must be positive"
      ELSE
       CALL RANDOM_NUMBER(temp)
       c=-mean*log(temp)
      END IF
      END FUNCTION

!
! Return a random sample from a gamma distribution
!
      RECURSIVE FUNCTION rand_gamma(shape, SCALE) RESULT(ans)
      DOUBLE PRECISION SHAPE,scale,u,w,d,c,x,xsq,g
      IF (shape <= 0.0d0) THEN

        WRITE(*,*) "Shape PARAMETER must be positive"
      END IF
      IF (scale <= 0.0d0) THEN

        WRITE(*,*) "Scale PARAMETER must be positive"
      END IF
!
! ## Implementation based on "A Simple Method for Generating Gamma Variables"
! ## by George Marsaglia and Wai Wan Tsang.
! ## ACM Transactions on Mathematical Software

! ## Vol 26, No 3, September 2000, pages 363-372.
!
      IF (shape >= 1.0d0) THEN
        d = SHAPE - 1.0d0/3.0d0
        c = 1.0d0/(9.0d0*d)**0.5
        DO while (.true.)
            x = rand_normal(0.0d0, 1.0d0)
            v = 1.0 + c*x
            DO while (v <= 0.0d0)
                x = rand_normal(0.0d0, 1.0d0)
                v = 1.0d0 + c*x
            END DO

            v = v*v*v
            CALL RANDOM_NUMBER(u)
            xsq = x*x
            IF ((u < 1.0d0 -.0331d0*xsq*xsq) .OR.  &
              (log(u) < 0.5d0*xsq + d*(1.0d0 - v + log(v))) )then
                ans=scale*d*v
                RETURN
            END IF

        END DO
      ELSE
        g = rand_gamma(shape+1.0d0, 1.0d0)
        CALL RANDOM_NUMBER(w)
        ans=scale*g*(w)**(1.0d0/shape)
        RETURN
      END IF

      END FUNCTION
!
! ## return a random sample from a chi square distribution
! ## with the specified degrees of freedom
!
      FUNCTION rand_chi_square(dof) RESULT(ans)
      DOUBLE PRECISION ans,dof
         ans=rand_gamma(0.5d0, 2.0d0*dof)
      END FUNCTION

!
! ## return a random sample from an inverse gamma random variable
!
      FUNCTION rand_inverse_gamma(shape, SCALE) RESULT(ans)
      DOUBLE PRECISION SHAPE,scale,ans

! ## If X is gamma(shape, scale) then
! ## 1/Y is inverse gamma(shape, 1/scale)
      ans= 1.0d0 / rand_gamma(shape, 1.0d0 / SCALE)
      END FUNCTION
!
!## return a sample from a Weibull distribution
!

      FUNCTION rand_weibull(shape, SCALE) RESULT(ans)
      DOUBLE PRECISION SHAPE,scale,temp,ans
      IF (shape <= 0.0d0) THEN

        WRITE(*,*) "Shape PARAMETER must be positive"
      END IF
      IF (scale <= 0.0d0) THEN

        WRITE(*,*) "Scale PARAMETER must be positive"
      END IF
      CALL RANDOM_NUMBER(temp)
      ans= SCALE * (-log(temp))**(1.0 / SHAPE)
      END FUNCTION

!
!## return a random sample from a Cauchy distribution
!
      FUNCTION rand_cauchy(median, SCALE) RESULT(ans)
      DOUBLE PRECISION ans,median,scale,p

      IF (scale <= 0.0d0) THEN

        WRITE(*,*) "Scale PARAMETER must be positive"
      END IF
      CALL RANDOM_NUMBER(p)
      ans = median + SCALE*tan(PI*(p - 0.5))
      END FUNCTION

!
!## return a random sample from a Student t distribution
!
      FUNCTION rand_student_t(dof) RESULT(ans)
      DOUBLE PRECISION ans,dof,y1,y2
      IF (dof <= 0.d0) THEN

        WRITE(*,*) "Degrees of freedom must be positive"
      END IF
!
! ## See Seminumerical Algorithms by Knuth
      y1 = rand_normal(0.0d0, 1.0d0)
      y2 = rand_chi_square(dof)
      ans= y1 / (y2 / DOf)**0.50d0
!

      END FUNCTION

!
!## return a random sample from a Laplace distribution
!## The Laplace distribution is also known as the double exponential distribution.
!
      FUNCTION rand_laplace(mean, SCALE)  RESULT(ans)
      DOUBLE PRECISION ans,mean,scale,u
      IF (scale <= 0.0d0) THEN

        WRITE(*,*) "Scale PARAMETER must be positive"
      END IF
      CALL RANDOM_NUMBER(u)
      IF (u < 0.5d0) THEN

        ans = mean + SCALE*log(2.0*u)
      ELSE
        ans = mean - SCALE*log(2*(1-u))
      END IF

      END FUNCTION

!
! ## return a random sample from a log-normal distribution
!
      FUNCTION rand_log_normal(mu, sigma) RESULT(ans)
      DOUBLE PRECISION ans,mu,sigma
        ans= EXP(rand_normal(mu, sigma))
      END FUNCTION

!
! ## return a random sample from a beta distribution
!
      FUNCTION rand_beta(a, b) RESULT(ans)
      DOUBLE PRECISION a,b,ans,u,v
      IF ((a <= 0.0d0) .OR. (b <= 0.0d0)) THEN

        WRITE(*,*) "Beta PARAMETERs must be positive"
      END IF

! ## There are more efficient methods for generating beta samples.
! ## However such methods are a little more efficient and much more complicated.
! ## For an explanation of why the following method works, see
! ## http://www.johndcook.com/distribution_chart.html#gamma_beta

       u = rand_gamma(a, 1.0d0)
       v = rand_gamma(b, 1.0d0)
       ans = u / (u + v)
      END FUNCTION

END MODULE


module SpherHarm
  !! Functions related to spherical harmonics
  implicit none
contains

complex(8) function SpherHarmSpecial(l,m,un)
  !! Ylm as a function of position vector
  integer,intent(in) :: l, m
  real(8),intent(in) :: un(3)
  real(8), parameter :: PI=3.14159265358979D0
  integer :: i,fact,mm
  real(8) ::  phi
  mm=abs(m)

  fact=1
  do i=l+mm,l-mm+1,-1
     fact=fact*i
  end do

  phi=atan2(un(2),un(1))

  SpherHarmSpecial=sqrt((2*l+1)/(4*fact*PI))*plgndr(l,mm,un(3))*&
      cmplx(cos(m*phi),sin(m*phi), 8)
end function SpherHarmSpecial

real(8) function SpherHarmTrunc(l,m,costheta)
  !! Ylm(θ,ϕ) without the exp(i m ϕ) factor
  integer,intent(in) :: l,m
  real(8),intent(in) :: costheta  ! cos(θ)
  real(8), parameter :: PI=3.14159265358979D0
  integer :: i,fact,mm
  mm=abs(m)

  fact=1
  do i=l+mm,l-mm+1,-1
     fact=fact*i
  end do

  SpherHarmTrunc=sqrt((2*l+1)/(4*fact*PI))*plgndr(l,mm,costheta)
end function SpherHarmTrunc

function plgndr(l,m,x)
  !! Computes the associated renormalized Legendre polynomial Pm
  !! l (x). m and l must statisfy 0<=m<=l and x must be in [-1,1].
  !! Legendre polynomial.
  integer, intent(in) :: l,m
  real(8), intent(in) :: x
  real(8) :: plgndr
  integer :: ll
  real(8) :: fact,pll,pmm,pmmp1,somx2
  pll=0.d0
  pmm=1.0 !Compute Pmm
  if (m > 0) then
     somx2=sqrt((1.0D0-x)*(1.0D0+x))
     fact=1.
     do ll=1,m
        pmm=-pmm*fact*somx2
        fact=fact+2.
     enddo
  endif

  if (l == m) then
     plgndr=pmm
  else
     pmmp1=x*(2*m+1)*pmm !Compute Pmm+1.
     if (l == m+1) then
        plgndr=pmmp1
     else !Compute Pml , l > m+ 1.
        do ll=m+2,l
           pll=(x*(2*ll-1)*pmmp1-(ll+m-1)*pmm)/(ll-m)
           pmm=pmmp1
           pmmp1=pll
        end do
        plgndr=pll
     end if
  end if
end function plgndr

end module


program composite_trapezoidal
    ! Author : Anantha Rao (reg no: 20181044)
    ! Program to evaluate the integral I = Int_a^b f(x)
    implicit none
    real*8,external::func
    ! An external function f in double precision

    real*8::a,b,h,trapezoidal_integral
    ! a : Lower limit of the integral
    ! b : Upper limit of the integral
    ! h : bin size
    ! trapezoidal_integral : Value of the integral using trapezoidal technique

    integer::n,i
    ! n : number of bins
    ! i : counter

    n = 1000
    a = 0
    b = 1
    print 10, n
    10 format("Welcome to this program. &
         & This program does integration on I= Int_0^1 4.0/(1+x^2) using trapezoidal rule with n=",i5," bins" )

    h=(b-a)/real(n)   ! size of each bin
    trapezoidal_integral=(h/2)*(func(a)+func(b))

    do i=1,n-1
        trapezoidal_integral=trapezoidal_integral+h*func(a+i*h)
    end do
    print *, "The integrated value using trapezoidal rule is:",trapezoidal_integral
    !5 format("The integrated value using trapezoidal rule is:",
end program composite_trapezoidal

real*8 function func(x)
    implicit none
    real*8::x
    func=4.0d0/(1.0d0+x*x)
    ! func=SIN(x)
end function


! Objetivo: Calcular a probabilidade de um caminhante, apos N passos,
!           parar em determinada posicao.

PROGRAM caminhadas_aleatorias

    USE nrtype
    USE ran_state, ONLY: ran_seed
    USE nr, ONLY: ran0

    IMPLICIT none
    INTEGER :: iseed = 1234
    INTEGER, PARAMETER :: passos_total = 20, total_caminhantes = 100000
    INTEGER :: passo, caminhante_n, posicao
    INTEGER, PARAMETER :: dados_caminhada_aleatoria = 7
! Quantidade_posfinais eh a quantidade de caminhantes que terminaram em
! determinadas posicoes
    INTEGER, DIMENSION (-passos_total:passos_total) :: quantidade_posfinais = 0
    REAL :: aleatorio
    REAL, PARAMETER :: total_caminhantes_real = REAL(total_caminhantes)
    REAL, DIMENSION(-passos_total:passos_total) :: probabilidade
! Iniciar semente
    CALL RAN_SEED (SEQUENCE = iseed)
    DO caminhante_n = 1, total_caminhantes
        posicao = 0
        DO passo = 1, passos_total
! Chamar numero aleatorio uniformemente distribuido entre 0. e 1.
! excluindo os extremos
            CALL ran0(aleatorio)
! A subrotina retorna um numero aleatorio uniformemente distribuido entre 0. e
! 1. (excluindo os extremos). Para termos chances iguais de movimentacao (direita
! e esquerda) assumimos que para aleatorio menor que 0.5 (passo para esquerda)
! para aleatorio maior que 0.5 (passo para direita) e para 0.5 (nao anda).
            IF(aleatorio < 0.5)THEN
                posicao = posicao-1
            ELSE
                IF(aleatorio > 0.5) THEN
                    posicao = posicao+1
                END IF
            END IF
        END DO
!Contabilizar a quantidade de caminhadas finalizadas em cada posicao
        quantidade_posfinais(posicao) = quantidade_posfinais(posicao) + 1
    END DO
! Calcular a probabilidade de um caminhante parar em cada posicao
    probabilidade = quantidade_posfinais/total_caminhantes_real

    OPEN(dados_caminhada_aleatoria, FILE="dados_caminhada_aleatoria.dat")
! Escrever a posicao e a probabilidade (excluindo os casos em que a
! probabilidade eh zero)
    DO posicao = -passos_total, passos_total, 2
        WRITE(dados_caminhada_aleatoria, *) posicao, probabilidade(posicao)
    END DO
    CLOSE(dados_caminhada_aleatoria)

END PROGRAM caminhadas_aleatorias


module smooth_step

  implicit none

  public :: smoothstep

contains

  pure function smoothstep (x,N,minV,maxV)

    implicit none

    real :: smoothstep
    real, intent (in) :: x
    integer, intent (in) :: N
    real, optional, intent (in) :: minV
    real, optional, intent (in) :: maxV
    real :: minVl
    real :: maxVl
    real :: dV

    minVl = 0
    maxVl = 1

    if(present(minV)) minVl = minV
    if(present(maxV)) maxVl = maxV

    dV = maxVl - minVl

    if(x .le. 0) then
      smoothstep = minVl
      return
    endif
    if(x .ge. 1) then
      smoothstep = maxVl
      return
    endif

    select case (N)
      case(0)
        smoothstep = minVl + dV*smoothstep0(x)
      case(1)
        smoothstep = minVl + dV*smoothstep1(x)
      case(2)
        smoothstep = minVl + dV*smoothstep2(x)
      case default
        smoothstep = minVl + dV*smoothstepN(x,N)
    end select
  end function smoothstep

  pure function smoothstep0 (x)
    implicit none
    real :: smoothstep0
    real, intent (in) :: x
    smoothstep0 = x
  end function smoothstep0

  pure function smoothstep1 (x)
    implicit none
    real :: smoothstep1
    real, intent (in) :: x
    smoothstep1 = x*x*(3-2*x)
  end function smoothstep1

  pure function smoothstep2 (x)
    implicit none
    real :: smoothstep2
    real, intent (in) :: x
    smoothstep2 = x*x*x*(x*(x*6-15)+10)
  end function smoothstep2

  pure function smoothstepN (x,N)
    implicit none
    real  :: smoothstepN
    real :: sumV
    real :: xp
    real, intent (in) :: x
    integer, intent (in) :: N
    integer :: i

    if(N < 0) then
      smoothstepN = 0.5*sin(3.14159265358979*(x-0.5))+0.5
      return
    endif

    xp = x
    if(x > 0.5) xp = 1.0-x
    sumV = 0
    do i = N, 0, -1
      sumV = xp*sumV + &
             pascalTriangle(-N-1,i) * &
             pascalTriangle(2*N + 1, N-i)
    end do
    sumV = xp**(N+1)*sumV
    smoothstepN = sumV
    if(x > 0.5) smoothstepN = 1-sumV
  end function smoothstepN

  pure function pascalTriangle (a,b)
    implicit none
    integer :: pascalTriangle
    integer, intent (in) :: a,b
    integer i
    pascalTriangle = 1
    do i = 0, b-1
      pascalTriangle = pascalTriangle*(a-i)/(i+1)
    end do
  end function pascalTriangle

end module smooth_step


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

MODULE m_differentiate
CONTAINS
  REAL FUNCTION difcub(x,f,xi)
    !     **********************************************************
    !     differentiate the function f, given at the
    !     points x0,x1,x2,x3 at the point xi by lagrange
    !     interpolation for polynomial of 3rd order
    !     r.p.
    !     ***********************************************************
    IMPLICIT NONE
    !     .. Scalar Arguments ..
    REAL,INTENT(IN):: xi
    !     ..
    !     .. Array Arguments ..
    REAL,INTENT(IN):: f(0:3),x(0:3)
    !     ..
    difcub = ((xi-x(1))* (xi-x(2))+ (xi-x(1))* (xi-x(3))+&
         (xi-x(2))* (xi-x(3)))*f(0)/ ((x(0)-x(1))* (x(0)-x(2))*&
         (x(0)-x(3))) + ((xi-x(0))* (xi-x(2))+&
         (xi-x(0))* (xi-x(3))+ (xi-x(2))* (xi-x(3)))*f(1)/&
         ((x(1)-x(0))* (x(1)-x(2))* (x(1)-x(3))) +&
         ((xi-x(0))* (xi-x(1))+ (xi-x(0))* (xi-x(3))+&
         (xi-x(1))* (xi-x(3)))*f(2)/ ((x(2)-x(0))* (x(2)-x(1))*&
         (x(2)-x(3))) + ((xi-x(0))* (xi-x(1))+&
         (xi-x(0))* (xi-x(2))+ (xi-x(1))* (xi-x(2)))*f(3)/&
         ((x(3)-x(0))* (x(3)-x(1))* (x(3)-x(2)))
    RETURN
  END FUNCTION difcub
  SUBROUTINE diff3(&
       f,dx,&
       df)
    !********************************************************************
    !     differetiation via 3-points
    !********************************************************************

    IMPLICIT NONE

    !     .. Scalar Arguments ..
    REAL,    INTENT (IN) :: dx
    !     ..
    !     .. Array Arguments ..
    REAL, INTENT (IN)  ::  f(:)
    REAL, INTENT (OUT) :: df(:)
    !     ..
    !     .. Local Scalars ..
    INTEGER i,jri
    REAL tdx_i
    !     ..
    jri=size(f)
    tdx_i = 1./(2.*dx)
    !
    !---> first point
    df(1) = -tdx_i * (-3.*f(1)+4.*f(2)-f(3))
    !
    !---> central point formula in charge
    DO i = 2,jri - 1
       df(i) = tdx_i * (f(i+1)-f(i-1))
    END DO
    !
    !---> last point
    df(jri) = tdx_i * (3.*f(jri)-4.*f(jri-1)+f(jri-2))
    !
    RETURN
  END SUBROUTINE diff3

END MODULE m_differentiate


! Counts the number of non-prime factors of a given number n.
! Works for any n <= 1000000.

module npf_module
    implicit none

    ! Declarations.
    integer, parameter :: max_n = 1000000
    integer, dimension (0:max_n + 1) :: factors, memo = -1

    public :: eratosthenes, npf

contains

    ! Runs the sieve of eratosthenes.
    subroutine eratosthenes ()
        integer :: i, j

        ! Initialize each of the factors to itself.
        do i = 0, max_n
            factors(i) = i
        end do

        ! Run the sieve.
        do i = 2, 1000
            if (factors(i) == i) then
                do j = i + i, max_n, i
                    factors(j) = i
                end do
            end if
        end do

    end subroutine eratosthenes

    ! Counts the number of non-prime factors of a given number.
    function npf (x) result (cnt)
        integer, intent (in) :: x
        integer :: cnt, pfactors, d, prod, n

        cnt = 0

        ! Handle trivial cases.
        if (memo(x) /= -1) then
            cnt = memo(x)
            return
        else if (x == 0 .or. x == 1) then
            memo(x) = cnt
            return
        end if

        ! Solve general case.
        n = x
        pfactors = 0
        prod = 1

        do while (n > 1)
            d = factors(n)
            cnt = 0

            do while (mod(n, d) == 0)
                n = n / d
                cnt = cnt + 1
            end do

            prod = prod * (cnt + 1)
            pfactors = pfactors + 1
        end do

        memo(x) = prod - pfactors
        cnt = memo(x)
    end function npf

end module npf_module

! Driver code.
program main
    use npf_module
    implicit none

    character(len = 100) :: input
    integer :: n

    call eratosthenes()

    ! Print information for the user.
    print '(a)', 'For any number of queries, this program gets the number of non-prime factors of a given number x <= 1000000.'
    print '(a)', 'To stop the queries and end the program, input "exit".'

    do while (input /= 'exit')
        read (*, *) input

        if (input /= 'exit') then
            read (input, *) n
            print '(a, i0)', 'The number of non-prime factors is: ', npf(n)
        end if
    end do

end program main


module mod_activation

  ! A collection of activation functions and their derivatives.

  use mod_kinds, only: ik, rk

  implicit none

  private

  public :: gaussian, gaussian_prime
  public :: relu, relu_prime
  public :: sigmoid, sigmoid_prime
  public :: step, step_prime
  public :: tanhf, tanh_prime

contains

  pure function gaussian(x) result(res)
    ! Gaussian activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = exp(-x**2)
  end function gaussian

  pure function gaussian_prime(x) result(res)
    ! First derivative of the Gaussian activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = -2 * x * gaussian(x)
  end function gaussian_prime

  pure function relu(x) result(res)
    !! REctified Linear Unit (RELU) activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = max(0., x)
  end function relu

  pure function relu_prime(x) result(res)
    ! First derivative of the REctified Linear Unit (RELU) activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    where (x > 0)
      res = 1
    elsewhere
      res = 0
    end where
  end function relu_prime

  pure function sigmoid(x) result(res)
    ! Sigmoid activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = 1 / (1 + exp(-x))
  endfunction sigmoid

  pure function sigmoid_prime(x) result(res)
    ! First derivative of the sigmoid activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = sigmoid(x) * (1 - sigmoid(x))
  end function sigmoid_prime

  pure function step(x) result(res)
    ! Step activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    where (x > 0)
      res = 1
    elsewhere
      res = 0
    end where
  end function step

  pure function step_prime(x) result(res)
    ! First derivative of the step activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = 0
  end function step_prime

  pure function tanhf(x) result(res)
    ! Tangent hyperbolic activation function.
    ! Same as the intrinsic tanh, but must be
    ! defined here so that we can use procedure
    ! pointer with it.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = tanh(x)
  end function tanhf

  pure function tanh_prime(x) result(res)
    ! First derivative of the tanh activation function.
    real(rk), intent(in) :: x(:)
    real(rk) :: res(size(x))
    res = 1 - tanh(x)**2
  end function tanh_prime

end module mod_activation


; Evalutes x +y
(define (add x y)
  (ifz y x                       ; if y==0, x+y=x
       (add (inc x) (dec y))))   ; otherwise x+y = (x+1) + (y-1)

; Evalutes x - y
(define (sub x y)
  (ifz y x                      ; if y==0, x-y = x
       (ifz x (halt)            ; else if x==0, we halt because the result is negative
            (sub (dec x) (dec y)))))  ; else x-y = (x-1) - (y-1)

; Evaluates to 0 if x < y, and 1 otherwise
(define (lt x y)
 (ifz y 1                       ; if y==0, x<y cannot be true, evaluates to 1
      (ifz x 0                  ; else if x==0, it must be x<y, evaluates to 0
           (lt (dec x) (dec y))))) ; else x<y if and only if x-1 < y-1

; Evaluets x * y
(define (mul x y)
  (ifz y 0                       ; if y==0, x*y=0
       (add (mul x (dec y)) x))) ; esle x*y = x + x*(y-1)

; Evaluets x / y, only the quotient part
(define (div x y)
  (ifz y (halt)                  ; Division by 0
       (ifz (lt x y) 0           ; if x < y, evaluates to 0
            (inc (div (sub x y) y)))))  ; else x/y = 1+(x-y)/y

; Evaluates factorial of x
(define (fac x)
  (ifz x 1
       (mul (fac (dec x)) x)))

; Evaluates x^e, in an inefficient way
(define (sexp x e)
  (ifz e 1
       (mul (sexp x (dec e)) x)))

(define (exp x e)
  (ifz e 1
       (ifz (rem e 2)
            (square (exp x (div e 2)))
            (mul (exp x (dec e)) x))))

; Evaluets x mod y (i.e., x % y)
(define (rem x y)
  (ifz y (halt)                  ; Division by 0
       (ifz (lt x y) x           ; if x<y, x mod y = x
            (rem (sub x y) y)))) ; else x mod y = (x-y) mod y

(define (square x)
  (mul x x))

; Evaluets x^e mod y
(define (mexp x e y)
  (ifz e 1                       ; if e==0, then x^e = 1
       (ifz (rem e 2)            ; if e % 2 == 0
            (rem (square (mexp x (div e 2) y)) y) ; x^e mod y = (x^(e/2) mod y)^2 mod y
            (rem (mul (mexp x (dec e) y) x) y)))) ; x^e mod y = (x * x^(e-1) mod y) mod y

; Helper function to compute gcd of x, y.
; On entering the function, we are guaranteed that
;      among 1 to z, the largest common divisor of (x,y) is c
;      and x<y
; Logic of the code
; (gcdh c z x y) = c if x<z
; (gcdh c z x y) = (gcdh z (z+1) x y) if z divides both x and y
; (gcdh c z x y) = (gcdh c (z+1) x y) if z does not divide x or z does not divide y
(define (gcdh c z x y)
  (ifz (lt x z) c
       (ifz (rem x z)
            (ifz (rem y z)
                 (gcdh z (inc z) x y)
                 (gcdh c (inc z) x y))
            (gcdh c (inc z) x y))))

(define (gcd x y)
  (ifz (lt x y)
       (gcdh 1 2 x y)
       (gcdh 1 2 y x)))

; Logic of the above gcd implementation expressed in C
; int gcd(int x, int y) {
;   c=1
;   for (int z=2; z<=x; z++} {
;     if ((x%z==0) && (y%z==0)) {
;       c=z;
;     }
;   }
; }

; Below is gcd using euclidean algorithm
(define (gcde x y)
  (ifz (lt x y) (gcde y x)
    (ifz y x (gcde y (rem x y)))))

(gcde 12 18)
(mexp 2 4 11)


module LUDecomposition
implicit none

  contains
    subroutine ludcmp_square(A, n, indx)

      ! The LU decomposition
      ! Return the LU decomposition in A after all alpah_ii = 1
      ! Thus Rule
      ! beta_ij  = a_ij with i<j
      ! alpha_ij = a_ij with i>=j
      !
      ! Steps of the Algorithm
      ! 1.- Find the largest absolute element in the row to be used as
      ! 2.- if big == 0.0 you have a singular matrix return with error
      ! 3.- if not singularity save the scalling vv(i) = 1.0/big
      ! 4.- Loop over the betas
      ! 5.- Loop over the betas and look if you have a new max pivote
      ! 6.- Move the max row pivote upwards
      ! 7.- Use TINY number if division by zero arises
      ! 8.- Divide by pivote element

      ! In parameters
      integer, intent(in) :: n
      real, intent(inout) :: A(n,n)
      ! Out Parameters
      integer, intent(out) :: indx(n)
      ! Parameters
      real, parameter :: TINY = 1.0E-30

      ! Internal variables
      ! Indexing
      integer :: i
      integer :: j
      integer :: k
      ! max index pivot
      integer :: imax
      ! Internal variables for the Crout's method
      real :: big
      real :: dum
      real :: sum
      real :: temp
      real, dimension (n) :: vv

      ! Chose the variable for permutation
      do i = 1, n
        big = 0.0
        do j = 1, n
          temp = abs(A(i,j))
          if (temp > big) then
            big = temp
          end if
        end do
        if (big == 0.0) then
          print*,"Singular matrix in routine ludcmp"
          return
        end if
        ! Save the Scaling
        vv(i) = 1.0/big
      end do
      ! This is the loop over columns of Crout’s method.
      ! For the upper triangular part of A(i,j)=beta_ij with i<=j
      do j = 1, n
        do i = 1, j-1
          sum = A(i,j)
          do k = 1, i-1
            sum = sum - A(i,k)*A(k,j)
          end do
          A(i,j) = sum
        end do
        ! Start the search for the largest pivot element
        big = 0.0
        imax = j
        do i = j, n
          sum = A(i,j)
          do k = 1, j-1
            sum = sum - A(i,k)*A(k,j)
          end do
          A(i,j) = sum
          dum = vv(i)*abs(sum)
          if (dum >= big) then
            big = dum
            imax = i
          end if
        end do
        ! Interchage Rows a classic to mantain stability getting
        ! The Largest absolute value in the choosen pivot
        if (j /= imax) then
          do k = 1, n
            dum = A(imax,k)
            A(imax,k) = A(j,k)
            A(j,k) = dum
          end do
          ! Interchange the scale factor
          vv(imax) = vv(j)
        end if
        indx(j) = imax
        ! Solving some issues with zero pivots
        !
        if (A(j,j) == 0) then
          A(j,j) = TINY
        end if
        ! Divide by the pivot element.
        if (j /= n) then
          dum = 1.0/A(j,j)
          do i = j+1, n
            A(i,j) = A(i,j)*dum ! Division
          end do
        end if
      end do

    end subroutine ludcmp_square

end module LUDecomposition


module statistics
  !! Provides routines for basic statistical methods.

  implicit none

  public :: factorial, mean, variance, standardDeviation, covariance

  public

  interface median
     module procedure median_real, median_int
  end interface median

contains

  pure integer function factorial(x) result(xfac)
    !! Returns the factorial of the scalar value \(\mathbf{x}\),
    !! $$ x! = n(n-1)(n-2)\cdots(3)(2)(1) $$

    integer, intent(in) :: x

    integer :: i

    xfac = 1
    if (x >= 0) then
       do i = x, 1, -1
          xfac = xfac * i
       end do
    end if

  end function factorial

  pure real function mean(x) result(mu)
    !! Returns the arithmatic mean of a vector \(\mathbf{x}\).
    !! $$ \mu = \frac{1}{n} \sum_{i=1}^n x_i $$

    implicit none

    real, intent(in) :: x(:)

    real :: Sx
    integer :: n, i, l, u

    mu = 0.0
    Sx = 0.0

    n = size(x)
    l = lbound(x,1)
    u = ubound(x,1)

    do i = l, u
       Sx = Sx + x(i)
    end do

    mu = Sx / n

  end function mean

  pure integer function median_int(x) result(xm)

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

    xm = ceiling(size(x)/2.0)

  end function median_int

  pure integer function median_real(x) result (xm)

    real, intent(in) :: x(:)

    xm = ceiling(size(x)/2.0)

  end function median_real

  pure real function variance(x) result(ss)
    !! Returns the sample variance of the vector \(\mathbf{x}\),
    !! $$ s^2 = \frac{1}{n-1} \sum_{i=1}^n \left(x_i - \mu_x \right)^2 $$

    implicit none

    real, intent(in) :: x(:)

    integer :: n, i, l, u
    real :: xb

    n = size(x)

    xb = mean(x)
    ss = 0.0

    l = lbound(x,1)
    u = ubound(x,1)
    do i = l, u
       ss = ss + (x(i) - xb)**2
    end do

    ss = 1 / (n - 1) * ss

  end function variance

  pure real function standardDeviation(x) result(s)
    !! Returns the sample standard deviation of a vector \(\mathbf{x}\),
    !! $$ s = \sqrt{\frac{1}{n-1} \sum_{i=1}^n \left(x_i - \mu_x \right)^2} $$

    implicit none

    real, intent(in) :: x(:)

    s = sqrt(variance(x))

  end function standardDeviation

  pure real function covariance(x, y) result(sigma)
    !! Returns the covariance of two vectors \(\mathbf{x}\) and \(\mathbf{y}\),
    !! $$ \sigma(x,y) =\frac{1}{n-1} \sum_{i=1}^n \left(x_i - \mu_x \right) \left(y_i-\mu_y\right) $$

    implicit none

    real, intent(in) :: x(:), y(:)

    real :: Sx, Sy, xb, yb
    integer :: n, i, l, u

    !!@todo If x and y aren't same size, return error
    !!@todo Handle x and y not same bound start/end
    sigma = 0.0

    n = size(x)

    xb = mean(x)
    yb = mean(y)

    l = lbound(x,1)
    u = ubound(x,1)
    do i = l, u
       Sx = x(i) - xb
       Sy = y(i) - yb
       sigma = sigma + (Sx*Sy / n)
    end do

  end function covariance

end module statistics


	!>@author
	!>Paul J. Connolly, The University of Manchester
	!>@copyright 2019
	!>@brief
	!>calculate the inverse of erf
	!> This implementation is based on the rational approximation
    !> of percentage points of normal distribution available from
    !> https://www.jstor.org/stable/2347330.
	!>@param[in] x: input integer
	!>@param[inout] ans: the output
	subroutine erfinv(x,ans)
	    use, intrinsic :: IEEE_ARITHMETIC
	    use numerics, only : LN2,A0,A1,A2,A3,A4,A5,A6,A7, &
	                    B0,B1,B2,B3,B4,B5,B6,B7, &
	                    C0,C1,C2,C3,C4,C5,C6,C7, &
	                    D0,D1,D2,D3,D4,D5,D6,D7, &
	                    E0,E1,E2,E3,E4,E5,E6,E7, &
	                    F0,F1,F2,F3,F4,F5,F6,F7
	    use numerics_type
        implicit none
        real(wp), intent(in) :: x
        real(wp), intent(inout) :: ans
        complex(wp) :: num, den
        real(wp) :: abs_x, r

        if((x>1._wp) .or. (x<-1._wp)) then
            ans=IEEE_VALUE(0._wp,IEEE_QUIET_NAN)
            return
        elseif((x==1._wp) ) then
            ans=IEEE_VALUE(0._wp,IEEE_POSITIVE_INF)
            return
        elseif((x==-1._wp) ) then
            ans=IEEE_VALUE(0._wp,IEEE_POSITIVE_INF)
        endif

        abs_x=abs(x)
        if(abs_x <= 0.85_wp) then
            r =  0.180625_wp - 0.25_wp * x * x
            num = (((((((A7 * r + A6) * r + A5) * r + A4) * r + A3) &
                * r + A2) * r + A1) * r + A0)
            den = (((((((B7 * r + B6) * r + B5) * r + B4) * r + B3) &
                * r + B2) * r + B1) * r + B0)
            ans = x * num / den
            return
        endif

        r = sqrt(LN2 - log(1.0_wp - abs_x))
        if (r <= 5.0_wp) then
            r = r - 1.6;
            num = (((((((C7 * r + C6) * r + C5) * r + C4) * r + C3) * &
                r + C2) * r + C1) * r + C0)
            den = (((((((D7 * r + D6) * r + D5) * r + D4) * r + D3) * &
                r + D2) * r + D1) * r + D0)
        else
            r = r - 5.0_wp
            num = (((((((E7 * r + E6) * r + E5) * r + E4) * r + E3) * &
                r + E2) * r + E1) * r + E0)
            den = (((((((F7 * r + F6) * r + F5) * r + F4) * r + F3) * &
                r + F2) * r + F1) * r + F0)
        endif
        if (x < 0._wp) then
            ans= real(-num/den,wp)
            return
        else
            ans = real(num/den,wp)
            return
        endif

    end subroutine erfinv
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!


!NEWTON RAPHSON METHOD (for finding root of real valued function)

program NewtonRaphson

    implicit none

    real :: x0,x1,e,f,fd
    integer :: i    !Counting Iterations

    print*,"Enter the initial guess : "
    read*,x0
    print*,"Enter the value of tolerance : "
    read*,e

    print*,"         n             x0             x1      "
    print*,"---------------------------------------------"

    i=0 !Initial value
    x1=x0-f(x0)/fd(x0)
    print*,i,x0,x1

    do while(abs(x1-x0)>e)
        x0=x1
        x1=x0-f(x0)/fd(x0)
        i=i+1   !Increase 1 after each loop
        print*,i,x0,x1
    end do

    print*,"The value of root x after ",i," iteration(s) : ",x1

end program

function f(x)
    implicit none
    real::f !Dummy Variable
    real::x !Local Variable
    f=x-exp(-x)
end function

function fd(x)
    implicit none
    real::fd    !Dummy Variable
    real::x     !Local Variable
    fd=1+exp(-x)
end function


program main
   use m_npy
   real    :: x(1000)
   real    :: step
   integer :: n
   real, allocatable :: P(:,:)

   step = 2.0 / (size(x) - 1)

   x(1) = -1.0
   do n = 2,size(x)
      x(n) = x(n-1) + step
   enddo

   call legendre_poly(10, x, P)

   call save_npy("leg.npy", P)

contains
   subroutine legendre_poly(n_max, x, P)
      implicit none
      integer, intent(in)              :: n_max
      real, intent(in)                 :: x(:)
      real, intent(inout), allocatable :: P(:,:)

      integer :: n

      if(allocated(P)) then
         if(size(P,1) /= size(x) .or. size(P,2) /= n_max+1) then
            deallocate(P)
         endif
      endif

      if(.not. allocated(P)) then
         allocate(P(size(x), 0:n_max), source=0.0)
      endif

      if (n_max >= 0) then
         P(:, 0) = 1.0
      endif

      if (n_max >= 1) then
         P(:, 1) = x
      endif

      do n = 1, n_max - 1
         P(:, n + 1) = ((2*n + 1)*x*P(:, n) - n*P(:, n - 1))/(n + 1.0)
      enddo
   end subroutine legendre_poly
end program main


program main
    implicit none

    call ball(-9.8, 20.0)
    call ball(-9.7, 20.0)
    call ball(-9.6, 20.0)
    call ball(-9.81, 10.0)
    call ball(-9.81, 20.0)
    call ball(-9.81, 30.0)
    call compute()
end program main

subroutine compute
    implicit none
    real :: gravity

    write (*,'(A)') 'Please input the gravity:'
    read  (*,*) gravity
    call ball(gravity, 20.0)
end subroutine compute

SUBROUTINE ball(GRAVITY,v)
!
!  Purpose:
!    To calculate distance traveled by a ball thrown at a specified
!    angle THETA and at a specified velocity VO from a point on the
!    surface of the earth, ignoring the effects of air friction and
!    the earth's curvature.
!
!  Record of revisions:
!       Date       Programmer          Description of change
!       ====       ==========          =====================
!     11/14/06    S. J. Chapman        Original code
!     04/12/17    hopeful              For homework 6 in chapter6
!
IMPLICIT NONE

! Add parameters
REAL :: GRAVITY
REAL :: v

! Data dictionary: declare constants
REAL, PARAMETER :: DEGREES_2_RAD = 0.01745329 ! Deg ==> rad conv.
!REAL, PARAMETER :: GRAVITY = -9.81            ! Accel. due to gravity (m/s)
! Data dictionary: declare variable types, definitions, & units
INTEGER :: max_degrees  ! angle at which the max rng occurs (degrees)
REAL :: max_range       ! Maximum range for the ball at vel v0 (meters)
REAL :: range           ! Range of the ball at a particular angle (meters)
REAL :: radian          ! Angle at which the ball was thrown (in radians)
INTEGER :: theta        ! Angle at which the ball was thrown (in degrees)
REAL :: v0              ! Velocity of the ball (in m/s)

! Initialize variables.
max_range = 0
max_degrees = 0
!v0 = 20
v0 = v
loop: DO theta = 0, 90

   ! Get angle in radians
   radian = real(theta) * DEGREES_2_RAD

   ! Calculate range in meters.
   range = (-2. * v0**2 / GRAVITY) * SIN(radian) * COS(radian)

   ! Write out the range for this angle.
     WRITE (*,*) 'Theta = ', theta, ' degrees; Range = ', range,  ' meters'

   ! Compare the range to the previous maximum range.  If this
   ! range is larger, save it and the angle at which it occurred.
   IF ( range > max_range ) THEN
      max_range = range
      max_degrees = theta
   END IF

END DO loop
      ! Skip a line, and then write out the maximum
! range and the angle at which it occurred.
WRITE (*,*) ' '
WRITE (*,*) 'Max range = ', max_range, ' at ', &
    max_degrees, ' degrees'

END SUBROUTINE ball


program Fibonacci
  implicit none
  CHARACTER(100) :: arg
  integer :: input

  if (command_argument_count() > 0) then
    call get_command_argument(1, arg)
    read (arg, *) input
  else
    input = 29
  endif

  print *, fibLinear(input)

contains

  recursive function fib(n) result(r)
    implicit none
    integer :: n, r

    if (n < 2) then
      r = n
    else
      r = fib(n - 1) + fib(n - 2)
    endif
  end function fib

  integer function fibLinear(n)
    implicit none
    integer :: n, i, temp, prevFib = 0, fib = 1

    do i = 2, n
      temp = prevFib + fib
      prevFib = fib
      fib = temp
    enddo
    fibLinear = fib
  end function fibLinear

  integer function fibFormula(n)
    implicit none
    integer :: n

    fibFormula = nint(((5 ** 0.5 + 1) / 2) ** n / 5 ** 0.5)
  end function fibFormula

  recursive function fibTailAuxiliary(n, prevFib, fib) result(r)
    implicit none
    integer :: n, prevFib, fib, r

    if (n == 0) then
      r = prevFib
    else
      r = fibTailAuxiliary(n - 1, fib, prevFib + fib)
    endif
  end function fibTailAuxiliary

  integer function fibTailRecursive(n)
    implicit none
    integer :: n

    fibTailRecursive = fibTailAuxiliary(n, 0, 1)
  end function fibTailRecursive

end program Fibonacci