! e_taylor.f95
! Calculates e^x via the Taylor Series approximation.
! Contemplated not using a function for factorial, and just adding up pieces
! along the way, but it got less accurate results.
!
! GRE, 2/26/10

program e_taylor
    implicit none

    real :: x, true_soln, factorial
    ! Input x; true (according to fortran) solution; function factorial
    integer :: n, i
    ! Input n: number of terms to take; dummy counter i
    real :: approx = 1.0
    ! Output approx: our approximated solution

    write(*,*) "I compute e^x via the Taylor Series approximation."

    write(*,*) "What value for x?"
    read(*,*) x
    true_soln = exp(x)

    write(*,*) "How far out should we take the approximation?"
    read(*,*) n

    do i = 1,n
        approx = approx + (x**i)/factorial(i)
        ! Add up terms of Taylor Series
    end do

    write(*,*) "My approximation:", approx          ! Output approximate answer
    write(*,*) "Actual answer:", true_soln          ! Output Fortran's solution
    write(*,*) "Error:", abs(true_soln - approx)    ! Output |Error|

end program e_taylor

function factorial(k)
! Computes k!
    implicit none

    real :: factorial                               ! Real to get more precision
    integer, intent(in) :: k                        ! Input
    integer :: j                                    ! Counter
    factorial = 1.0
    do j = 2,k
        factorial = factorial * j
    end do
    return
end function factorial


! Math Algorithms
!
! Purpose:       Function that calculates the factorial of a given number
! Obs:           The factorial is calculated in two ways: iterative and recursive
! Language:      Fortran 95
! Author:        José Cintra
! Year:          2020
! Web Site:      https://github.com/JoseCintra/MathAlgorithms
! License:       Unlicense, described in http://unlicense.org
! Online demo:   https://onlinegdb.com/Syk6M8G8d

MODULE math
! Mathemathical functions

CONTAINS

   ! Function to calculate the factorial in a iterative way
   INTEGER FUNCTION factorial(num)

      ! Variables
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: num
      INTEGER :: i

      !Calculation
      factorial = 1
      DO i = 1,num
        factorial = factorial * i
      END DO
      RETURN

   END FUNCTION factorial

  ! Function to calculate the factorial in a recursive way
  RECURSIVE FUNCTION recFactorial (num) RESULT (res)

    ! Variables
    INTEGER, INTENT(IN) :: num
    INTEGER :: res

    !Calculation
    IF (num <= 1) THEN
       res = 1
    ELSE
       res = recFactorial(num-1) * num
    END IF

  END FUNCTION recFactorial

END MODULE

PROGRAM factorialTest

   USE math

   ! Variables
   IMPLICIT NONE
   INTEGER :: num  ! User's number to calculate factorial
   INTEGER :: fact ! Calculated factorial
   WRITE (*,'(a)') "Factorial calculation"

      ! Data entry
   PRINT *,""

   ! Change this to test other input values
   num = 5

   ! Output
   fact = factorial(num)
   WRITE (*, '(a,I0,a,I0)') "The factorial of the number ", num, " is ", fact
   fact = recFactorial(num)
   WRITE (*, '(a,I0,a,I0)') "The recursive factorial of the number ", num, " is ", fact

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

END PROGRAM factorialTest


INTEGER FUNCTION euclid_sub(a, b)
    IMPLICIT NONE
    INTEGER, INTENT(INOUT) :: a, b

    a = ABS(a)
    b = ABS(b)

    DO WHILE (a /= b)

        IF (a > b) THEN
            a = a - b
        ELSE
            b = b - a
        END IF
    END DO

    euclid_sub = a

END FUNCTION euclid_sub

INTEGER FUNCTION euclid_mod(a, b)
    IMPLICIT NONE
    INTEGER, INTENT(INOUT) :: a, b
    INTEGER                :: temp

    DO WHILE (b > 0)
        temp = b
        b = MODULO(a,b)
        a = temp
    END DO

    euclid_mod = a

END FUNCTION euclid_mod

PROGRAM euclidean

    IMPLICIT NONE
    INTEGER :: a, b, euclid_sub, euclid_mod

    a = 24
    b = 27
    WRITE(*,*) 'Subtraction method: GCD is: ', euclid_sub(a, b)

    a = 24
    b = 27
    WRITE(*,*) 'Modulus method:     GCD is: ', euclid_mod(a, b)

END PROGRAM euclidean


! Test against the sequence of prime numbers:
!
!   https://oeis.org/A000040
!
! First implementation: just two nested loops: over numbers and over divisors up
! to sqrt(n).
!
! Second implementation: do the sieve of Eratosthenes.
! 1) Create an array of natural numbers from 2 to n to contain primes and zeros.
! 2) Start from multiple p = 1.
! 3) Repeat until p doesn't exceed n.  Increment p.  If primes(p) is not marked, then
! 3) Mark all multiples of p in primes from p^2 to n with a step of p.
! 4) Repeat step 3).
! Generate a sequence of integers from 2 through n.
! Let p be the current prime number.  Start with p = 2.
! Mark the multiples of p in the sequence from 2p, 3p, ..., n (don't mark p itself).
! Find the smallest number in the sequence greater than p that is not marked.
! If there was no such number, stop.
! Otherwise, this is the next prime.  Set p to it and repeat marking again.
! Once done, all unmarked numbers in the sequence are primes.
program sieve
    implicit none
    integer :: n, i, j, root, p
    integer, allocatable :: primes(:)
    logical, allocatable :: is_prime(:)

    print '(a)', "Enter n"
    read *, n

    ! 1st solution.
    !numbers: do i = 2, n
    !    if (2 < i) then
    !        root = int(sqrt(real(i)))
    !        do j = 2, root
    !            if (mod(i, j) == 0) cycle numbers
    !        end do
    !    end if
    !    write(*, '(i0)') i
    !end do numbers

    ! 2nd solution.
    !allocate(primes(2:n))
    !primes = [ (i, i = 2, n) ]

    !root = int(sqrt(real(n)))
    !p = 1
    !do while (p <= root)
    !    p = p + 1
    !    if (primes(p) == 0) cycle
    !    do i = p * p, n, p
    !        primes(i) = 0
    !    end do
    !end do
    !print '(a)', "Primes are"
    !do i = 2, n
    !    if (primes(i) /= 0) print '(i0)', primes(i)
    !end do
    !deallocate(primes)

    ! 3rd solution
    allocate(is_prime(2:n), source=.true.)
    root = int(sqrt(real(n)))
    p = 1
    do while (p <= root)
        p = p + 1
        if (.not.is_prime(p)) cycle
        do i = p * p, n, p
            is_prime(i) = .false.
        end do
    end do
    print "(a)", "Primes are"
    do i = 2, n
        if (is_prime(i)) print "(i0)", i
    end do
    deallocate(is_prime)
end program sieve


program Prime_Number_Judgement
implicit none
    logical :: Judge = .false.
    integer :: n , i

    do n = 2 , 100
        do i = 2 , n-1
            if(mod(n,i) == 0) then
                Judge = .true.
                print*, n , '=', i, '*', n/i
                exit
            else
                continue
            end if
            Judge = .false.
        end do

        if (.not.Judge) then
            print*, n, 'is a prime number'
        end if
    end do

end


!
!     Copyright (c) 2017, NVIDIA CORPORATION.  All rights reserved.
!
! NVIDIA CORPORATION and its licensors retain all intellectual property
! and proprietary rights in and to this software, related documentation
! and any modifications thereto.
!
!
!    These example codes are a portion of the code samples from the companion
!    website to the book "CUDA Fortran for Scientists and Engineers":
!
! http://store.elsevier.com/product.jsp?isbn=9780124169708
!

program sum_accuracy
  implicit none
  real, allocatable :: x(:)
  real :: sum_intrinsic,sum_cpu, sum_kahan, sum_pairwise, &
       comp, y, tmp
  double precision :: sum_cpu_dp
  integer :: i,inext,icurrent,  N=10000000

  allocate (x(N))
  x=7.

  ! Summation using intrinsic
  sum_intrinsic=sum(x)

  ! Recursive summation
  sum_cpu=0.
  sum_cpu_dp=0.d0
  do i=1,N
     ! accumulator in single precision
     sum_cpu=sum_cpu+x(i)
     ! accumulator in double precision
     sum_cpu_dp=sum_cpu_dp+x(i)
  end do

  ! Kahan summation
  sum_kahan=0.
  comp=0. ! running compensation to recover lost low-order bits

  do i=1,N
     y    = comp +x(i)
     tmp  = sum_kahan + y     ! low-order bits may be lost
     comp = (sum_kahan-tmp)+y ! (sum-tmp) recover low-order bits
     sum_kahan = tmp
  end do
  sum_kahan=sum_kahan +comp

  ! Pairwise summation
  icurrent=N
  inext=ceiling(real(N)/2)
  do while (inext >1)
     do i=1,inext
        if ( 2*i <= icurrent) x(i)=x(i)+x(i+inext)
     end do
     icurrent=inext
     inext=ceiling(real(inext)/2)
  end do
  sum_pairwise=x(1)+x(2)

  write(*, "('Summming ',i10, &
       ' elements of magnitude ',f3.1)") N,7.
  write(*, "('Sum with intrinsic function       =',f12.1, &
       '   Error=', f12.1)")  &
       sum_intrinsic, 7.*N-sum_intrinsic
  write(*, "('Recursive sum with SP accumulator =',f12.1, &
       '   Error=', f12.1)")  sum_cpu, 7.*N-sum_cpu
  write(*, "('Recursive sum with DP accumulator =',f12.1, &
       '   Error=', f12.1)")  sum_cpu_dp, 7.*N-sum_cpu_dp
  write(*, "('Pairwise sum in SP                =',f12.1, &
       '   Error=', f12.1)")  sum_pairwise, 7.*N-sum_pairwise
  write(*, "('Compensated sum in SP             =',f12.1, &
       '   Error=', f12.1)")  sum_kahan, 7.*N-sum_kahan

  deallocate(x)
end program sum_accuracy


!To find the sum of series (sine series) :
!sin(x) = x - x^3/3! + x^5/5! - x^7/7!

program Sum_of_Series

    implicit none

    real :: x,sinx=0
    integer :: i,n,fact
    real,parameter::pi=3.14 !Constant

    print*,"To find the sum of series (sine series) : sin(x) = x - x^3/3! + x^5/5! - x^7/7"

    print*,"Enter the no. of iterations : n = "
    read*,n
    print*,"Enter the value of x(in degrees) : x = "
    read*,x
    x=x*pi/180

    do i=0,n
        sinx=sinx+(((-1)**i)*(x**(2*i+1)))/fact(2*i+1)
    end
    o
    print*,"sin(",x,") = ",sinx

end program

function fact(n)    !Computing Factorial
    implicit none
    integer::f,n,i    !Local Variables
    integer::fact   !Dummy Variable
    f=1
    do i=1,n
        f=f*i
    end do
    fact=f
end function


module serial_subs

    implicit none

contains

    function calc_pi(n) result(pi)

        implicit none
        integer(8) :: accept
        real(8) :: r(2), pi
        integer(8), intent(in) :: n
        integer(8) :: i

        accept = 0

        do i = 1, n
            call random_number(r)
            if (r(1)**2 + r(2)**2 <= 1) then
                accept = accept + 1
            end if
        end do

        pi = 4.0d0 * dble(accept)/dble(n) ! dble(a) converts a to double precision real type.  Pi/4 parts of a sphere circle

    end function calc_pi

end module serial_subs

program main

    use serial_subs

    implicit none
    integer(8) :: n
    real(8), parameter :: pi = 2.0d0*dacos(0.0d0)
    character (len=64) :: arg
    real(8) :: T1, T2, mypi
    ! 'How many samples you would like to take?'
    ! Usage of this program should be declare.
    call random_seed()

    if (command_argument_count() /= 1) then
        error stop "One command line argument should be passed, which is the number of iterations to perform."
    end if

    call get_command_argument(1, arg)
    read(arg,*) n
    call cpu_time(T1)
    mypi = calc_pi(n)
    call cpu_time(T2)
    write(*,'(a,f12.6)') "Calculated π = ", mypi
    write(*,'(a,f12.6)') "Actual π =     ", pi
    print *, 'The time usage is:',  T2-T1

end program main


PROGRAM roots

!  Purpose:
!    This program solves for the roots of a quadratic equation of the
!    form a*x**2 + b*x + c = 0.  It calculates the answers regardless
!    of the type of roots that the equation possesses.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/06/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare variable types, definitions, & units
REAL :: a              ! Coefficient of x**2 term of equation
REAL :: b              ! Coefficient of x term of equation
REAL :: c              ! Constant term of equation
REAL :: discriminant   ! Discriminant of the equation
REAL :: imag_part      ! Imaginary part of equation (for complex roots)
REAL :: real_part      ! Real part of equation (for complex roots)
REAL :: x1             ! First solution of equation (for real roots)
REAL :: x2             ! Second solution of equation (for real roots)

! Prompt the user for the coefficients of the equation
WRITE (*,*) 'This program solves for the roots of a quadratic '
WRITE (*,*) 'equation of the form A * X**2 + B * X + C = 0. '
WRITE (*,*) 'Enter the coefficients A, B, and C: '
READ  (*,*) a, b, c

! Echo back coefficients
WRITE (*,*) 'The coefficients A, B, and C are: ', a, b, c

! Calculate discriminant
discriminant = b**2 - 4. * a * c

! Solve for the roots, depending upon the value of the discriminant
IF ( discriminant > 0. ) THEN ! there are two real roots, so...

   x1 = ( -b + sqrt(discriminant) ) / ( 2. * a )
   x2 = ( -b - sqrt(discriminant) ) / ( 2. * a )
   WRITE (*,*) 'This equation has two real roots:'
   WRITE (*,*) 'X1 = ', x1
   WRITE (*,*) 'X2 = ', x2

ELSE ( discriminant < 0. ) THEN ! there are complex roots, so ...

   real_part = ( -b ) / ( 2. * a )
   imag_part = sqrt ( abs ( discriminant ) ) / ( 2. * a )
   WRITE (*,*) 'This equation has complex roots:'
   WRITE (*,*) 'X1 = ', real_part, ' +i ', imag_part
   WRITE (*,*) 'X2 = ', real_part, ' -i ', imag_part

ELSE IF ( discriminant == 0. ) THEN ! there is one repeated root, so...

   x1 = ( -b ) / ( 2. * a )
   WRITE (*,*) 'This equation has two identical real roots:'
   WRITE (*,*) 'X1 = X2 = ', x1

END IF

END PROGRAM roots


PROGRAM ball
!
!  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
!
IMPLICIT NONE

! 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.

! Loop over all specified angles.

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 PROGRAM ball


PROGRAM  question5
    IMPLICIT NONE

    REAL, ALLOCATABLE, DIMENSION(:, :) :: A, B, C, D
    INTEGER:: L, M, N, i, j, k

    WRITE(*, *) "A() is L by M .and. B() is M by N ==> So final result C() will be L by N"
    WRITE(*, *) "Please Enter L, M and N"
    READ(*, *) L, M, N
    ALLOCATE(A(L, M))
    ALLOCATE(B(M, N))
    ALLOCATE(C(L, N))
    ALLOCATE(D(L, N))

    WRITE(*, *) "Enter Matrix A()"
    DO i = 1, L
        READ(*, *) (A(i,j), j=1,M) ! A() is L-by-M
    ENDDO

    WRITE(*, *) "Enter Matrix B()"
    DO i = 1, M
        READ(*, *) (B(i,j), j=1, N) ! B() is M-by-N
    ENDDO

    DO i = 1, L
        DO j = 1, N
            C(i,j) = 0
            DO k = 1, M                         ! (row i of A)*(col j of B)
                C(i,j) = C(i,j) + A(i,k)*B(k,j)
            ENDDO
        ENDDO
    ENDDO

    WRITE(*, *)
    WRITE(*, *) "Matrix C:"
    DO i = 1, L
        Write(*, *) (C(i,j), j=1,N)
    ENDDO
    WRITE(*, *)

    D = matmul(a, b)
    WRITE(*, *) "Matrix D: (calculated from matmul library)"
    DO i = 1, L
        Write(*, *) (D(i,j), j=1,N)
    ENDDO

    WRITE(*, *)
    IF(All(C == D)) WRITE(*, *) "C and D is same."

END


! Created by EverLookNeverSee@GitHub on 5/25/20.
! This program computes the product of two given matrices.

program matrix_product
    implicit none
    ! declaring variables
    integer :: m, n, o, p, i, j, k
    ! declaring matrices
    real, allocatable, dimension(:,:) :: A, B, C

    print *, "Matrix A:"
    do
        print *, "Enter number of rows and columns for matrix A:"
        read *, m, n
        if (m <= 0 .or. n <= 0) then
            print *, "number of rows and columns should be positive integers"
            print *, "*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*"
            cycle
        end if
        exit
    end do

    print *, "Matrix B:"
    do
        print *, "Enter number of rows and columns for matrix B:"
        read *, o, p
        if (o <= 0 .or. p <= 0) then
            print *, "number of rows and columns should be positive integers"
            print *, "*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*-*"
            cycle
        end if
        if (n /= o) then
            print *, "Number columns in matrix A should be equal to number of rows in matrix B."
            cycle
        end if
        exit
    end do

    ! Allocating memory space for matrices
    allocate(A(m, n))
    allocate(B(o, p))
    allocate(C(m, p))

    ! Getting elements of matrix A from user
    print *, "Getting elements of matrix A:"
    do i = 1, m
        do j = 1, n
            print *, "A(", i, j, "):"
            read*, A(i, j)
        end do
    end do
    ! Getting elements of matrix B from user
    print *, "Getting elements of matrix B:"
    do i = 1, o
        do j = 1, p
            print *, "B(", i, j, "):"
            read*, B(i, j)
        end do
    end do

    ! computing prodcut operation
    do i = 1, m
        do j = 1, p
            C(i, j) = 0.0
            do k = 1, n
                C(i, j) = C(i, j) + A(i, k) * B(k, j)
            end do
        end do
    end do

    ! printing result
    print *, "Result -->", ((C(i, j), j = 1, p), i = 1, m)
end program matrix_product


!-----------------------------------------------------
!PHY1038 Assignment 1 - Newton-Raphson root finding
!URN 6309823 - Penguin Lab Group 1K
!February 24th 2015
!-----------------------------------------------------

PROGRAM Newton_Raphson
IMPLICIT NONE
REAL :: x,x1,a,b,c,d,t
INTEGER :: j,k

WRITE(6,*) " "
WRITE(6,*) " "
WRITE(6,*) "This program finds the roots of a cubic function using the Newton-Raphson method,"
WRITE(6,*) " "
WRITE(6,*) "i.e. it finds all possible values of x which satisfy the equation: f(x)=ax^3+bx^2+cx+d=0."
WRITE(6,*) " "
WRITE(6,*) " "

!I had to change this so that the coeficients are defined individually. Then I an input them into the cubic equation.

WRITE(6,*) "Please input a value for a."
READ(5,*) a
WRITE(6,*) " "
WRITE(6,*) "Please input a value for b."
READ(5,*) b
WRITE(6,*) " "
WRITE(6,*) "Please input a value for c."
READ(5,*) c
WRITE(6,*) " "
WRITE(6,*) "Please input a value for d."
READ(5,*) d
WRITE(6,*) " "
WRITE(6,*) " "
WRITE(6,*) "Make a guess as a first approximation to the root of the function (x); write down this value."
READ(5,*) x1
WRITE(6,*) " "
WRITE(6,*) " "

!'t' remains as the initial guess so that it can be referenced later

t=x1
x=x1

!This is a do loop which uses the formulat x1=x0-f(x0)/f'(x0) to find an estimate of a root of the cubic equation

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

k=1

DO j=1,100
  x1=x-(a*x**3+b*x**2+c*x+d)/(3*a*x**2+2*b*x+c)
    IF (ABS(x1-x) <1E-6) EXIT
  x=x1
  k=k+1
END DO

!------------------------------------------------------
WRITE(6,*) "The cubic equation in question is:",a,"x^3+",b,"x^2+",c,"x+",d
WRITE(6,*) " "
WRITE(6,*) "This is a root of the cubic equation to a tolerance of 10^-6:", x1
WRITE(6,*) " "
WRITE(6,*) "It took",k,"iterations to find this root"
WRITE(6,*) " "
WRITE(6,*) "The initial guess for a root of the cubic equation was:",t
WRITE(6,*) " "
WRITE(6,*) "Please repeat this program with different values for the initial guess until three roots of the cubic equation are found"

END PROGRAM Newton_Raphson


function derivs_1g(t, x)
  implicit none
  double precision :: derivs_1g
  double precision,intent(in) :: t, x
  double precision ::  g = (50.d0), k = (0.1d0)

  derivs_1g = g - k * x

end function derivs_1g

subroutine ode_1g_euler(x0,dt,nsteps,results)
  implicit none
  integer, intent(in) :: nsteps
  double precision, intent(in) :: x0, dt
  double precision, dimension(2, nsteps), intent(out) :: results
  double precision :: derivs_1g
  integer :: i, n
  double precision ::  t, x

  t = 0.d0
  x = x0
  do i = 1, nsteps
    t = t + dt
    x = x + derivs_1g(t, x) * dt
    results(1,i) = t
    results(2,i) = x
  enddo

end subroutine ode_1g_euler

subroutine ode_1g_rk2(x0,dt,nsteps,results)
  implicit none
  integer, intent(in) :: nsteps
  double precision, intent(in) :: x0, dt
  double precision, dimension(2, nsteps), intent(out) :: results
  double precision :: derivs_1g
  integer :: i, n
  double precision ::  t, x, k1, k2

  t = 0.d0
  x = x0
  do i = 1, nsteps
    k1 = derivs_1g(t,x) * dt
    t = t + dt
    k2 = derivs_1g(t,x+k1) * dt
    x = x + (k1+k2)/2.d0
    results(1,i) = t
    results(2,i) = x
  enddo
end subroutine ode_1g_rk2

subroutine ode_1g_rk4(x0,dt,nsteps,results)
  implicit none
  integer, intent(in) :: nsteps
  double precision, intent(in) :: x0, dt
  double precision, dimension(2, nsteps), intent(out) :: results
  double precision :: derivs_1g
  integer :: i, n
  double precision ::  t, x, k1, k2, k3, k4, dt05

  dt05 = dt/2.d0
  t = 0.d0
  x = x0
  do i = 1, nsteps
    k1 = derivs_1g(t,x) * dt
    t = t + dt05
    k2 = derivs_1g(t,x+k1/2.d0) * dt
    k3 = derivs_1g(t,x+k2/2.d0) * dt
    t = t + dt05
    k4 = derivs_1g(t,x+k3) * dt
    x = x + (k1+2.d0*k2+2.d0*k3+k4)/6.d0
    results(1,i) = t
    results(2,i) = x
  enddo
end subroutine ode_1g_rk4


submodule (m_maths) sm_maths_d1d
  !! Implement math routines for double precision arrays
implicit none

contains
  !====================================================================!
  module function crossProduct_d1D(a,b) result(res)
    !! Interfaced with crossproduct()
  !====================================================================!
  real(r64),intent(in) :: a(3) !! 1D Array
  real(r64),intent(in) :: b(3) !! 1D Array
  real(r64) :: res(3) !! cross product
  res(1)=a(2)*b(3)-a(3)*b(2)
  res(2)=a(3)*b(1)-a(1)*b(3)
  res(3)=a(1)*b(2)-a(2)*b(1)
  end function
  !====================================================================!
  !====================================================================!
  module function cumprod_d1D(this) result(res)
    !! Interfaced with cumprod()
  !====================================================================!
  real(r64),intent(in) :: this(:) !! 1D array
  real(r64) :: res(size(this)) !! Cumulative product
  integer(i32) :: i
  integer(i32) :: N
  N=size(this)
  res(1) = this(1)
  do i=2,N
    res(i) = res(i-1) * this(i)
  end do
  end function
  !====================================================================!
  !====================================================================!
  module function cumsum_d1D(this) result(res)
    !! Interfaced with cumsum()
  !====================================================================!
  real(r64),intent(in) :: this(:) !! 1D array
  real(r64) :: res(size(this)) !! Cumulative sum
  integer(i32) :: i
  integer(i32) :: N
  N=size(this)
  res(1) = this(1)
  do i=2,N
    res(i) = res(i-1) + this(i)  ! Round off error?
  end do
  end function
  !====================================================================!
  !====================================================================!
  module function geometricMean_d1D(this) result(res)
    !! Interfaced with geometricMean()
  !====================================================================!
  real(r64),intent(in) :: this(:)
  real(r64) :: res
  res=product(this)
  res=res**(dble(size(this)))
  end function
  !====================================================================!
  !====================================================================!
  module procedure Mean_d1D
    !! interface with mean()
  !====================================================================!
  !module function mean_d1D(this) result(res)
  !real(r64) :: this(:)
  !real(r64) :: res
  res=sum(this)/dble(size(this))
  end procedure
  !====================================================================!
  !====================================================================!
  module function median_d1D(this) result(res)
  !====================================================================!
    !! Interfaced with median()
  real(r64), intent(in) :: this(:) !! 1D array
  real(r64) :: res !! median
  integer(i32), allocatable :: i(:)
  integer(i32) :: iMed
  integer(i32) :: N

  integer(i32) :: iTmp

  N=size(this)
  call allocate(i,N)
  call arange(i,1,N)

  if (mod(N,2)==0) then
    iMed = N/2
    call argSelect(this, i, iMed, iTmp)
    res=this(iTmp)
    call arange(i,1,N)
    call argSelect(this, i, iMed+1, iTmp)
    res=0.5d0*(res+this(iTmp))
  else
    iMed=N/2 + 1
    call argSelect(this, i, iMed, iTmp)
    res = this(iTmp)
  end if

  deallocate(i)
  end function
  !====================================================================!
  !====================================================================!
  module procedure norm1_d1D
    !! interface with norm1()
  !====================================================================!
  !module function norm1_d1D(this) result(res)
  !real(r64) :: this(:)
  !real(r64) :: res
  res=sum(abs(this))
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure normI_d1D
    !! interface with normI()
  !====================================================================!
  !module function normI_d1D(this) result(res)
  !real(r64) :: this(:)
  !real(r64) :: res
  res=maxval(abs(this))
  end procedure
  !====================================================================!
!  !====================================================================!
!  module procedure normP_d1D
!    !! Interfaced with normP
!  !====================================================================!
!  !module function normP_d1D(this, p) result(res)
!  !real(r64) :: this(:)
!  !real(r64) :: p
!  !real(r64) :: res
!
!  end procedure
!  !====================================================================!
  !====================================================================!
  module function project_d1D(a,b) result(c)
  !====================================================================!
    !! Interfaced with project()
    real(r64),intent(in) :: a(:) !! 1D array
    real(r64),intent(in) :: b(size(a)) !! 1D array
    real(r64) :: c(size(a)) !! 1D array
    real(r64) :: c1
    ! Magnitude of b^2
    c1=norm2(b)**2.d0
    if (c1 == 0.0) then
      c=0.d0
      return
    end if
    c=b/c1
    ! Dot a onto b hat
    c1=dot_product(a,b)
    ! Multiply projected length by b hat
    c=c1*c
  end function
  !====================================================================!
  !====================================================================!
  module procedure trimmedmean_d1D
  !====================================================================!
  !function trimmedmean_d1D(this,alpha) result(res)
  !real(r64) :: this(:)
  !real(r64) :: alpha
  !real(r64) :: res
  integer(i32) :: istat
  integer(i32) :: j
  integer(i32) :: N
  integer(i32) :: tmp
  integer(i32), allocatable :: i(:)
  real(r64) :: alpha_

  real(r64), allocatable :: rTmp(:)

  N=size(this)
  alpha_=alpha*0.01d0
  ! Test the percentage
  if (alpha_ <= 0.d0) then
    res=Mean(this)
    return
  elseif (alpha_ >= 0.5d0) then
    call eMsg('trimmedmean:alpha >= 50% does not make sense')
  endif
  ! Calculate the number of integers that make up the trimmed percentage
  tmp=idnint(alpha_*dble(N))

  ! Set the indices into the vector
  call allocate(i, N)
  call arange(i, 1, N)

  ! Sort the vector
  call argSort(this,i)

  call allocate(rTmp, N-(2*tmp))
  rTmp =this(i(tmp+1:N-tmp))
  res=mean(rTmp)
  call deallocate(i)
  call deallocate(rTmp)
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure std_d1D
    !! Interfaced with std()
  !====================================================================!
  !real(r64) :: this(:)
  !real(r64) :: res
  res=dsqrt(Variance(this))
  end procedure
  !====================================================================!
  !====================================================================!
  module procedure variance_d1D
    !! Interfaced with variance()
  !====================================================================!
  !real(r64) :: this(:)
  !real(r64) :: res
  real(r64) :: tmp
  real(r64), allocatable :: rTmp(:)
  tmp=Mean(this)
  call allocate(rTmp, size(this))
  rTmp = this - tmp
  rTmp = rTmp ** 2.d0
  res=sum(rTmp)/dble(size(this)-1)
  call deallocate(rTmp)
  end procedure
  !====================================================================!
end submodule


      program matrix02
!
!     USAGE:
!       ./matrix02.exe <n>
!
!     ABOUT:
!     This program reads a size n from the command line, fills two (n x n)
!     matrices with random numbers, and evaluates the matrix product using
!     explicit loops. The program tracks the time taken for the
!     multiplication steps and reports is at the end.
!
!
!     AUTHOR:
!     H. P. Hratchian, 2020.
!
!
!     Variable Declarations
!
      implicit none
      integer::n,i,j,k
      integer,parameter::iOut=6
      real::tStart,tEnd
      real,dimension(:,:),allocatable::A,B,C
      character(len=256)::commandLineArg
      logical::fail=.false.
!
 1000 Format('Loop ',I1,': n = ',I10,'  Job Time: ',F10.3,' s.')
 9000 Format('Failure reading command line arguments...incorrect number.')
 9999 Format('The program FAILED!')
!
!     Read the user-specified matrix dimension, n, from the command line.
!
      if(COMMAND_ARGUMENT_COUNT().ne.1) then
        write(iOut,9000)
        fail = .true.
        goto 999
      endIf
      call GET_COMMAND_ARGUMENT(1,commandLineArg)
      read(commandLineArg,*) n
!
!     Allocate matrices A, B, and C. Then, fill A and B with random numbers.
!
      Allocate(A(n,n),B(n,n),C(n,n))
      call random_number(A)
      call random_number(B)
      C = 0
!
!     Carry out matrix multiplication using explicit nested loops.
!
      call CPU_TIME(tStart)
      do i = 1,n
        do j = 1,n
          do k = 1,n
            C(i,j) = C(i,j) + A(i,k)*B(k,j)
          endDo
        endDo
      endDo
      call CPU_TIME(tEnd)
      write(iOut,1000) 1,n,tEnd-tStart
!
!     Carry out matrix multiplication using explicit nested loops, using
!     approach 2.
!
      C = 0
      call CPU_TIME(tStart)
      do k = 1,n
        do i = 1,n
          do j = 1,n
            C(i,j) = C(i,j) + A(i,k)*B(k,j)
          endDo
        endDo
      endDo
      call CPU_TIME(tEnd)
      write(iOut,1000) 2,n,tEnd-tStart
!
!     Carry out matrix multiplication using explicit nested loops, using
!     approach 3.
!
      C = 0
      call CPU_TIME(tStart)
      do k = 1,n
        do j = 1,n
          do i = 1,n
            C(i,j) = C(i,j) + A(i,k)*B(k,j)
          endDo
        endDo
      endDo
      call CPU_TIME(tEnd)
      write(iOut,1000) 3,n,tEnd-tStart
!
  999 if(fail) write(iOut,9999)
      end program matrix02


module integrals
  !! module for computing integrals
  implicit none
contains

  function trapz(x,y) result(Int)
    !! Aproximates the integral of the function
    !! $$ y = f(x)$$
    !! given a set of points:
    !! $$(x_i,y_i)$$
    !! using the trapezoidal rule.
    !! The points do not need to be linearly spaced along the
    !! integration domain.
    real, intent(in) :: x(0:)
    !! Array containing the abscissas of the points
    real, intent(in) :: y(0:)
    !! Array containing the ordinates of the points
    real :: Int
    !! Numerical aproximation to the integral

    integer :: i, N

    N = ubound(x,1)
    Int = 0.
    do i = 1,N
      Int = Int + (y(i-1)+y(i))/2*(x(i)-x(i-1))
    end do
  end function

  function quad_trapz(f,a,b,h_in) result(Int)
    !! Approximates the integral:
    !! $$ \int_{a}^{b}f\left(x\right)\,\mathrm{d}x$$
    !! using the trapezoidal rule on a linearly spaced
    !! set of points.
    interface
      function f(x) result(y)
        !! Function to be integrated
        real, intent(in) :: x
        !! independent variable
        real :: y
        !! dependent variable
      end function
    end interface
    real, intent(in) :: a
    !! Lower limit of integration
    real, intent(in) :: b
    !! Upper limit of integration
    real, intent(in) :: h_in
    !! Approximated size of the intervals used by the trapezoidal rule.
    real :: Int
    !! Numerical approximation to the integral

    integer :: i, N
    real :: h, x_l, x_r

    ! imposing that h must divide (b-a) in a whole number
    ! of intervals
    N = ceiling((b-a)/h_in)
    h = (b-a)/N

    Int = 0.
    do i=1,N
      x_l = (i-1)*h
      x_r = i*h
      Int = Int + (f(x_l)+f(x_r))/2
    end do
    Int = Int*h
  end function

function quad_simpson(f,a,b,h_in) result(Int)
  !! Approximates the integral:
  !! $$ \int_{a}^{b}f\left(x\right)\,\mathrm{d}x$$
  !! using Simpson's rule on a linearly spaced
  !! set of points.
  interface
    function f(x) result(y)
      !! Function to be integrated
      real, intent(in) :: x
      !! independent variable
      real :: y
      !! dependent variable
    end function
  end interface
  real, intent(in) :: a
  !! Lower limit of integration
  real, intent(in) :: b
  !! Upper limit of integration
  real, intent(in) :: h_in
  !! Approximated size of the intervals used by the trapezoidal rule.
  real :: Int
  !! Numerical approximation to the integral

  integer :: i, N
  real :: h, x_l, x_m, x_r

  ! imposing that h must divide (b-a) in an even number
  ! of intervals
  N = ceiling((b-a)/h_in)
  if(modulo(N,2)==1) N = N+1
  h = (b-a)/N

  Int = 0.
  do i=1,N,2
    x_l = (i-1)*h
    x_m = i*h
    x_r = (i+1)*h
    Int = Int + (f(x_l)+4*f(x_m)+f(x_r))/3
  end do
  Int = Int*h
end function

function quad(f,a,b,h_in,method) result(Int)
  !! Approximates the integral:
  !! $$ \int_{a}^{b}f\left(x\right)\,\mathrm{d}x$$
  !! using some integration method on a linearly spaced
  !! set of points.
  interface
    function f(x) result(y)
      !! Function to be integrated
      real, intent(in) :: x
      !! independent variable
      real :: y
      !! dependent variable
    end function
  end interface
  real, intent(in) :: a
  !! Lower limit of integration
  real, intent(in) :: b
  !! Upper limit of integration
  real, intent(in) :: h_in
  !! Approximated size of the intervals used by the trapezoidal rule.
  character(*) :: method
  !! Method of integration to be used, can be either "Trapezoidal" or "Simpson"
  real :: Int
  !! Numerical approximation to the integral
  select case (method)
  case ("Trapezoidal")
    Int = quad_trapz(f,a,b,h_in)
  case ("Simpson")
    Int = quad_simpson(f,a,b,h_in)
  case default
    print*, 'Integration method "'//method//'"" not recognised,'
    print*, 'please choose between "Trapezoidal" and "Simpson"'
  end select
end function
end module


SUBROUTINE matrix_inv3 (R1, Rinv)

! ----------------------------------------------------------------------
! SUBROUTINE: matrix_inv3.f90
! ----------------------------------------------------------------------
! Purpose:
!  3x3 Matrix inversion
! ----------------------------------------------------------------------
! Input arguments:
! - R1: 			Array 3x3
!
! Output arguments:
! - Rinv : 			Inverse matrix of input matrix 3x3
! ----------------------------------------------------------------------
! Thomas D. Papanikolaou, Geoscience Australia              30 June 2016
! ----------------------------------------------------------------------

      USE mdl_precision
      IMPLICIT NONE

! ---------------------------------------------------------------------------
! Dummy arguments declaration
! ---------------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN) :: R1(3,3)
! OUT
      REAL (KIND = prec_q), INTENT(OUT) :: Rinv(3,3)
! ---------------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q) :: Det_R
      REAL (KIND = prec_q) :: Cof_R(3,3), Adj_R(3,3)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Determinant of R1
      Det_R =    R1(1,1) * (R1(2,2)*R1(3,3) - R1(2,3)*R1(3,2))  &
	           - R1(1,2) * (R1(2,1)*R1(3,3) - R1(2,3)*R1(3,1))  &
	           + R1(1,3) * (R1(2,1)*R1(3,2) - R1(2,2)*R1(3,1))
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Cofactor matrix
      Cof_R(1,1) =          ( R1(2,2)*R1(3,3) - R1(2,3)*R1(3,2) )
      Cof_R(1,2) = -1.0D0 * ( R1(2,1)*R1(3,3) - R1(2,3)*R1(3,1) )
      Cof_R(1,3) =          ( R1(2,1)*R1(3,2) - R1(2,2)*R1(3,1) )

      Cof_R(2,1) = -1.0D0 * ( R1(1,2)*R1(3,3) - R1(1,3)*R1(3,2) )
      Cof_R(2,2) =          ( R1(1,1)*R1(3,3) - R1(1,3)*R1(3,1) )
      Cof_R(2,3) = -1.0D0 * ( R1(1,1)*R1(3,2) - R1(1,2)*R1(3,1) )

      Cof_R(3,1) =          ( R1(1,2)*R1(2,3) - R1(1,3)*R1(2,2) )
      Cof_R(3,2) = -1.0D0 * ( R1(1,1)*R1(2,3) - R1(1,3)*R1(2,1) )
      Cof_R(3,3) =          ( R1(1,1)*R1(2,2) - R1(1,2)*R1(2,1) )
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Adjoint matrix
      Adj_R = transpose (Cof_R)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Inverse matrix
      Rinv = (1.0D0 / Det_R) * Adj_R
! ----------------------------------------------------------------------

END


program problem_21
    implicit none
    integer :: divisorsSum, i, total
    logical :: areAmicable

    total = 0
    do i = 1, 10000
        if (areAmicable(i, divisorsSum(i))) then
            total = total + i
        endif
    enddo

    print *, total

end program problem_21

integer function divisorsSum(number) result(total)
    implicit none
    integer :: number, i
    total = 0

    do i = 1, number / 2
        if (modulo(number, i) .EQ. 0) then
            total = total + i
        endif
    enddo
end function divisorsSum

logical function areAmicable(a, b) result(decision)
    implicit none
    integer :: a, b, divisorsSum

    if ((divisorsSum(a) .EQ. b) .AND. (divisorsSum(b) .EQ. a) .AND. (a .NE. b)) then
        decision = .TRUE.
    else
        decision = .FALSE.
    endif
end function areAmicable


program test_bessel_zeros
use types, only: dp
use utils, only: assert
use constants, only: pi
use special, only: bessel_jn_zeros, spherical_bessel_jn, &
    spherical_bessel_jn_zeros
implicit none

real(dp), allocatable :: zeros(:, :)
integer :: n, nzeros

n = 5
nzeros = 10
allocate(zeros(nzeros, 0:n))
zeros = bessel_jn_zeros(n, nzeros, 1e-13_dp)

! The following numbers were checked against SciPy's:
!   scipy.special.jn_zeros(n, 10)
! and they all agree to all printed digits (with correct rounding)

call assert(abs(zeros( 1, 0) -  2.40482556_dp) < 1e-8_dp)
call assert(abs(zeros( 2, 0) -  5.52007811_dp) < 1e-8_dp)
call assert(abs(zeros(10, 0) - 30.63460647_dp) < 1e-8_dp)

call assert(abs(zeros( 1, 1) -  3.83170597_dp) < 1e-8_dp)
call assert(abs(zeros( 2, 1) -  7.01558667_dp) < 1e-8_dp)
call assert(abs(zeros(10, 1) - 32.18967991_dp) < 1e-8_dp)

call assert(abs(zeros( 1, 4) -  7.58834243_dp) < 1e-8_dp)
call assert(abs(zeros( 2, 4) - 11.06470949_dp) < 1e-8_dp)
call assert(abs(zeros(10, 4) - 36.69900113_dp) < 1e-8_dp)

call assert(abs(zeros( 1, 5) -  8.77148382_dp) < 1e-8_dp)
call assert(abs(zeros( 2, 5) - 12.33860420_dp) < 1e-8_dp)
call assert(abs(zeros(10, 5) - 38.15986856_dp) < 1e-8_dp)

! Test that things work for the special case n=0:

n = 0
nzeros = 10
deallocate(zeros)
allocate(zeros(nzeros, 0:n))
zeros = bessel_jn_zeros(n, nzeros, 1e-13_dp)

call assert(abs(zeros( 1, 0) -  2.40482556_dp) < 1e-8_dp)
call assert(abs(zeros( 2, 0) -  5.52007811_dp) < 1e-8_dp)
call assert(abs(zeros(10, 0) - 30.63460647_dp) < 1e-8_dp)

! Test spherical Bessel functions:
n = 5
nzeros = 10
deallocate(zeros)
allocate(zeros(nzeros, 0:n))
zeros = spherical_bessel_jn_zeros(n, nzeros, 1e-13_dp)

call assert(abs(zeros( 1, 0) -    pi) < 1e-8_dp)
call assert(abs(zeros( 2, 0) -  2*pi) < 1e-8_dp)
call assert(abs(zeros(10, 0) - 10*pi) < 1e-8_dp)

call assert(abs(zeros( 1, 1) -  4.49340946_dp) < 1e-8_dp)
call assert(abs(zeros( 2, 1) -  7.72525184_dp) < 1e-8_dp)
call assert(abs(zeros(10, 1) - 32.95638904_dp) < 1e-8_dp)

call assert(abs(zeros( 1, 4) -  8.18256145_dp) < 1e-8_dp)
call assert(abs(zeros( 2, 4) - 11.70490715_dp) < 1e-8_dp)
call assert(abs(zeros(10, 4) - 37.43173677_dp) < 1e-8_dp)

call assert(abs(zeros( 1, 5) -  9.35581211_dp) < 1e-8_dp)
call assert(abs(zeros( 2, 5) - 12.96653017_dp) < 1e-8_dp)
call assert(abs(zeros(10, 5) - 38.88363096_dp) < 1e-8_dp)

end program


! Number F(46) is the highest allowed for integer(kind=4).  The next number,
! F(47) creates an integer overflow and produces a negative result.
!
! To test yourself, get the table of F(i) values from here:
!
!   https://oeis.org/A000045/b000045.txt
!
program fibonacci_sequential
    implicit none
    integer :: i

    print '(a)', "Enter index `i` for the Fibonacci sequence"
    read *, i
    print '(2(a, i0))', "F(", i, ") = ", fib_seq(i)
contains
    function fib_seq(n)
        integer :: fib_seq
        integer, intent(in) :: n
        integer :: j, f_pp, f_p, f

        f_pp = 0
        f_p  = 1
        do j = 2, n
            f    = f_p + f_pp
            f_pp = f_p
            f_p  = f
        end do
        fib_seq = f
        return
    end function fib_seq
end program fibonacci_sequential


program main_bisection
    implicit none
    real x1,x2,x,eps,xcosx
    external xcosx
    integer ind
    x1=0
    x2=3.14
    eps=1e-7
    call bisection(xcosx,x1,x2,x,eps,ind)
    if (ind>=0) then
        print *,'X= ',x,xcosx(x),ind
    else if (ind==-1) then
        print *,'f(x1)*f(x2) must be less than 0'
    else
        print *,'No Convergence'
    endif
end program main_bisection

function xcosx(x)
    real xcosx,x
    xcosx = x-cos(x)
end function xcosx

subroutine bisection(func,x10,x20,x,eps,ind)
    implicit none
    real func,x10,x20,x,eps,x1,x2,y1,y2,xm,ym
    external func
    integer ind,it
    integer, parameter :: itmax=100000000

    x1=x10
    x2=x20
    y1=func(x1)
    y2=func(x2)
    ind=0
    if(y1==0) then
        x=x1
        return
    else if (y2==0) then
        x=x2
        return
    else if(y1*y2>0) then
        ind=-1
        return
    endif

    do it = 1, itmax
        xm=(x1+x2)/2
        ym=func(xm)
        if(ym==0) then
            x=xm
            exit
        endif
        if(ym*y1<0) then
            x2=xm
            y2=ym
        else
            x1=xm
            y1=ym
        endif
        if(abs(x2-x1)<eps) then
            x=xm
            exit
        endif
    enddo

    if(it>itmax) then
        ind=-itmax
    else
        ind=it
    endif

end subroutine bisection


module chebyshev_mod

use constants

contains
    function chebT (n,x)

        implicit none

        integer, intent(in) :: n
        real, intent(in) :: x
        real :: chebT

        if(abs(x)>1) then
            write(*,*) 'ERROR: chebT arg abs(x)>1', x
        endif

        if(x==1.0)then
            chebT = 1
        elseif(x==-1.0)then
            chebT = (-1)**n
        else
            !chebT = ( ( x - sqrt ( x**2 - 1 ) )**n &
            !    + ( x + sqrt ( x**2 - 1 ) )**n ) / 2d0
            chebT = cos ( n * acos(x) )
        endif

    end function chebT

    function chebU (n,x)

        implicit none

        integer, intent(in) :: n
        real, intent(in) :: x
        real(kind=dbl) :: chebU

        if(x==1.0) then
            chebU   = n + 1
        elseif(x==-1.0) then
            chebU   = (n+1) * (-1)**n
        else

            !chebU   = ( ( x + sqrt ( x**2 - 1 ) )**(n+1) &
            !    - ( x - sqrt ( x**2 - 1 ) )**(n+1) ) &
            !    / ( 2d0 * sqrt ( x**2 - 1 ) )

            chebU   = sin ( (n+1) * acos(x) ) / sin ( acos(x) )

        endif

    end function chebU

end module chebyshev_mod


! =====================================================================
! function FACTORIAL
!
! factorial is an function that recursively computes the value of the
! factorial of integer n.
! ---------------------------------------------------------------------
      INTEGER RECURSIVE FUNCTION factorial ( n ) RESULT ( nFactorial )

      IMPLICIT NONE

      INTEGER, INTENT ( IN ) :: n

      nFactorial = 0

      IF ( n == 0 ) THEN

         nFactorial = 1

      ELSE IF ( n >= 1 .AND. n <= 12 ) THEN

         nFactorial = n * factorial ( n - 1 )

      ELSE

         nFactorial = -1
         WRITE ( UNIT = 6 , FMT = * ) 'math : factorial :: &
            & ERROR - n must be an integer greater than or equal to 0, &
            & but less than or equal to 12 because KIND ( n ) may be a &
            & 32-bit integer.'
         STOP

      END IF

      RETURN
      END FUNCTION
! =====================================================================


program main
use calculates
implicit none

real(kind=8), dimension(3,3) :: A, A_work
real(kind=8), dimension(3) :: B, X, Y
real(kind=8) :: det_A, det_A_work, test, test2
integer :: i, j, k, l

! assign values:

A = reshape( (/2, 7, 2, 7, 3, 4, 3, 9, 6/) , (/3,3/))
write(*,*) "Matrix A:"
call writes(A)

B = (/10, 11, 6/)

Y = (/0.0495, 1.3465, 0.1584/)
write(*,'(A12,3F8.3)') "Vector B:", B
write(*,*)

det_A = determinant(A)

write(*,*) "det_A:", det_A
write(*,*)

! Find x:

do i = 1, 3
   write(*,*) "---------------------------------------------"
   write(*,'(A15,I5)') "iteration:", i
   write(*,*) "---------------------------------------------"
   ! make A and A_work equal:
   do k = 1, 3
      do l = 1, 3
         A_work(k,l) = A(k,l)
      end do
   end do
   write(*,*) "working array before column change"
   call writes(A_work)
   !substitute the ith column of b in A_work:
   do j = 1, 3
      A_work(j,i) = B(j)
   end do
   write(*,*) "working array after column change"
   call writes(A_work)
   det_A_work = determinant(A_work)
   write(*,*) "determinant of the working array:", det_A_work
   write(*,*)
   X(i) = det_A_work/det_A
   write(*,'(A5,I1,A3,F8.3)') "   X(",i,")   ", X(i)
   write(*,*)
end do

write(*,*) "---------------------------------------------"
write(*,'(A15)') "solution:"
write(*,*) "---------------------------------------------"
write(*,*)
write(*,'(A12,3F8.3)') "Vector X:", X
write(*,*)

! Check solution:

do i = 1, 3
   test = 0.0d0
   test2 = 0.0d0
   do j = 1, 3
      test = test + A(i,j)*X(j)
      test2 = test2 + A(i,j)*Y(j)
   end do
   write(*,'(A14,I1,A13,F6.3,A9,F6.3,A9,F6.3)') "check for row ", i, " =>   AX(i): ", test, "   B(i): ", B(i), "  AY(i): ", test2
end do

end program main


!*******************************************************
!*    LU decomposition routines used by test_lu.f90    *
!*                                                     *
!*                 F90 version by J-P Moreau, Paris    *
!* --------------------------------------------------- *
!* Reference:                                          *
!*                                                     *
!* "Numerical Recipes By W.H. Press, B. P. Flannery,   *
!*  S.A. Teukolsky and W.T. Vetterling, Cambridge      *
!*  University Press, 1986" [BIBLI 08].                *
!*                                                     *
!*******************************************************
MODULE LU

CONTAINS

!  ***************************************************************
!  * Given an N x N matrix A, this routine replaces it by the LU *
!  * decomposition of a rowwise permutation of itself. A and N   *
!  * are input. INDX is an output vector which records the row   *
!  * permutation effected by the partial pivoting; D is output   *
!  * as -1 or 1, depending on whether the number of row inter-   *
!  * changes was even or odd, respectively. This routine is used *
!  * in combination with LUBKSB to solve linear equations or to  *
!  * invert a matrix. Return code is 1, if matrix is singular.   *
!  ***************************************************************
 Subroutine LUDCMP(A,N,INDX,D,CODE)
 PARAMETER(NMAX=200)
 REAL*16  AMAX,DUM, SUM, VV(NMAX)
 real*16 A(N,N)
 INTEGER CODE, D, INDX(N)
 real*16 TINY
 TINY = 1.0q-40

 D=1; CODE=0

 DO I=1,N
   AMAX=0.q0
   DO J=1,N
     IF (ABS(A(I,J)).GT.AMAX) AMAX=ABS(A(I,J))
   END DO ! j loop
   IF(AMAX.LT.TINY) THEN
     CODE = 1
     RETURN
   END IF
   VV(I) = 1.q0 / AMAX
 END DO ! i loop

 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 ! k loop
     A(I,J) = SUM
   END DO ! i loop
   AMAX = 0.q0
   DO I=J,N
     SUM = A(I,J)
     DO K=1,J-1
       SUM = SUM - A(I,K)*A(K,J)
     END DO ! k loop
     A(I,J) = SUM
     DUM = VV(I)*ABS(SUM)
     IF(DUM.GE.AMAX) THEN
       IMAX = I
       AMAX = DUM
     END IF
   END DO ! i loop

   IF(J.NE.IMAX) THEN
     DO K=1,N
       DUM = A(IMAX,K)
       A(IMAX,K) = A(J,K)
       A(J,K) = DUM
     END DO ! k loop
     D = -D
     VV(IMAX) = VV(J)
   END IF

   INDX(J) = IMAX
   IF(ABS(A(J,J)) < TINY) A(J,J) = TINY

   IF(J.NE.N) THEN
     DUM = 1.q0 / A(J,J)
     DO I=J+1,N
       A(I,J) = A(I,J)*DUM
     END DO ! i loop
   END IF
 END DO ! j loop

 RETURN
 END subroutine LUDCMP

!  ******************************************************************
!  * Solves the set of N linear equations A . X = B.  Here A is     *
!  * input, not as the matrix A but rather as its LU decomposition, *
!  * determined by the routine LUDCMP. INDX is input as the permuta-*
!  * tion vector returned by LUDCMP. B is input as the right-hand   *
!  * side vector B, and returns with the solution vector X. A, N and*
!  * INDX are not modified by this routine and can be used for suc- *
!  * cessive calls with different right-hand sides. This routine is *
!  * also efficient for plain matrix inversion.                     *
!  ******************************************************************
 Subroutine LUBKSB(A,N,INDX,B)
 implicit none
 REAL*16  SUM
 real*16 A(N,N), B(N)
 INTEGER INDX(N)
 integer II, I, LL, J, N

 II = 0

 DO I=1,N
   LL = INDX(I)
   SUM = B(LL)
   B(LL) = B(I)
   IF(II.NE.0) THEN
     DO J=II,I-1
       SUM = SUM - A(I,J)*B(J)
     END DO ! j loop
   ELSE IF(SUM.NE.0.q0) THEN
     II = I
   END IF
   B(I) = SUM
 END DO ! i loop

 DO I=N,1,-1
   SUM = B(I)
   IF(I < N) THEN
     DO J=I+1,N
       SUM = SUM - A(I,J)*B(J)
     END DO ! j loop
   END IF
   B(I) = SUM / A(I,I)
 END DO ! i loop

 RETURN
 END subroutine LUBKSB

END MODULE LU

! end of file lu.f90


! ****************************************************************************
! ... Module for variable types
! ... COSMO Project
! ... Quim Ballabrera, March 2017
! ****************************************************************************

MODULE constants

USE types, ONLY: sp,dp

IMPLICIT NONE

PRIVATE
PUBLIC pi,e_,nan,inf,deg2rad,rad2deg,i_,dpi,hpi
PUBLIC zero,one,half,two,ten,hundred
PUBLIC nan4,inf4
PUBLIC grav,Rearth,Omega

! ... Mathematical constants
! ...
REAL(dp), PARAMETER    :: zero    = 0.0_dp
REAL(dp), PARAMETER    :: one     = 1.0_dp
REAL(dp), PARAMETER    :: two     = 2.0_dp
REAL(dp), PARAMETER    :: half    = 0.5_dp
REAL(dp), PARAMETER    :: ten     = 10.0_dp
REAL(dp), PARAMETER    :: hundred = 100.0_dp
REAL(dp), PARAMETER    :: pi      = 3.1415926535897932384626433832795_dp
REAL(dp), PARAMETER    :: dpi     = 2.0_dp*pi
REAL(dp), PARAMETER    :: hpi     = 0.5_dp*pi
REAL(dp), PARAMETER    :: e_      = 2.7182818284590452353602874713527_dp
REAL(dp), PARAMETER    :: nan     = 0.0_dp/0.0_dp
REAL(dp), PARAMETER    :: inf     = 1.0_dp/0.0_dp
REAL(DP), PARAMETER    :: deg2rad = pi/180.0_dp
REAL(DP), PARAMETER    :: rad2deg = 180.0_dp/pi
COMPLEX(dp), PARAMETER :: i_      = (0.0_dp, 1.0_dp)

REAL(sp), PARAMETER    :: nan4    = 0.0_sp/0.0_sp
REAL(sp), PARAMETER    :: inf4    = 1.0_sp/0.0_sp

! ... Physical constants
! ...
REAL(DP), PARAMETER    :: grav    = 9.80665_dp     ! m / s^2
REAL(DP), PARAMETER    :: Rearth  = 6371229.0_dp   ! m
REAL(DP), PARAMETER    :: Omega   = 7.292E-5_dp    ! 1/s

END MODULE constants


!      This program solves Newton's equation for a block
!      sliding on a horizontal frictionless surface. The block
!      is tied  to a wall with a spring, and Newton's equation
!      takes the form
!           m d^2x/dt^2 =-kx
!      with k the spring tension and m the mass of the block.
!      The angular frequency is omega^2 = k/m and we set it equal
!      1 in this example program.
!      Newton's equation is rewritten as two coupled differential
!      equations, one for the position x  and one for the velocity v
!           dx/dt = v    and
!           dv/dt = -x   when we set k/m=1
!      We use therefore a two-dimensional array to represent x and v
!      as functions of t
!      y[0] == x
!      y[1] == v
!      dy[0]/dt = v
!      dy[1]/dt = -x
!      The derivatives are calculated by the user defined function
!      derivatives.
!      The user has to specify the initial velocity (usually v_0=0)
!      the number of steps and the initial position. In the programme
!      below we fix the time interval [a,b] to [0,2*pi].
!
!
!
!
!  this is the number of differential equations  as a global parameter

MODULE parameters
  INTEGER, PARAMETER, PUBLIC :: number_differential_eqs =2
END MODULE parameters
!
!     Main function begins here
!
PROGRAM diff_solver
  USE constants
  USE parameters
  IMPLICIT NONE
  REAL(DP), DIMENSION(number_differential_eqs) :: y, dydt, yout
  REAL(DP) ::  t, h, tmax, E0, initial_x, initial_v
  INTEGER :: i, number_of_steps

  !  read in the initial position, velocity and number of steps
  CALL initialise (initial_x, initial_v, number_of_steps)
  !  setting initial values, step size and max time tmax
  h = 2.0_dp*acos(-1.0_dp)/FLOAT(number_of_steps)   ! the step size
  tmax = h*number_of_steps                  ! the final time
  y(1) = initial_x                          ! initial position
  y(2) = initial_v                          ! initial velocity
  t=0.0_dp                                      ! initial time
  E0 = 0.5_dp*(y(1)**2+y(2)**2)                ! the initial total energy
  ! now we start solving the differential equations using the RK4 method
  OPEN(6,FILE='outf.dat')
  yout = 0.0_dp; dydt = 0.0_dp
  DO WHILE (t <= tmax)
     ! initial derivatives
     CALL derivatives(t, y, dydt)
     ! here we call the runge-kutta method and get the new y-value in yout
     CALL runge_kutta_4(y, t, h,yout,dydt)
     y = yout
     t = t + h
     ! writing time, x, v, the exact solution, and the energy difference
     WRITE(6,'(5(E12.6,1X))') t, y(1), y(2), cos(t),0.5*(y(1)**2+y(2)**2)-E0
  ENDDO
  CLOSE (6)

END PROGRAM diff_solver
!
!   this function sets up the derivatives for this special case
!
SUBROUTINE derivatives(t, y, dydt)
  USE constants
  USE parameters
  IMPLICIT NONE
  REAL(DP), DIMENSION(number_differential_eqs) :: y, dydt
  REAL(DP) :: t

  dydt(1)=y(2);    ! derivative of x
  dydt(2)=-y(1); ! derivative of v

END SUBROUTINE derivatives
!
!     The function initialise
!     Reads in from screen the air temp, the number of steps
!     final time and the initial temperature
!
SUBROUTINE initialise(initial_x, initial_v, number_of_steps)
  USE constants
  IMPLICIT NONE
  INTEGER, INTENT(OUT) :: number_of_steps
  REAL(DP), INTENT(OUT) :: initial_x, initial_v

  WRITE(*,*) ' Read in from screen intial x, initial v, and number of steps'
  READ(*,*) initial_x, initial_v, number_of_steps

END SUBROUTINE initialise
!
!     Runge-kutta procedure
!
SUBROUTINE runge_kutta_4(y,x,diff_eq_step,yout,dydx)
  USE constants
  USE parameters
  IMPLICIT NONE
  REAL(DP), DIMENSION(number_differential_eqs) :: yt, dyt, dym
  REAL(DP), DIMENSION(number_differential_eqs), INTENT(IN) :: y, dydx
  REAL(DP), DIMENSION(number_differential_eqs), INTENT(OUT) :: yout
  REAL(DP) :: hh, h6, xh
  REAL(DP), INTENT(IN) :: x, diff_eq_step

  hh=diff_eq_step*0.5; h6=diff_eq_step/6. ; xh=x+hh
  !     first rk-step
  yt=y+hh*dydx
  CALL derivatives(xh,yt,dyt)
  !     second rk-step
  yt=y+hh*dyt
  CALL derivatives(xh,yt,dym)
  !     third rk-step
  yt=y+diff_eq_step*dym;  dym=dyt+dym
  CALL derivatives(x+diff_eq_step,yt,dyt)
  !     fourth rk-step
  yout=y+h6*(dydx+dyt+2.*dym)

END SUBROUTINE runge_kutta_4


module procedures
implicit none
contains

!----------------------------
! Function to solve:
!----------------------------

real(kind=8) function g (x)
   real(kind=8), intent (in) :: x
   real(kind=8) :: m, k, c, A

   m = 2000.0d0
   k = 500.0d0
   c = 38*(10**(3))
   A = 0.2

   g = A*A*k*k - A*A*k*m*x*x + A*A*x*x*c*c - m*c*x*x*x
end function g

!----------------------------
! Bisection routine:
!----------------------------

subroutine BisectionRoot (Fun, a, b, ToolMax, Xs)

   real(kind=8), intent(in) :: ToolMax
   real(kind=8), intent(inout) :: a, b
   real(kind=8), intent(out) :: Xs
   interface
      real(kind=8) function Fun(x)
         real(kind=8), intent (in) :: x
      end function
   end interface
   real(kind=8) :: n, ConvergenceTest
   integer :: i

   ! Determine n; check if a and b are positioned properly:

   n = nint( (log10(b-a) - log10(ToolMax)) / log10(2.0d0) )
   write(*,'(A6F7.3)') " n >= ", n

   if (Fun(a)*Fun(b) > 0) then
      write(*,*) "f(a) and f(b) are not on opposite sides of the root. Cannot apply the bisection method "
      stop
   end if

   !Solve the function:

   write(*,'(6A15)') "   iteration:  ", "       a       ", &
      "        b        ", "(xNS) Solution", "      f(xNS)    ", "   Tolerance   "

   i = 0
   ConvergenceTest = 10
   do while (ConvergenceTest > ToolMax)

      i = i + 1
      if (i > n + 50) then
         write(*,*) "convergence could not be reached in the number of intervals)"
         stop
      end if

      Xs = (a+b)/2.0d0
      if (Fun(a)*Fun(Xs) < -0.00000000001) then
         b = Xs
      else if (Fun(a)*Fun(Xs) > 0.00000000001) then
         a = Xs
      else
         ConvergenceTest = abs(Fun(Xs))
         write(*,'(A6,I2,A7,3F15.11,F15.2,F15.11)') " ", i, " ", a, b, Xs, Fun(Xs), ConvergenceTest
         write(*,*) "convergence reached"
         exit
      end if

      ConvergenceTest = abs(Fun(Xs))
      write(*,'(A6,I2,A7,3F15.11,F15.2,F15.4)') " ", i, " ", a, b, Xs, Fun(Xs), ConvergenceTest

   end do

end subroutine BisectionRoot

end module procedures


module PI

    implicit none

    contains

    function factorial(n) result (y)
        integer, intent(in) :: n
        integer             :: y

        integer             :: i

        y = 1
        do i = 2, n
            y = y*i
        end do
    end function

    ! n should be less than 17, or it will overflow.
    function sint(n, x) result (y)
        integer, intent(in) :: n
        real, intent(in)    :: x
        real                :: y

        integer             :: i
        real                :: coeff
        y = x
        coeff = x
        do i = 3, n, 2
            coeff = -coeff*x*x
            !print *, i, coeff, factorial(i)
            y = y + coeff/factorial(i)
        end do
    end function
end module PI

program test

    use PI

    implicit none
    real, parameter     :: PIC = 4*atan(1d0)
    real, parameter     :: EVAL_MAX = 2*PIC
    integer, parameter  :: EVAL_SEGMENTS = 200

    call evalSine()
    call compareSine()

    contains

    subroutine evalSine()
        integer         :: i
        real            :: x

10      format(F16.9, F16.9)

        open(unit=10, file="sinx_Taylor_5.txt", status="replace")
        open(unit=11, file="sinx_Taylor_10.txt", status="replace")
        do i = 0, EVAL_SEGMENTS
            x = EVAL_MAX/EVAL_SEGMENTS*i
            write (10, 10), x, sint(5, x)
            write (11, 10), x, sint(10, x)
        end do
        close(10)
        close(11)
    end subroutine

    subroutine compareSine()
        integer         :: i
        real, dimension(EVAL_SEGMENTS + 1) :: x, y5, y10
        real            :: dummy

        open(unit=10, file="sinx_Taylor_5.txt", status="old")
        open(unit=11, file="sinx_Taylor_10.txt", status="old")
        do i = 1, EVAL_SEGMENTS + 1
            read (10, *), x(i), y5(i)
            read (11, *), dummy, y10(i)
        end do
        close(10)
        close(11)

        open(unit=12, file="sinx_Taylor_5_10_error.txt", status="replace")
        do i = 1, EVAL_SEGMENTS + 1
            write (12, "(F12.6, F12.6)"), x(i), y10(i) - y5(i)
        end do
        close(12)

    end subroutine

end program


C$Procedure            GCD ( Greatest Common Divisor )

      INTEGER FUNCTION GCD ( A, B )

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

      INTEGER          A
      INTEGER          B

C$ Brief_I/O
C
C      VARIABLE  I/O  DESCRIPTION
C      --------  ---  --------------------------------------------------
C      A          I   Any integer
C      B          I   Any integer
C      GCD        I   The greatest common divisor of A and B.
C
C$ Detailed_Input
C
C      A          An integer
C
C      B          An integer
C
C$ Detailed_Output
C
C      GCD        The greatest common divisor of A and B.
C
C$ Parameters
C
C      None.
C
C$ Exceptions
C
C     Error free.
C
C     1) If both A and B are zero, we return 0 as the GCD.
C
C     2) If exactly one of A and B is zero, then the GCD is by
C        definition the maximum of the absolute values of A and B.
C
C$ Particulars
C
C      This routine uses Euclid's Algorithm to find the greatest common
C      divisor (GCD) of the integers A and B.  In other words the
C      largest integer, G, such that A = k*G for some k and B = j*G for
C      some G.  Note if either A or B is zero, then we return the
C      maximum of the two integers ABS(A) and ABS(B).  If one is
C      non-zero we have just what the definition says.  If both are zero
C      the definition above does not give us a GCD, so we take the GCD
C      of 0 and 0 to be 0.
C
C
C$ Examples
C
C      A      B            GCD
C    -----  -----         -----
C      8      4             4
C     120    44             4
C     15    135            15
C    101     97             1
C    119    221            17
C    144     81             9
C      0    111           111
C      0      0             0
C
C$ Restrictions
C
C      None.
C
C$ Files
C
C      None.
C
C$ Author_and_Institution
C
C      W.L. Taber      (JPL)
C
C$ Literature_References
C
C      The Art of Computer Programming Vol 1. "Fundamental Algorithms"
C      by Donald Knuth
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 31-JAN-1990 (WLT)
C
C-&

C$ Index_Entries
C
C     greatest common divisor
C
C-&

C$ Revisions
C
C-     Beta Version 1.0.1, 29-DEC-1988 (WLT)
C
C      This revision simply cleared up questions regarding the input of
C      zeros to the routine.
C
C-&

C
C     Local variables
C
      INTEGER          REMNDR
      INTEGER          ABSA
      INTEGER          ABSB
      INTEGER          P
      INTEGER          Q

      ABSA = ABS(A)
      ABSB = ABS(B)

      IF ( ABSA .GT. ABSB ) THEN
         P = ABSA
         Q = ABSB
      ELSE
         P = ABSB
         Q = ABSA
      END IF

      REMNDR = 1

      IF ( Q .NE. 0 ) THEN

         DO WHILE (REMNDR .NE. 0 )
            GCD    = Q
            REMNDR = P - (P/Q)*Q
            P      = Q
            Q      = REMNDR
         END DO

      ELSE

      GCD = P

      END IF

      RETURN

      END


	SUBROUTINE GDIGIT  ( ival, ibase, ndig, idigs, iret )
C************************************************************************
C* GDIGIT 								*
C*									*
C* This subroutine computes the individual digits of a decimal input	*
C* number in any arbitrary base.					*
C*									*
C* The digits are ordered beginning with the one's digit; so, IDIGS (1) *
C* is multiplied by IBASE**0 = 1, IDIGS (2) by IBASE**1, and so on, in  *
C* recovering the value in the new base.				*
C*									*
C* GDIGIT   ( IVAL, IBASE, NDIG, IDIGS, IRET )				*
C*									*
C* Input parameters:							*
C*	IVAL		INTEGER		Input decimal value		*
C*	IBASE		INTEGER		Base for the output digits	*
C*									*
C* Input and output parameter:						*
C*	NDIG		INTEGER		Input: max # of digits allowed	*
C*					Output: # of digits needed	*
C*									*
C* Output parameters:							*
C*	IDIGS (NDIG)	INTEGER		Output digits			*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 -1 = base cannot be < 2	*
C*					 -2 = not enough digits		*
C*					 -3 = input value < 0		*
C**									*
C* Log:									*
C* K. Brill/HPC		 8/99						*
C************************************************************************
	INTEGER		idigs (*)
C*
	DOUBLE PRECISION	v, b
C------------------------------------------------------------------------
	IF ( ibase .lt. 2 ) THEN
	    iret = -1
	    RETURN
	END IF
	IF ( ival .lt. 0 ) THEN
	    iret = -3
	    RETURN
	END IF
	iret = 0
	nmax = ndig
	DO i = 1, nmax
	    idigs (i) = 0
	END DO
C*
	v = DFLOAT ( ival )
	b = DFLOAT ( ibase )
	ndig = INT ( DLOG ( v ) / DLOG ( b ) ) + 1
	itest = ibase ** ndig
	IF ( itest .lt. ival ) ndig = ndig + 1
	IF ( ndig .gt. nmax ) THEN
	    iret = -2
	    RETURN
	END IF
	iv = ival
	idig = ndig
	DO WHILE ( idig .gt. 0 )
	    npwr = idig - 1
	    id = ibase ** npwr
	    idigs (idig) = iv / id
	    iv = iv - idigs (idig) * id
	    idig = idig - 1
	END DO
C*
	RETURN
	END


program test_ode
  !! Program to test the ode module.
  !! The [Lorenz chaotic system](https://en.wikipedia.org/wiki/Lorenz_system) is solved:
  !! \[
  !! \frac{dx}{dt}= a\left(y-x\right)\\
  !! \frac{dy}{dt}= x\left(b-z\right) - y \\
  !! \frac{dz}{dt}= xy - cz
  !! \]
  !! The system is integrated for \(t\in[0,10]\) with \(a=\), \(b=\) and \(c=\).
  !! For initial conditions \(\left(x(0),y(0),z(0)\right) = \left(1,1,1\right)\), the solution is:
  !! ![Image of the trayectory](../../lorenz.png)
  use ode

  implicit none

  integer, parameter :: N = 1000;
  real :: Tf, dT
  real :: t(0:N), y(0:N,3)
  integer :: i, u

  Tf = 10
  dT = Tf/N

  do i =0, N
    t(i) = i*dT
  end do

  y = forward_euler(lorenz, t, [ 1.,1.,1.])

  open(file='datos.dat',newunit=u)
  do i = 0, N
    write(u,*) t(i), y(i,1), y(i,2), y(i,3)
  end do
  close(u)

contains

  function lorenz(U,t) result(dU)
  !! function for defining derivative in the
  !! [Lorenz system](https://en.wikipedia.org/wiki/Lorenz_system)
  !! written as:
  !! \[
  !! \frac{d\mathbf{U}}{dt}=\mathbf{F}\left(\mathbf{U},t\right)
  !! \]
  !! where:
  !! \[
  !! \mathbf{U}\left(t\right) =
  !! \begin{pmatrix}
  !! x\left(t\right)\\
  !! y\left(t\right)\\
  !! z\left(t\right)
  !! \end{pmatrix}
  !! \]
  !! and
  !! \[
  !! \mathbf{F}\left(\mathbf{U},t\right)=
  !! \begin{pmatrix}
  !!  a \left( U_2 - U_1 \right) \\
  !!  U_1 \left( b - U_3 \right) - U_2 \\
  !!  U_1 U_2 - cU_3
  !! \end{pmatrix}
  !! \]
    real, intent(in) :: U(:)
    real, intent(in) :: t
    real :: dU(size(U))
    real, parameter :: a = 10.
    real, parameter :: b = 28.
    real, parameter :: c = 8./3.
    dU(1) = a*(U(2)-U(1))
    dU(2) = U(1)*(b-U(3)) - U(2)
    dU(3) =U(1)*U(2) - c*U(3)
  end function
end program


function gcd(v, t)
  integer :: gcd
  integer, intent(in) :: v, t
  integer :: c, b, a

  b = t
  a = v
  do
     c = mod(a, b)
     if ( c == 0) exit
     a = b
     b = c
  end do
  gcd = b ! abs(b)
end function gcd


PROGRAM euler

    IMPLICIT NONE
    LOGICAL                            :: is_approx
    REAL(8), DIMENSION(:), ALLOCATABLE :: vec
    REAL(8)                            :: time_step, threshold
    INTEGER                            :: n

    time_step = 0.01d0
    n         = 100
    threshold = 0.01d0

    ALLOCATE(vec(n))
    CALL forward_euler(time_step, n, vec)
    is_approx = check_result(vec, threshold, time_step)

    WRITE(*,*) is_approx

    DEALLOCATE(vec)

CONTAINS

    SUBROUTINE forward_euler(time_step, n, vec)

        IMPLICIT NONE
        REAL(8), DIMENSION(:), INTENT(OUT)   :: vec
        REAL(8), INTENT(IN)                  :: time_step
        INTEGER, INTENT(IN)                  :: n
        INTEGER                              :: i

        vec(1) = 1d0

        DO i=1, n-1

            vec(i+1) = vec(i) - 3d0 * vec(i) * time_step

        END DO
    END SUBROUTINE

    LOGICAL FUNCTION check_result(euler_result, threshold, time_step)

        IMPLICIT NONE
        REAL(8), DIMENSION(:), INTENT(IN) :: euler_result
        REAL(8), INTENT(IN)               :: threshold, time_step
        REAL(8)                           :: time, solution
        INTEGER                           :: i

        check_result = .TRUE.

        DO i = 1, SIZE(euler_result)

            time = (i - 1) * time_step
            solution = EXP(-3d0 * time)

            IF (ABS(euler_result(i) - solution) > threshold) THEN

                WRITE(*,*) euler_result(i), solution
                check_result = .FALSE.

            END IF
        END DO
    END FUNCTION
END PROGRAM euler


program testPositivDefinit
    implicit none
    integer , parameter:: columnRowLength = 4  ! Initialize how big the square matrix of the text file is
    ! also bigger or smaller matrices are possible
    integer, dimension(columnRowLength , columnRowLength) :: matrix
    logical :: isSymmetric = .TRUE.
    logical :: isPositivDefinit = .TRUE.
    INTEGER :: solutionDeterminat

    ! initialize the matrix from the text file

	! choose/uncomment one of the 3 matrix options
    ! open(10,file='CholeskyNotPossible.txt')

     open(10,file='CholeskyPossible.txt')

    ! -> Matrix columnRowLength have to be the same as in the text file -> here columnRowLength = 5
    ! open(10,file='5x5Matrix.txt')

    read (10,*) matrix

    ! first requirement for Cholesky: symmetry
    call checkSymmetry(columnRowLength, matrix, isSymmetric) ! returns all parameters (isSymmetric => True or False)

    ! second requirement for Cholesky: positiv determinat (here calculated by Laplace expansion)
    solutionDeterminat = determinatLaplace( matrix, columnRowLength )
    print *, ' '
    print *, 'The solution of Laplace expansion of the given Matrix is: '
    print *, solutionDeterminat
    call checkPositivDefiniteLaPlaceExpansion(columnRowLength, matrix, isPositivDefinit, isSymmetric)

! If the matrix is symmetric and the determinat > 0 (with Laplace expansion) then the matrix is positiv definit => then there is a Cholesky decomposition
    IF (isPositivDefinit) THEN
    print *, ' '
        print *, 'calculate Cholesky decomposition'
    end if

contains

subroutine printMatrix(columnRowLength, matrix)
    !printing given matrices

    integer :: i,j, columnRowLength
    integer, dimension(columnRowLength , columnRowLength) :: matrix

    do i = 1,columnRowLength
            print*, (matrix(i, j), j=1,columnRowLength)
    end do
end subroutine printMatrix

subroutine checkSymmetry(columnRowLength, matrix, isSymmetric)
! checks if the matrix is symmetric

        integer :: columnRowLength
        integer, dimension(columnRowLength , columnRowLength) :: matrix, matrixTransposed ! create two quadratic matrices with given length
        integer :: i, j ! loop helpers
        logical :: isSymmetric ! setter for solution

        matrixTransposed = transpose(matrix)	! function that transposes the matrix

        !printing both matrices
        print*,"----------------matrix---------------"
        call printMatrix(columnRowLength, matrix)

        print *, ' '

        print*,"--------transpose of matrix ---------"
        call printMatrix(columnRowLength, matrixTransposed)

        ! checking symmetric (compare tranpose and normal matrices)
        do i = 1, columnRowLength
            do j = 1, columnRowLength
                if(matrix(i,j) /= matrixTransposed(i,j)) then
                    isSymmetric = .FALSE.
                    exit		! exit loop and set solution of the subroutine: isSymmetric = false
                end if
            end do
        end do

        if (isSymmetric) then
            print*, "The matrix is equal to its transpose"
            print*,"Therfore, the matrix is symmetric"
         else
            print*, "The matrix is not equal to its transpose"
            print*, "Therefore, the matrix is antisymmetric"
        end if
    end subroutine checkSymmetry

subroutine checkPositivDefiniteLaPlaceExpansion(columnRowLength, matrix, isPositivDefinit, isSymmetric)
    integer::columnRowLength
    Integer, dimension(columnRowLength, columnRowLength) :: matrix
    logical :: isPositivDefinit, isSymmetric

    IF(solutionDeterminat>0 .AND. isSymmetric) THEN
        isPositivDefinit = .TRUE.
        print *, 'The given matrix is symmetric and the solution of the the Laplace expansion is greater than 0'
        print *, 'Therefore the matrix is positive definit and there is a Cholesky decomposition '
    Else
        isPositivDefinit = .FALSE.
        print *, 'The given matrix is not symmetric or the solution of the the Laplace expansion is not greater than 0'
        print *, 'Therefore there is not a Cholesky decomposition'
    END IF

end subroutine checkPositivDefiniteLaPlaceExpansion

recursive function determinatLaplace( matrix, n ) result( intermediateResult )
    integer :: n ! = columnRowLength (name here too long)
    integer:: matrix(n, n)
    integer:: submatrix(n-1, n-1), intermediateResult !intermediateResult
    integer :: i, sgn ! i=loop helper, sgn=sign for the change +/-

    if ( n == 1 ) then
        intermediateResult = matrix(1,1) ! The result of the determinats of a 1x1 matrix is its only element & calculates the recursion upwards again
    else
        intermediateResult = 0.0 ! reset for new tntermediateResult (last solution is safed in last recursion step)
        sgn = 1
        do i = 1, n ! go through first row //matrix(rows, columns)

            ! Sub-Array Manipulations
            ! Laplace expansion is made along the first row
            submatrix( 1:n-1, 1:i-1 ) = matrix( 2:n, 1:i-1 )! fill submatrix till i-1th column with matrix values that are between the first and i-1th column and not in the first row
            submatrix( 1:n-1, i:n-1 ) = matrix( 2:n, i+1:n )! fill submatrix from i column onwards with matrix values that are not in the first row and are between the i+1th column and n
            ! => skip first row & i-th column

            ! matrix(1,i) = value of first row elements -> alternately * +/- 1 (sgn)
            ! determinat method is called again with submatrix of the matrix with deleted 1st row and i-th column & the matrix columnRowlength-1
            ! the recursion calls end with the 1x1 matrices. After that the intermediateResult will get calculated up the recursion.
            ! one element of the first row fully calculated -> with do loop iterate through the hole row
            intermediateResult = intermediateResult + sgn * matrix(1, i) * determinatLaplace( submatrix, n-1 )
            sgn = - sgn ! change +/-
        enddo ! if do loop ends the intermediateResult is the solution
    endif
end function

end program testPositivDefinit


! Power function using recursion
!
! An integer base \( b > 0 \) can be raised to an integer power \( p > 0 \)
! using a simple recurrence relation,
! \[
!   b^p = b \cdot b^{p - 1}.
! \]
! The base case is \( b^0 = 1 \).
!
! TODO: try to incorporate case p < 0 with divisions for real numbers.
program main
    implicit none
    integer :: n, m, ans
    print "(a)", "Numbers n and m are "
    read *, n, m
    print "(a, i0)", "n^m is ", power_f(n, m)
    call power_s(n, m, ans)
    print "(a, i0)", "n^m is ", ans
contains
    recursive function power_f(b, p) result(answer)
        integer             :: answer
        integer, intent(in) :: b, p
        if (p == 0) then
            answer = 1
        else
            answer = b * power_f(b, p - 1)
        end if
    end function power_f

    recursive subroutine power_s(b, p, answer)
        integer, intent(in)    :: b, p
        integer, intent(inout) :: answer
        if (p == 0) then
            answer = 1
        else
            call power_s(b, p - 1, answer)
            answer = b * answer
        end if
    end subroutine power_s
end program main


SUBROUTINE stats (stat_q)

! ----------------------------------------------------------------------
! SUBROUTINE: stats.f90
! ----------------------------------------------------------------------
! Purpose:
!  Computation of statistical qunatities based on a provided data series
!  Root Mean Square (RMS), Maximum, Minimum, Mean, Standard deviation
! ----------------------------------------------------------------------
! Input arguments:
! - array1:         Input allocatable array
! - mdl_array:		Module for the input/output allocatable arrays
!
! Output arguments:
! - stat_q:			Statistics quantities: RMS, Max, Min, Mean, sdev
! ----------------------------------------------------------------------
! Dr. Thomas D. Papanikolaou, Geoscience Australia              May 2016
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_arr
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN

! OUT
      REAL (KIND = prec_d) :: stat_q(5)
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_d) :: min_val, max_val, RMS, Mean, sdev
      REAL (KIND = prec_d) :: sum_dx2, sum_dx, sum_dxx
      INTEGER (KIND = prec_int4) :: sz1, sz2, i
! ----------------------------------------------------------------------

![size_dx size2] = size(dx);
      sz1 = SIZE (array1,DIM=1)
      !sz2 = SIZE (array1,DIM=2)

      min_val = array1(1)
      max_val = array1(1)
      sum_dx2 = 0.0D0
      sum_dx = 0.0D0

      DO i = 1 , sz1
	     sum_dx2 = sum_dx2 + array1(i)**2
	     sum_dx = sum_dx + array1(i)
         if ( array1(i) < min_val ) then
		     min_val = array1(i)
		 end if
		 if ( array1(i) > max_val ) then
		     max_val = array1(i)
		 end if
      END DO

! RMS
      RMS = sqrt(sum_dx2 / sz1)

! Mean
      Mean = sum_dx / sz1

! ----------------------------------------------------------------------
! Standard Deviation
      sum_dxx = 0.0D0
      DO i = 1 , sz1
	     sum_dxx = sum_dxx + (array1(i) - Mean)**2
      END DO

      sdev = sqrt(sum_dxx / sz1)

      sdev = sqrt(sum_dxx / (sz1 - 1) )
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
      stat_q(1) = RMS
      stat_q(2) = max_val
      stat_q(3) = min_val
      stat_q(4) = Mean
      stat_q(5) = sdev
! ----------------------------------------------------------------------

END


!-------------------------------------------------------------------
      subroutine make_array_logspace(a_start, a_end, dim, out)
      implicit none
      integer         , intent(IN) :: dim
      double precision, intent(IN) :: a_start, a_end
      double precision, intent(out):: out(dim)
      integer                      :: i
      double precision             :: du,u1,u2,exp
      if (dim.gt.1) then
         u1=log10(a_start)
         u2=log10(a_end)
         du=(u2-u1)/float(dim-1)
         exp=log10(a_start)
         do i=1, dim
            out(i)=10**exp
            exp=exp+du
         enddo
      else if(dim.eq.1) then
       out(1)=a_start
      else if(dim.lt.1) then
       write(*,'(A)',advance="no") 'Error! It is impossible create'
       write(*,*) ' the log scaled array: dim is less than 1'
       stop
      endif
      return
    end subroutine make_array_logspace
!-----------------------------------------------------------------

!-------------------------------------------------------------------
      subroutine make_array_logspace_real(a_start, a_end, dim, out)
      implicit none
      integer :: i,dim
      real :: a_start,a_end,out(dim)
      real :: du,u1,u2,exp
      if (dim.gt.1) then
         u1=log10(a_start)
         u2=log10(a_end)
         du=(u2-u1)/float(dim-1)
         exp=log10(a_start)
         do i=1, dim
            out(i)=10**exp
            exp=exp+du
         enddo
      else if(dim.eq.1) then
       out(1)=a_start
      else if(dim.lt.1) then
       write(*,'(A)',advance="no") 'Error! It is impossible create'
       write(*,*) ' the log scaled array: dim is less than 1'
       stop
      endif
      return
    end subroutine make_array_logspace_real
!-----------------------------------------------------------------


      !>@author
      !>Paul Connolly, The University of Manchester
      !>@brief
      !>code to solve a calculate the 1st derivative of a function
      !> richardson extrapolation:
      !> see https://www.researchgate.net/profile/Toshio_Fukushima/publication/320008726_Efficient_numerical_differentiation_by_Richardson_extrapolation_applied_to_forward_difference_formulas/links/59c73513a6fdccc7191edae2/Efficient-numerical-differentiation-by-Richardson-extrapolation-applied-to-forward-difference-formulas.pdf
      !>@param[in] x,h0,delta
      !>@param[inout] err
      !>@return dfsid1: gradient
      function dfsid1(func,x,h0,delta,err)
	    use numerics_type
        implicit none
        real(wp), intent(in) :: x,h0,delta
        real(wp), intent(inout) :: err
        real(wp) :: dfsid1
        interface
            function func(x)
            use numerics_type
            real(wp), intent(in) :: x
            real(wp) :: func
            end function func
        end interface
        integer JMAX1;
        real(wp) :: BETA,ERRMIN,LOG2,fx
        parameter (JMAX1=8,BETA=8.e0_wp,ERRMIN=1.e-35_wp)
        parameter (LOG2=0.69314718055994530941723212145818e0_wp)
        integer j,kmin,k;
        real(wp),dimension(JMAX1,JMAX1) :: T
        real(wp) :: hj,errM,errP,factor,errT,errX

        fx=func(x)
        hj=2.e0_wp**(floor(log(abs(h0))/LOG2))
        if(h0.lt.0.e0_wp) then
            hj=-hj
        endif
        T(1,1)=(func(x+hj)-fx)/hj; dfsid1=T(1,1)
        errM=0.5e0_wp*delta*abs(dfsid1); errP=1.e-38_wp; err=1.e38_wp !e-66 and e99
        do j=2,JMAX1
            hj=hj/BETA; factor=BETA; kmin=1; T(1,j)=(func(x+hj)-fx)/hj
            do k=2,j
                T(k,j)=T(k-1,j)+(T(k-1,j)-T(k-1,j-1))/(factor-1.e0_wp)
                factor=BETA*factor
                errT=max(abs(T(k,j)-T(k-1,j)),abs(T(k,j)-T(k-1,j-1)))
                if(errT.le.err) then
                    kmin=k; err=errT; dfsid1=T(k,j)
                endif
            enddo
            errX=err*err/errP
            if(errX.le.errM) then
                err=max(ERRMIN,errX); return
            endif
            if(err.le.errM) return
            if(kmin.eq.1) then
                err=errX; return
            endif
            errP=err
        enddo
        err=max(ERRMIN,errX)
        return;
      end function dfsid1


SUBROUTINE arctan ( y,x , angle )

! ----------------------------------------------------------------------
! SUBROUTINE: arctan.f90
! ----------------------------------------------------------------------
! Purpose:
!  Angle computation based on the x,y Cartesian coordinates.
!  Test for identifying the angle quadrant.
! ----------------------------------------------------------------------
! Remarks:
!  Angles are considered counter-clockwise
!  The result is computed in radians.
! ----------------------------------------------------------------------
! Input arguments:
! - x,y:			2D Cartesian coordinates
! Output arguments:
! - angle:			Orientation angle (counter-clockwise) starting from x axis (radians)
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia              August 2015
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q), INTENT(IN) :: x,y
      REAL (KIND = prec_q), INTENT(OUT) :: angle
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_q) :: pi
      REAL (KIND = prec_q) :: a
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Numerical Constants
      pi = PI_global
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
      if (x .ne. 0.d0) then
          a = atan( abs( y/x ) )
          if (x > 0.0D0) THEN
              if (y > 0.0D0) THEN
                  angle = a
              else if (y < 0.0D0) THEN
                  angle = 2.0D0 * pi - a
              else
                  angle = 0.0D0
              end IF
          else if (x < 0.0D0) THEN
              if (y > 0.0D0) THEN
                  angle = pi - a
              else if (y < 0.0D0) THEN
                  angle = pi + a
              else
                  angle = pi
              end IF
          end if
      else
          if (y > 0.0D0) THEN
              angle = pi / 2.0D0
          else if (y < 0.0D0) THEN
              angle = 3.0D0 * pi / 2.0D0
          else
              angle = 0.d0
          end IF
      end IF
! ----------------------------------------------------------------------

END


! In this module you can define for example global constants

MODULE constants
  ! definition of variables for double precisions and complex variables
  INTEGER,  PARAMETER :: dp = KIND(1.0D0)
  INTEGER, PARAMETER :: dpc = KIND((1.0D0,1.0D0))
  ! Global Truncation parameter
  REAL(DP), PARAMETER, PUBLIC ::  truncation=1.0E-10
END MODULE constants

! Here you can include specific functions which can be used by
! many subroutines or functions

MODULE functions

CONTAINS
  REAL(DP) FUNCTION factorial(n)
    USE CONSTANTS
    INTEGER, INTENT(IN) :: n
    INTEGER  :: loop

    factorial = 1.0_dp
    IF ( n > 1 ) THEN
       DO loop = 2, n
          factorial=factorial*loop
       ENDDO
    ENDIF

  END FUNCTION factorial

END MODULE functions

PROGRAM exp_prog
  USE constants
  USE functions
  IMPLICIT NONE
  REAL (DP) :: x, term, final_sum
  INTEGER :: n, loop_over_x

  !  loop over x-values
  DO loop_over_x=0, 100, 10
     x=loop_over_x
     !  initialize the EXP sum
     final_sum= 0.0_dp; term = 1.0_dp; n = 0
     DO WHILE ( ABS(term) > truncation)
        term = ((-1.0_dp)**n)*(x**n)/ factorial(n)
        final_sum=final_sum+term
        n=n+1
     ENDDO
     !  write the argument x, the exact value, the computed value and n
     WRITE(*,*) x ,EXP(-x), final_sum, n
  ENDDO

END PROGRAM exp_prog


module procedures
implicit none
contains

subroutine writes2d (A)
   real(kind=8), allocatable, dimension(:,:), intent(in) :: A
   integer :: n, m, i, j

   n = size(A, 1)
   m = size(A, 2)

   do i = 1,n
      write(*,'(20F8.4)') (A(i,j), j = 1, m)
   end do
   write(*,*)
end subroutine writes2d

subroutine writes1d (A)
   real(kind=8), allocatable, dimension(:), intent(in) :: A
   integer :: n, i

   n = size(A)

   write(*,'(20F8.4)') (A(i), i = 1, n)
   write(*,*)
end subroutine writes1d

real(kind = 8) function MaxEig(A)
   real(kind=8), allocatable, dimension(:,:), intent(in) :: A
   real(kind=8), allocatable, dimension(:,:) :: Y, Y_old, Y_new
   real(kind=8) :: normalization_constant
   integer :: n, i, j

   !Initialize column vector:
   n = size(A,1)
   allocate (Y(n,1), Y_old(n,1))
   do i = 1, n
      Y(i,1) = 1.0d0
      Y_old(i,1) = 2.0d0 !initialize loop
   end do
   write(*,*) "initial vector:"
   call writes2d(Y)

   !perform calculation:
   i = 1
   do while (maxval(dabs(Y_old-Y)) .ge. 0.0001)
      do j = 1, n ! save old vector
         Y_old(j,1) = Y(j,1)
      end do
      Y = matmul(A,Y) !determine new vector
      MaxEig = maxval(Y)
      do j = 1, n
         Y(j,1) = Y(j,1)/MaxEig
      end do
      write(*,*) "iteration:", i
      write(*,'(A14,F10.6)') " tolerance:   ", maxval(dabs(Y_old-Y))
      write(*,'(A15,F8.4)') " eigenvalue:   ", MaxEig
      write(*,*) "eigenvector:"
      call writes2d(Y)
      i = i+1
   end do

   ! final normalization:
   normalization_constant = sqrt(Y(1,1)*Y(1,1) + Y(2,1)*Y(2,1) + Y(3,1)*Y(3,1))
   do i = 1, n
      Y(i,1) = Y(i,1)/normalization_constant
   end do
   write(*,*)
   write(*,'(A30)') " -----------------------------"
   write(*,'(A30)') "         final result         "
   write(*,'(A30)') " -----------------------------"
   write(*,*) "eigenvalue:", MaxEig
   write(*,*) "eigenvector, normalized to length 1 for comparison with matlab result:"
   call writes2d(Y)

   deallocate (Y, Y_old)
end function MaxEig

end module procedures


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!%
!%  Description:
!%      +   Return the natural logarithm of an ndim-dimensional mixture of Standard Multivariate
!%          Normal (SMVN) density functions (PDF) with the mean and amplitude vectors as defined below.
!%          Reference: https://en.wikipedia.org/wiki/Multivariate_normal_distribution
!%  Input:
!%      +   ndim:       The number of dimensions of the domain of the objective function.
!%      +   point:      The input 64-bit real-valued vector of length ndim,
!%                      at which the natural logarithm of objective function is computed.
!%  Output:
!%      +   logFunc:    A 64-bit real scalar number representing the natural logarithm of the objective function.
!%  Author:
!%      +   Computational Data Science Lab, Monday 9:03 AM, May 16 2016, ICES, The University of Texas at Austin
!%  Visit:
!%      +   https://www.cdslab.org/paramonte
!%
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%

module LogFunc_mod

    use paramonte, only: IK, RK

    implicit none

    ! The number of dimensions of the domain of the objective function.

    integer(IK), parameter  :: NDIM = 1_IK

    ! The number of mixtures of multivariate normal distributions.

    integer(IK), parameter  :: NMIX = 3_IK

    ! The mean vectors of the SMVN mixtures.

    integer(IK)             :: idim, imix
    real(RK), parameter     :: MEAN(NDIM,NMIX) = reshape([((real(3*imix,RK), idim = 1, NDIM), imix = -NMIX/2, NMIX/2 + mod(NMIX,2) - 1)], shape = shape(MEAN))

    ! The log-amplitudes of the SMVN mixtures.

    real(RK), parameter     :: LOG_AMPLITUDE(NMIX) = [(imix*log(2._RK), imix = 1, NMIX)]

contains

    function getLogFunc(ndim,Point) result(logFunc)
        ! Return the negative natural logarithm of SMVN mixture density evaluated at the input vector `Point` of length `ndim`.
        implicit none
        integer(IK), intent(in) :: ndim
        real(RK), intent(in)    :: Point(ndim)
        real(RK)                :: LogFuncMix(NMIX)
        real(RK)                :: maxLogFuncMix
        real(RK)                :: logFunc
        maxLogFuncMix = -huge(maxLogFuncMix)
        do imix = 1, NMIX
            LogFuncMix(imix) = LOG_AMPLITUDE(imix) - 0.5_RK * sum((Point - MEAN(:,imix))**2)
            if (maxLogFuncMix < LogFuncMix(imix)) maxLogFuncMix = LogFuncMix(imix)
        end do
        logFunc = maxLogFuncMix + log(sum(exp(LogFuncMix - maxLogFuncMix)))
    end function getLogFunc

end module LogFunc_mod

!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%


! Truong Dang added this subroutine on 10-21-2016
  subroutine gauss_2(a,b,x,n)
!===========================================================
! Solutions to a system of linear equations A*x=b
! Method: Gauss elimination (with scaling and pivoting)
! Alex G. (November 2009)
!-----------------------------------------------------------
! input ...
! a(n,n) - array of coefficients for matrix A
! b(n)   - array of the right hand coefficients b
! n      - number of equations (size of matrix A)
! output ...
! x(n)   - solutions
! coments ...
! the original arrays a(n,n) and b(n) will be destroyed
! during the calculation
!===========================================================
implicit none
integer n
double precision a(n,n), b(n), x(n)
double precision s(n)
double precision c, pivot, store
integer i, j, k, l

! step 1: begin forward elimination
do k=1, n-1

! step 2: "scaling"
! s(i) will have the largest element from row i
  do i=k,n                       ! loop over rows
    s(i) = 0.0
    do j=k,n                    ! loop over elements of row i
      s(i) = max(s(i),abs(a(i,j)))
    end do
  end do

! step 3: "pivoting 1"
! find a row with the largest pivoting element
  pivot = abs(a(k,k)/s(k))
  l = k
  do j=k+1,n
    if(abs(a(j,k)/s(j)) > pivot) then
      pivot = abs(a(j,k)/s(j))
      l = j
    end if
  end do

! Check if the system has a sigular matrix
  if(pivot == 0.0) then
    write(*,*) ' The matrix is sigular '
    return
  end if

! step 4: "pivoting 2" interchange rows k and l (if needed)
if (l /= k) then
  do j=k,n
     store = a(k,j)
     a(k,j) = a(l,j)
     a(l,j) = store
  end do
  store = b(k)
  b(k) = b(l)
  b(l) = store
end if

! step 5: the elimination (after scaling and pivoting)
   do i=k+1,n
      c=a(i,k)/a(k,k)
      a(i,k) = 0.0
      b(i)=b(i)- c*b(k)
      do j=k+1,n
         a(i,j) = a(i,j)-c*a(k,j)
      end do
   end do
end do

! step 6: back substiturion
x(n) = b(n)/a(n,n)
do i=n-1,1,-1
   c=0.0
   do j=i+1,n
     c= c + a(i,j)*x(j)
   end do
   x(i) = (b(i)- c)/a(i,i)
end do

end subroutine gauss_2


module procedures
implicit none
contains

!----------------------------
! Function to solve:
!----------------------------

real(kind=8) function g (x)
   real(kind=8), intent (in) :: x

   g = 8.0d0 - 4.5d0*(x-sin(x))
end function g

!----------------------------
! Bisection routine:
!----------------------------

subroutine BisectionRoot (Fun, a, b, ToolMax, Xs)

   real(kind=8), intent(in) :: ToolMax
   real(kind=8), intent(inout) :: a, b
   real(kind=8), intent(out) :: Xs
   interface
      real(kind=8) function Fun(x)
         real(kind=8), intent (in) :: x
      end function
   end interface
   real(kind=8) :: n, ConvergenceTest
   integer :: i

   ! Determine n; check if a and b are positioned properly:

   n = nint( (log10(b-a) - log10(ToolMax)) / log10(2.0d0) )
   write(*,'(A6F7.3)') " n >= ", n

   if (Fun(a)*Fun(b) > 0) then
      write(*,*) "f(a) and f(b) are not on opposite sides of the root. Cannot apply the bisection method "
      stop
   end if

   !Solve the function:

   write(*,'(6A15)') "   iteration:  ", "       a       ", &
      "        b        ", "(xNS) Solution", "      f(xNS)    ", "   Tolerance   "

   i = 0
   ConvergenceTest = 10
   do while (ConvergenceTest > ToolMax)

      i = i + 1
      if (i > n + 10) then
         write(*,*) "convergence could not be reached in the number of intervals)"
         stop
      end if

      Xs = (a+b)/2.0d0
      if (Fun(a)*Fun(Xs) < -0.00000000001) then
         b = Xs
      else if (Fun(a)*Fun(Xs) > 0.00000000001) then
         a = Xs
      else
         ConvergenceTest = abs(Fun(Xs))
         write(*,'(A6,I2,A7,5F15.11)') " ", i, " ", a, b, Xs, Fun(Xs), ConvergenceTest
         write(*,*) "convergence reached"
         exit
      end if

      ConvergenceTest = abs(Fun(Xs))
      write(*,'(A6,I2,A7,5F15.11)') " ", i, " ", a, b, Xs, Fun(Xs), ConvergenceTest

   end do

end subroutine BisectionRoot

end module procedures