! Auto differentiation
! ====================

! This is a powerful numerical technique which provides numerically exact vaulues of a first derivative,
! not an approximation.

! Represent a variable by a pair containing its value and first derivative's value {x, d}, and
! implementation is by extensive use of operator overloading.
!
! For example:
!    x**2 is represented by {x**2, 2*x} (a specific case of x**n)
!  sin(x) is represented by {sin(x), cos(x)}
!
! The product rule: {x dx}*{y dy} => {xy (x*dy+y*dx)}
!
! so x**2*sin(x) => {x**2 2*x}*{sin(x) cos(x)} => {x**2*sin(x) (x**2*cos(x)+2*x*sin(x))}

! The advantage is that complicated algebra calculating first derivatives is avoided without using an approximation
! - very useful when working with a Jacobian for example.
! The disadvantage is that the function value is always calculated as well.

!
! Attribution
! ===========
! Read about this somewhere at least 10  years ago and thought it looked interesting. So the idea was someone else's
! but the implementation is all mine.

!
! Example
! =======
!
! To find the first an second derivatives of 1/(1-x) at x=0.5
!
! 1) Set the auto_var x  call x%set(0.5) - the components of x are now {0.5 1}
! 2) Assign the auto_var f  f = 1/(1-x) which generates the following call sequence:
!            sub_n_x        {0.5  1} -> {0.5 -1}
!            div_r_x
!            quotient rule  {0.5 -1} -> {2 4}
! 3) So f is now set to {2 4}
!
!
! Usage
! =====
!
! To get the numerical value of the derivative of x**2 at x = 3
!
!     type(auto_var) :: x, y
!     call x%set(3)
!     y = x**2
!     write(*,'(a,f0.1)') 'Derivative of x**2 at x = 3 is ',y%get_derivative()
!
! Tested
! ======
!     gfortran -o autodiff -cpp -DUTEST autodiff.f90
!
!    ./autodiff
!    passed :: x**2
!    passed :: x**3 + x
!    passed :: 3*x**2
!    passed :: 3*x**4 + 2*x
!    passed :: 3*x**2 + 2*x - 5
!    passed :: (x + 2)*(x + 3)*(x - 1)
!    passed :: (x + 2)*(3 - x)*(x**2 - 1)
!    passed :: (x + 2)/(x**2 - 1)
!    passed :: 1.5d0/(x-1) - 0.5d0/(x+1) [previous function as partial fractions]
!    passed :: 1/(1-x)
!    passed :: 4/x
!    passed :: e**x
!    passed :: 2**x
!    passed :: sin(x)
!    passed :: cos(x)
!    passed :: sin(1/x)
!    passed :: sqrt(x)
!    passed :: ||y||
!    passed :: sqrt(9+u(2)**2) == ||u||
!    passed :: _t_ x _x_ (1)
!    passed :: _t_ x _x_ (2)
!    passed :: _t_ x _x_ (3)
!    passed :: x**2 - 2*x*y , Fx
!    passed :: x**2 - 2*x*y , Fy
!    passed :: (x-1)*sin(z) + (y+x)*cos(z/2)**2 Fx
!    passed :: (x-1)*sin(z) + (y+x)*cos(z/2)**2 Fy
!    passed :: (x-1)*sin(z) + (y+x)*cos(z/2)**2 Fz
!    passed :: log(4 + x)
!    passed :: log(4 + x**2)
!    sub_n_x
!    div_n_x
!    quotient rule
!    passed :: 1/(1-x)

module auto_diff
  implicit none

  public :: auto_var
  public :: set_val, make_var, make_const, get_val, get_der, create
  public :: operator(==), operator(+), operator(-), operator(*), operator(/), operator(**), assignment(=)
  public :: operator(<), operator(>)
  public :: cos, sin, tan, sqrt, operator(.dot.), operator(.cross.)
  public :: cosh, sinh, tanh, exp, log

#ifdef UTEST
  public :: utest
#endif
  integer :: debug_level = 0

private

  type auto_var
      private
      real(8) :: x = 0
      real(8) :: d = 1
  contains
      procedure, public :: set => set_ad
      procedure, public :: set_constant => set_constant_ad
      procedure, public :: get_value => get_value_ad
      procedure, public :: get_derivative => get_derivative_ad
  end type auto_var

  interface create
     module procedure create_av
  end interface

  interface make_var
    module procedure make_var_s
    module procedure make_var_v
  end interface

  interface sqrt
     module procedure sqrt_av
  end interface

  interface norm2
     module procedure norm2_av
  end interface

  interface assignment(=)
     module procedure assign_s
     module procedure assign_v
  end interface

  interface operator(+)
     module procedure add_x_x_v
     module procedure add_x_x
     module procedure add_x_r
     module procedure add_r_x
     module procedure add_x_n
     module procedure add_n_x
  end interface

  interface operator(-)
     module procedure sub_x_x_v
     module procedure sub_x_x
     module procedure sub_x_r
     module procedure sub_r_x
     module procedure sub_r_x_a
     module procedure sub_x_n
     module procedure sub_n_x
  end interface

  interface operator(*)
     module procedure mult_x_x
     module procedure mult_x_r
     module procedure mult_r_x
     module procedure mult_x_n
     module procedure mult_n_x
  end interface

  interface operator(/)
     module procedure div_x_x
     module procedure div_xv_x
     module procedure div_x_r
     module procedure div_r_x
     module procedure div_x_n
     module procedure div_n_x
  end interface

  interface operator(**)
     module procedure pow_x_x
     module procedure pow_x_n
     module procedure pow_x_r
     module procedure pow_n_x
     module procedure pow_r_x
  end interface

  interface operator(==)
     module procedure equal
  end interface

  interface operator(<)
     module procedure less_than
  end interface

  interface operator(>)
     module procedure greater_than
  end interface

  interface operator(<=)
     module procedure less_equal
  end interface

  interface operator(>=)
     module procedure greater_equal
  end interface

  interface get_val
     module procedure get_val_s
     module procedure get_val_v
  end interface

  interface get_der
     module procedure get_der_s
     module procedure get_der_v
  end interface

  interface set_val
     module procedure set_val_n
     module procedure set_val_r
  end interface

  interface sin
     module procedure sin_x_r
  end interface

  interface cos
     module procedure cos_x_r
  end interface

  interface tan
     module procedure tan_x_r
  end interface

  interface sinh
     module procedure sinh_x_r
  end interface

  interface cosh
     module procedure cosh_x_r
  end interface

  interface tanh
     module procedure tanh_x_r
  end interface

  interface log
     module procedure log_x_r
  end interface

  interface exp
     module procedure exp_x_r
  end interface

  interface operator(.dot.)
     module procedure dot_x_y
     module procedure dot_r_x
     module procedure dot_x_r
  end interface

  interface operator(.cross.)
     module procedure cross_x_y
  end interface

contains

    subroutine set_ad(this, v)
        class(auto_var), intent(inout) :: this
        real(8), intent(in)            :: v
        this%x = v
        this%d = 1
    end subroutine set_ad

    subroutine set_constant_ad(this, v)
        class(auto_var), intent(inout) :: this
        real(8), intent(in)            :: v
        this%x = v
        this%d = 0
    end subroutine set_constant_ad

    function get_value_ad(this)
        class(auto_var), intent(in) :: this
        real(8) :: get_value_ad
        get_value_ad = this%x
    end function  get_value_ad

    function get_derivative_ad(this)
        class(auto_var), intent(in) :: this
        real(8) :: get_derivative_ad
        get_derivative_ad = this%d
    end function  get_derivative_ad

  type(auto_var) function create_av(x) result(r)
     real(8), intent(in) :: x
     r%x = x
  end function create_av

  subroutine assign_s(a, b)
    type(auto_var), intent(out) :: a
    type(auto_var), intent(in) :: b
    a%x = b%x
    a%d = b%d
  end subroutine assign_s

  subroutine assign_v(a, b)
    type(auto_var), intent(out) :: a(:)
    type(auto_var), intent(in) :: b(:)
    integer :: i
    do i=1,size(b)
      a(i)%x = b(i)%x
      a(i)%d = b(i)%d
    end do
  end subroutine assign_v

  function cross_x_y(a, b)
    type(auto_var) :: cross_x_y(3)
    type(auto_var), intent(in) :: a(3), b(3)
    integer :: i, j, k
    do i=1,3
       j = merge(1,i+1,i==3)
       k = merge(1,j+1,j==3)
       cross_x_y(i) = a(j)*b(k) - a(k)*b(j)
    end do
  end function cross_x_y

  function sqrt_av(x)
    type(auto_var) :: sqrt_av
    type(auto_var), intent(in) :: x
    sqrt_av = pow_x_r(x,0.5d0)
  end function sqrt_av

  function norm2_av(x)
    type(auto_var) :: norm2_av
    type(auto_var), intent(in) :: x(:)
    type(auto_var) :: v
    norm2_av%d = 0
    v = x .dot. x
    norm2_av = pow_x_r(v,0.5d0)
  end function norm2_av

  function dot_x_y(x, y)
    type(auto_var) :: dot_x_y
    type(auto_var), intent(in) :: x(:), y(:)
    integer :: i
    dot_x_y%d = 0
    do i=1,size(x)
       dot_x_y = dot_x_y + x(i)*y(i)
    end do
  end function dot_x_y

  function dot_r_x(r, x)
    type(auto_var) :: dot_r_x
    real(8), intent(in) :: r(:)
    type(auto_var), intent(in) :: x(:)
    type(auto_var) :: s(size(x))
    integer :: i
    do i=1,size(x)
       call set_val(s(i),r(i))
    end do
    dot_r_x = dot_x_y(s, x)
  end function dot_r_x

  function dot_x_r(x, r)
    type(auto_var) :: dot_x_r
    real(8), intent(in) :: r(:)
    type(auto_var), intent(in) :: x(:)
    type(auto_var) :: s(size(x))
    integer :: i
    do i=1,size(x)
       call set_val(s(i),r(i))
    end do
    dot_x_r = dot_x_y(s, x)
  end function dot_x_r

  real(8) function get_val_s(x)
    type(auto_var), intent(in) :: x
    get_val_s = x%x
  end function get_val_s

  function get_val_v(x)
    type(auto_var), intent(in) :: x(:)
    real(8) :: get_val_v(size(x))
    integer :: i
    do i=1,size(x)
      get_val_v(i) = x(i)%x
    end do
  end function get_val_v

  real(8) function get_der_s(x)
    type(auto_var), intent(in) :: x
    get_der_s = x%d
  end function get_der_s

  function get_der_v(x)
    type(auto_var), intent(in) :: x(:)
    real(8) :: get_der_v(size(x))
    integer :: i
    do i=1,size(x)
      get_der_v(i) = x(i)%d
    end do
  end function get_der_v

  subroutine set_val_r(x, v, isvar)
    type(auto_var), intent(inout) :: x
    real(8), intent(in) :: v
    logical, optional, intent(in) :: isvar
    x%x = v
    if (present(isvar)) then
       x%d = merge(1,0,isvar)
    end if
  end subroutine set_val_r

  subroutine set_val_n(x, v, isvar)
    type(auto_var), intent(inout) :: x
    integer, intent(in) :: v
    logical, optional, intent(in) :: isvar
    x%x = v
    if (present(isvar)) then
       x%d = merge(1,0,isvar)
    end if
  end subroutine set_val_n

   subroutine make_var_s(x, f)
    type(auto_var), intent(inout) :: x
    logical, optional, intent(in) :: f
    if (present(f)) then
       x%d = merge(1, 0, f)
    else
       x%d = 1
    end if
  end subroutine make_var_s

  ! Create an auto_var version of the input array
  subroutine make_var_v(in, out, index)
    real(8), intent(in)           :: in(:)
    type(auto_var), intent(out)   :: out(size(in))
    integer, optional, intent(in) :: index
    integer :: i
    do i=1,size(in)
      out(i)%x = in(i)
      if (present(index)) then
        out(i)%d = merge(1, 0, index == i)
      else
        out(i)%d = 0
      end if
    end do
  end subroutine make_var_v

  subroutine make_const(x)
    type(auto_var), intent(inout) :: x
    x%d = 0
  end subroutine make_const

  !----------------------------------------------------------------------------
  ! Equality test
  function equal(x, y) result(m)
    logical                    :: m
    type(auto_var), intent(in) :: x
    type(auto_var), intent(in) :: y

    m = abs(x%x-y%x) < 1.0d-8 .and. abs(x%d-y%d) < 1.0d-8
  end function equal

  !----------------------------------------------------------------------------
  ! Less-than test
  function less_than(x, y) result(m)
    logical                    :: m
    type(auto_var), intent(in) :: x
    type(auto_var), intent(in) :: y

    m = x%x < y%x
  end function less_than

  !----------------------------------------------------------------------------
  ! Greater-than test
  function greater_than(x, y) result(m)
    logical                    :: m
    type(auto_var), intent(in) :: x
    type(auto_var), intent(in) :: y

    m = x%x > y%x
  end function greater_than

  !----------------------------------------------------------------------------
  ! Less-equal test
  function less_equal(x, y) result(m)
    logical                    :: m
    type(auto_var), intent(in) :: x
    type(auto_var), intent(in) :: y

    m = x%x <= y%x
  end function less_equal

  !----------------------------------------------------------------------------
  ! Greater-equal test
  function greater_equal(x, y) result(m)
    logical                    :: m
    type(auto_var), intent(in) :: x
    type(auto_var), intent(in) :: y

    m = x%x >= y%x
  end function greater_equal

  !----------------------------------------------------------------------------
  ! Add

  function add_x_x_v(x, y) result(m)
    type(auto_var), intent(in) :: x(:)
    type(auto_var), intent(in) :: y(:)
    type(auto_var) :: m(size(x))
    integer :: i
    if (debug_level > 0) write(*,'(a)') 'add_x_x_v'
    do i=1,size(x)
      m(i) = x(i) + y(i)
    end do
  end function add_x_x_v

  function add_x_x(x, y) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    type(auto_var), intent(in) :: y
    if (debug_level > 0) write(*,'(a)') 'add_x_x'
    m%x = x%x + y%x
    m%d = x%d + y%d
  end function add_x_x

  function add_x_r(x, r) result(m)
    type(auto_var)             :: m
    type(auto_var), intent(in) :: x
    real(8), intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'add_x_r'
    m%x = x%x + r
    m%d = x%d
  end function add_x_r

  function add_r_x(r, x) result(m)
    type(auto_var)             :: m
    real(8), intent(in)        :: r
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'add_r_x'
    m%x = x%x + r
    m%d = x%d
  end function add_r_x

  function add_x_n(x, r) result(m)
    type(auto_var)             :: m
    type(auto_var), intent(in) :: x
    integer, intent(in)        :: r
    if (debug_level > 0) write(*,'(a)') 'add_x_n'
    m%x = x%x + r
    m%d = x%d
  end function add_x_n

  function add_n_x(r, x) result(m)
    type(auto_var)             :: m
    integer, intent(in)        :: r
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'add_n_x'
    m%x = x%x + r
    m%d = x%d
  end function add_n_x

  !----------------------------------------------------------------------------
  ! Subtract

  function sub_x_x_v(x, y) result(m)
    type(auto_var), intent(in) :: x(:)
    type(auto_var), intent(in) :: y(:)
    type(auto_var) :: m(size(x))
    integer :: i
    if (debug_level > 0) write(*,'(a)') 'sub_x_x_v'
    do i=1,size(x)
      m(i) = x(i) - y(i)
    end do
  end function sub_x_x_v

  function sub_x_x(x, y) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    type(auto_var), intent(in) :: y
    if (debug_level > 0) write(*,'(a)') 'sub_x_x'
    m%x = x%x - y%x
    m%d = x%d - y%d
  end function sub_x_x

  function sub_x_r(x, r) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    real(8), intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'sub_x_r'
    m%x = x%x - r
    m%d = x%d
  end function sub_x_r

  function sub_r_x(r, x) result(m)
    type(auto_var) :: m
    real(8), intent(in) :: r
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'sub_r_x'
    m%x = r - x%x
    m%d = -x%d
  end function sub_r_x

  function sub_r_x_a(r, x) result(m)
    real(8), intent(in) :: r(:)
    type(auto_var), intent(in) :: x(:)
    type(auto_var) :: m(size(r))
    integer :: i
    if (debug_level > 0) write(*,'(a)') 'sub_r_x_a'
    do i=1, size(r)
       m(i) = r(i) - x(i)
    end do
  end function sub_r_x_a

  function sub_x_n(x, r) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    integer, intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'sub_x_n'
    m%x = x%x - r
    m%d = x%d
  end function sub_x_n

  function sub_n_x(r, x) result(m)
    type(auto_var) :: m
    integer, intent(in) :: r
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'sub_n_x'
    m%x = r - x%x
    m%d = -x%d
  end function sub_n_x

  !----------------------------------------------------------------------------
  ! Multiply

  function mult_x_x(uf, vf) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: uf
    type(auto_var), intent(in) :: vf
    if (debug_level > 0) write(*,'(a)') 'product rule'
    associate (u =>uf%x, v => vf%x, du => uf%d, dv => vf%d)
      m%x = u*v
      m%d = u*dv + v*du
    end associate
  end function mult_x_x

  function mult_x_r(x, r) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    real(8), intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'mult_x_r'
    m = mult_x_x(x,auto_var(r,0))
  end function mult_x_r

  function mult_r_x(r, x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    real(8), intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'mult_r_x'
    m = mult_x_x(auto_var(r,0),x)
  end function mult_r_x

  function mult_x_n(x, r) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    integer, intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'mult_x_r'
    m = mult_x_x(x,auto_var(r,0))
  end function mult_x_n

  function mult_n_x(r, x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    integer, intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'mult_n_x'
    m = mult_x_x(auto_var(r,0),x)
  end function mult_n_x

  !----------------------------------------------------------------------------
  ! Divide

  function div_x_x(uf, vf) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: uf
    type(auto_var), intent(in) :: vf
    if (debug_level > 0) write(*,'(a)') 'quotient rule'
    associate (u =>uf%x, v => vf%x, du => uf%d, dv => vf%d)
      m%x = u/v
      m%d = (v * du - u * dv)/v**2
    end associate
  end function div_x_x

  function div_x_r(x, r) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    real(8), intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'div_x_r'
    m = div_x_x(x,auto_var(r,0))
  end function div_x_r

  function div_xv_x(x, r) result(m)
    type(auto_var), intent(in) :: x(:)
    type(auto_var), intent(in) :: r
    type(auto_var) :: m(size(x))
    integer :: i
    if (debug_level > 0) write(*,'(a)') 'div_xv_x'
    do i=1, size(x)
      m(i) = div_x_x(x(i),r)
    end do
  end function div_xv_x

  function div_r_x(r, x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    real(8), intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'div_r_x'
    m = div_x_x(auto_var(r,0),x)
  end function div_r_x

  function div_x_n(x, r) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    integer, intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'div_x_n'
    m = div_x_x(x,auto_var(r,0))
  end function div_x_n

  function div_n_x(r, x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    integer, intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'div_n_x'
    m = div_x_x(auto_var(r,0),x)
  end function div_n_x

  !----------------------------------------------------------------------------
  ! Power

  function pow_x_x(x, y) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    type(auto_var), intent(in) :: y
    if (debug_level > 0) write(*,'(a)') 'pow_x_x'
    stop '[pow_x_x] not yet implemented'
    m%x = x%x ** y%x
    m%d = x%d * (1 + log(x%x))*m%x
  end function pow_x_x

  function pow_x_n(x, r) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    integer, intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'x**n'
    m%x = x%x ** r
    m%d = x%d * r*x%x ** (r-1)
  end function pow_x_n

  function pow_x_r(x, r) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    real(8), intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'x**r'
    m%x = x%x ** r
    m%d = x%d * r*x%x ** (r-1)
  end function pow_x_r

  function pow_n_x(r, x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    integer, intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'n**x'
    m%x = r ** x%x
    m%d = x%d * r**x%x * log(dble(r))
  end function pow_n_x

  function pow_r_x(r, x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    real(8), intent(in) :: r
    if (debug_level > 0) write(*,'(a)') 'r**x'
    m%x = r ** x%x
    m%d = x%d * r**x%x * log(r)
  end function pow_r_x

  !----------------------------------------------------------------------------
  ! Trig
  function sin_x_r(x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'sin_x_r'
    m%x = sin(x%x)
    m%d = x%d * cos(x%x)
  end function sin_x_r

  function cos_x_r(x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'cos_x_r'
    m%x = cos(x%x)
    m%d = x%d * (-sin(x%x))
  end function cos_x_r

  function tan_x_r(x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'tan_x_r'
    m  = div_x_x(sin(x),cos(x))
  end function tan_x_r

  !----------------------------------------------------------------------------
  ! Exponential
  function sinh_x_r(x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'sinh_x_r'
    m%x = sinh(x%x)
    m%d = x%d * cosh(x%x)
  end function sinh_x_r

  function cosh_x_r(x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'cosh_x_r'
    m%x = cosh(x%x)
    m%d = x%d * sinh(x%x)
  end function cosh_x_r

  function tanh_x_r(x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'tanh_x_r'
    m  = div_x_x(sinh(x),cosh(x))
  end function tanh_x_r

  function log_x_r(x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'log_x_r'
    m%x = log(x%x)
    m%d = x%d/x%x
  end function log_x_r

  function exp_x_r(x) result(m)
    type(auto_var) :: m
    type(auto_var), intent(in) :: x
    if (debug_level > 0) write(*,'(a)') 'exp_x_r'
    m%x = exp(x%x)
    m%d = m%x
  end function exp_x_r

  !============================================================================
  !
  ! Unit test
#ifdef UTEST
  subroutine utest

    type(auto_var) :: x, y, z, f, u(2), s(3), t(3), v(3)
    real(8) :: e = exp(1.0d0)

    call set_val(x,3)
    y = x**2
    call testResult('x**2',auto_var(9,6),y)

    y = x**3 + x
    call testResult('x**3 + x',auto_var(30,28),y)

    y = 3*x**2
    call testResult('3*x**2',auto_var(27,18),y)

    y = 3*x**4 + x*2
    call testResult('3*x**4 + 2*x',auto_var(3*3**4+2*3,12*3**3+2),y)

    y = 3*x**2 + x*2.0d0 - 5
    call testResult('3*x**2 + 2*x - 5',auto_var(28,20),y)

    y = (x + 2)*(x + 3)*(x - 1)
    call testResult('(x + 2)*(x + 3)*(x - 1)',auto_var((3+2)*(3+3)*(3-1),3*3**2+8*3+1),y)

    y = (x + 2)*(3 - x)*(x**2 - 1)
    call testResult('(x + 2)*(3 - x)*(x**2 - 1)',auto_var(0,-40),y)

    y = (x + 2)/(x**2 - 1)
    call testResult('(x + 2)/(x**2 - 1)',auto_var(1.5d0/2 - 0.5d0/4,-1.5d0/2**2+0.5d0/4**2),y)
    ! and now the same function as partial fractions
    y = 1.5d0/(x-1) - 0.5d0/(x+1)
    call testResult('1.5d0/(x-1) - 0.5d0/(x+1) [previous function as partial fractions]',&
         auto_var(1.5d0/2 - 0.5d0/4,-1.5d0/2**2+0.5d0/4**2),y)

    call set_val(x,0.5d0)
    y = 1.0d0/(1-x)
    call testResult('1/(1-x)',auto_var(2,4),y)

    call set_val(x,4)
    y = 4/x
    call testResult('4/x',auto_var(1,-1.0/4),y)

    y = e**x
    call testResult('e**x',auto_var(e**4,e**4),y)

    y = 2**x
    call testResult('2**x',auto_var(2**4,2**4*log(2.0d0)),y)

!!$    y = x**x  ! - not yet correctly implemented
!!$    call testResult('x**x',auto_var(4**4,(1+log(4.0d0))*4**4),y)

    call set_val(x,1)
    y = sin(x)
    call testResult('sin(x)',auto_var(sin(1.0d0),cos(1.0d0)),y)

    call set_val(x,2)
    y = cos(x)
    call testResult('cos(x)',auto_var(cos(2.0d0),-sin(2.0d0)),y)

    call set_val(x,2)
    y = sin(1/x)
    call testResult('sin(1/x)',auto_var(sin(1/2.0d0),-cos(1/2.0d0)/4),y)

    y = sqrt(x)
    call testResult('sqrt(x)',auto_var(sqrt(2.0d0), 0.5d0/sqrt(2.0d0)),y)

    call set_val(u(1),3,.false.)
    call set_val(u(2),4,.false.)
    y = norm2(u)
    call testResult('||y||',auto_var(5,0),y)
    call make_var(u(2))
    y = norm2(u)
    call testResult('sqrt(9+u(2)**2) == ||u||',sqrt(9 + u(2)**2),y)

    ! Cross product
    call set_val(x,2)
    call make_var([0.0d0, 1.0d0, -1.0d0],t)
    t(1) = x**2
    call set_val(s(1), 2, .false.)
    s(2) = x
    s(3) = 1/x
    v = t .cross. s
    call testResult('_t_ x _x_ (1)',auto_var(2.5d0,0.75d0),v(1))
    call testResult('_t_ x _x_ (2)',auto_var(-4.0d0,-1.0),v(2))
    call testResult('_t_ x _x_ (3)',auto_var(6.0d0,12.0d0),v(3))

   ! Partial derivatives
    call set_val(x,3,.true.)
    call set_val(y,2,.false.)
    z = x**2 - 2*x*y
    call testResult('x**2 - 2*x*y , Fx',auto_var(-3,2),z)

    call set_val(x,3,.false.)
    call set_val(y,2,.true.)
    z = x**2 - 2.0d0*x*y
    call testResult('x**2 - 2*x*y , Fy',auto_var(-3,-6),z)

    call set_val(x,2,.true.); call set_val(y,3,.false.); call set_val(z,0.6d0,.false.)
    f = (x-1)*sin(z) + (y+x)*cos(z/2)**2
    call testResult('(x-1)*sin(z) + (y+x)*cos(z/2)**2 Fx',auto_var(sin(0.6d0)+5*cos(0.3d0)**2,sin(0.6d0)+cos(0.3d0)**2),f)

    call set_val(x,2,.false.); call set_val(y,3,.true.); call set_val(z,0.6d0,.false.)
    f = (x-1)*sin(z) + (y+x)*cos(z/2)**2
    call testResult('(x-1)*sin(z) + (y+x)*cos(z/2)**2 Fy',auto_var(sin(0.6d0)+5*cos(0.3d0)**2,cos(0.3d0)**2),f)

    call set_val(x,2,.false.); call set_val(y,3,.false.); call set_val(z,0.6d0,.true.)
    f = (x-1)*sin(z) + (y+x)*cos(z/2)**2
    call testResult('(x-1)*sin(z) + (y+x)*cos(z/2)**2 Fz', &
         auto_var(sin(0.6d0)+5*cos(0.3d0)**2,cos(0.6d0) - 5*cos(0.3d0)*sin(0.3d0)),f)

    call set_val(x,3,.true.)
    f = log(4.0d0 + x)
    call testResult('log(4 + x)', &
         auto_var(log(4.0d0 + 3),1/(4.0+3)),f)

    call set_val(x,3,.true.)
    call set_val(y,2,.false.)
    f = log(4.0d0 + x**2)
    call testResult('log(4 + x**2)', &
         auto_var(log(4.0d0 + 3**2),2*3/(4.0+3**2)),f)

    ! The example in the comment at the top with call sequence
    block
        type(auto_var) :: f, x
        debug_level = 1
        write(*,'(a)') 'Call sequence for 1/(1-x), '
        call x%set(0.5d0)
        f = 1/(1-x)
        call testResult('1/(1-x)', &
         auto_var(1/(1-0.5d0),1/(1-0.5d0)**2),f)
    end block

  contains
    subroutine testResult(str,ref,res)
      character(len=*), intent(in) :: str
      type(auto_var), intent(in) :: res
      type(auto_var), intent(in) :: ref
      if (res == ref) then
         write(*,'(a)') 'passed'//' :: '//str
      else
         write(*,'(2(a,f0.6))') 'FAILED :: '//str//' => ', res%x - ref%x,' ; ', res%d - ref%d
      end if
    end subroutine testResult

  end subroutine utest
#endif
end module auto_diff

#ifdef UTEST
program tauto
  use auto_diff
  call utest
end program tauto
#endif


!> Author:   Jabir Ali Ouassou
!> Category: Foundation
!>
!> This file defines functions that perform some common calculus operations.

module calculus_m
  use :: basic_m
contains

  !--------------------------------------------------------------------------------
  ! Specific implementations of the `mean` interface
  !--------------------------------------------------------------------------------

  pure function mean_array_re(x) result(r)
    !! Calculates the mean value of a real-valued array.
    real(wp), dimension(:), intent(in) :: x   !! Real-valued array
    real(wp)                           :: r   !! Mean value <x>

    r = sum(x)/max(1,size(x))
  end function

  pure function mean_array_cx(x) result(r)
    !! Calculates the mean value of a complex-valued array.
    complex(wp), dimension(:), intent(in) :: x  !! Complex-valued array
    complex(wp)                           :: r  !! Mean value <x>

    r = sum(x)/max(1,size(x))
  end function

  !--------------------------------------------------------------------------------
  ! Specific implementations of the `differentiate` interface
  !--------------------------------------------------------------------------------

  pure function differentiate_array_re(x, y) result(r)
    !! This function calculates the numerical derivative of an array y with respect to x, using a central difference approximation
    !! at the interior points and forward/backward difference approximations at the exterior points. Note that since all the three
    !! approaches yield two-point approximations of the derivative, the mesh spacing of x does not necessarily have to be uniform.
    real(wp), dimension(:),       intent(in)  :: x   !! Variable x
    real(wp), dimension(size(x)), intent(in)  :: y   !! Function y(x)
    real(wp), dimension(size(x))              :: r   !! Derivative dy/dx

    ! Differentiate using finite differences
    associate(n => size(x))
      r(   1   ) = (y( 1+1 ) - y(  1  ))/(x( 1+1 ) - x(  1  ))
      r(1+1:n-1) = (y(1+2:n) - y(1:n-2))/(x(1+2:n) - x(1:n-2))
      r(   n   ) = (y(  n  ) - y( n-1 ))/(x(  n  ) - x( n-1 ))
    end associate
  end function

  pure function differentiate_array_cx(x, y) result(r)
    !! Complex version of differentiate_array_re.
    real(wp),    dimension(:),       intent(in)  :: x   !! Variable x
    complex(wp), dimension(size(x)), intent(in)  :: y   !! Function y(x)
    complex(wp), dimension(size(x))              :: r   !! Derivative dy/dx

    ! Differentiate using finite differences
    associate(n => size(x))
      r(   1   ) = (y( 1+1 ) - y(  1  ))/(x( 1+1 ) - x(  1  ))
      r(1+1:n-1) = (y(1+2:n) - y(1:n-2))/(x(1+2:n) - x(1:n-2))
      r(   n   ) = (y(  n  ) - y( n-1 ))/(x(  n  ) - x( n-1 ))
    end associate
  end function

  !--------------------------------------------------------------------------------
  ! Specific implementations of the `integrate` interface
  !--------------------------------------------------------------------------------

  pure function integrate_array_re(x, y) result(r)
    !! This function calculates the integral of an array y with respect to x using a trapezoid
    !! approximation. Note that the mesh spacing of x does not necessarily have to be uniform.
    real(wp), dimension(:),       intent(in)  :: x   !! Variable x
    real(wp), dimension(size(x)), intent(in)  :: y   !! Function y(x)
    real(wp)                                  :: r   !! Integral ∫y(x)·dx

    ! Integrate using the trapezoidal rule
    associate(n => size(x))
      r = sum((y(1+1:n-0) + y(1+0:n-1))*(x(1+1:n-0) - x(1+0:n-1)))/2
    end associate
  end function

  pure function integrate_array_cx(x, y) result(r)
    !! Complex version of integrate_array_re.
    real(wp),    dimension(:),       intent(in) :: x   !! Variable x
    complex(wp), dimension(size(x)), intent(in) :: y   !! Function y(x)
    complex(wp)                                 :: r   !! Integral ∫y(x)·dx

    ! Integrate using the trapezoidal rule
    associate(n => size(x))
      r = sum((y(1+1:n-0) + y(1+0:n-1))*(x(1+1:n-0) - x(1+0:n-1)))/2
    end associate
  end function

  function integrate_range_re(x, y, a, b) result(r)
    !! This function constructs a piecewise hermitian cubic interpolation of an array y(x) based on
    !! discrete numerical data, and subsequently evaluates the integral of the interpolation in the
    !! range (a,b). Note that the mesh spacing of x does not necessarily have to be uniform.
    real(wp), dimension(:),       intent(in)  :: x  !! Variable x
    real(wp), dimension(size(x)), intent(in)  :: y  !! Function y(x)
    real(wp),                     intent(in)  :: a  !! Left endpoint
    real(wp),                     intent(in)  :: b  !! Right endpoint
    real(wp)                                  :: r  !! Integral ∫y(x)·dx

    external                                  :: dpchez
    real(wp), external                        :: dpchqa
    real(wp), dimension(size(x))              :: d
    integer                                   :: err

    ! Create a PCHIP interpolation of the input data
    call dpchez(size(x), x, y, d, .false., 0, 0, err)

    ! Integrate the interpolation in the provided range
    r = dpchqa(size(x), x, y, d, a, b, err)
  end function

  function integrate_range_cx(x, y, a, b) result(r)
    !! Complex version of integrate_range_re.
    real(wp),    dimension(:),       intent(in)  :: x   !! Variable x
    complex(wp), dimension(size(x)), intent(in)  :: y   !! Function y(x)
    real(wp),                        intent(in)  :: a   !! Left endpoint
    real(wp),                        intent(in)  :: b   !! Right endpoint
    complex(wp)                                  :: r   !! Integral ∫y(x)·dx

    ! Integrate the real and imaginary parts separately
    r = cx( integrate_range_re(x, re(y), a, b),&
            integrate_range_re(x, im(y), a, b) )
  end function

  !--------------------------------------------------------------------------------
  ! Specific implementations of the `interpolate` interface
  !--------------------------------------------------------------------------------

  function interpolate_array_re(x, y, p) result(r)
    !! This function constructs a piecewise hermitian cubic interpolation of an array y(x) based on discrete numerical data,
    !! and evaluates the interpolation at points p. Note that the mesh spacing of x does not necessarily have to be uniform.
    real(wp), dimension(:),       intent(in)  :: x   !! Variable x
    real(wp), dimension(size(x)), intent(in)  :: y   !! Function y(x)
    real(wp), dimension(:),       intent(in)  :: p   !! Interpolation domain p
    real(wp), dimension(size(p))              :: r   !! Interpolation result y(p)

    external                                  :: dpchez
    external                                  :: dpchfe
    real(wp), dimension(size(x))              :: d
    integer                                   :: err

    ! Create a PCHIP interpolation of the input data
    call dpchez(size(x), x, y, d, .false., 0, 0, err)

    ! Extract the interpolated data at provided points
    call dpchfe(size(x), x, y, d, 1, .false., size(p), p, r, err)
  end function

  function interpolate_array_cx(x, y, p) result(r)
    !! Complex version of interpolate_array_re.
    real(wp),    dimension(:),       intent(in)  :: x   !! Variable x
    complex(wp), dimension(size(x)), intent(in)  :: y   !! Function y(x)
    real(wp),    dimension(:),       intent(in)  :: p   !! Interpolation domain p
    complex(wp), dimension(size(p))              :: r   !! Interpolation result y(p)

    ! Interpolate the real and imaginary parts separately
    r = cx( interpolate_array_re(x, re(y), p),&
            interpolate_array_re(x, im(y), p) )
  end function

  function interpolate_point_re(x, y, p) result(r)
    !! Wrapper for interpolate_array_re that accepts scalar arguments.
    real(wp), dimension(:),       intent(in)  :: x   !! Variable x
    real(wp), dimension(size(x)), intent(in)  :: y   !! Function y(x)
    real(wp),                     intent(in)  :: p   !! Interpolation point p
    real(wp)                                  :: r   !! Interpolation result y(p)
    real(wp), dimension(1)                    :: rs

    ! Perform the interpolation
    rs = interpolate_array_re(x, y, [p])

    ! Extract the scalar result
    r = rs(1)
  end function

  function interpolate_point_cx(x, y, p) result(r)
    !! Complex version of interpolate_point_re.
    real(wp),    dimension(:),       intent(in)  :: x   !! Variable x
    complex(wp), dimension(size(x)), intent(in)  :: y   !! Function y(x)
    real(wp),                        intent(in)  :: p   !! Interpolation point p
    complex(wp)                                  :: r   !! Interpolation result y(p)
    complex(wp), dimension(1)                    :: rs

    ! Perform the interpolation
    rs = cx( interpolate_array_re(x, re(y), [p]),&
             interpolate_array_re(x, im(y), [p]) )

    ! Extract the scalar result
    r = rs(1)
  end function

  pure function interpolate_point_matrix_re(x, y, p) result(r)
    !! Perform a Piecewise Cubic Hermitian Interpolation of a matrix function using Catmull-Rom splines.
    real(wp), dimension(:),       intent(in) :: x  !! Variable x
    real(wp), dimension(:,:,:),   intent(in) :: y  !! Function y(x)
    real(wp),                     intent(in) :: p  !! Interpolation point p
    real(wp), dimension(size(y,1),size(y,2)) :: r  !! Interpolation result y(p)

    integer  :: n, m
    real(wp) :: t

    ! Find the nearest known point y(x)
    m = size(x)
    n = floor(p*(m-1) + 1);

    ! Perform the interpolation
    if (n <= 0) then
      ! Exterior: nearest extrapolation
      r = y(:,:,1)
    else if (n >= m) then
      ! Exterior: nearest extrapolation
      r = y(:,:,m)
    else
      ! Interior: spline interpolation
      t = (p - x(max(n,1)))/(x(min(n+1,m)) - x(max(n,1)))
      r = y(:,:,max(n-1,1)) * (     -0.5*t +1.0*t**2 -0.5*t**3)  &
        + y(:,:,max(n-0,1)) * (+1.0        -2.5*t**2 +1.5*t**3)  &
        + y(:,:,min(n+1,m)) * (     +0.5*t +2.0*t**2 -1.5*t**3)  &
        + y(:,:,min(n+2,m)) * (            -0.5*t**2 +0.5*t**3)
    end if
  end function

  !--------------------------------------------------------------------------------
  ! Specific implementations of the `linspace` interface
  !--------------------------------------------------------------------------------

  pure subroutine linspace_array_re(array, first, last)
    !! Populates an existing array with elements from `first` to `last`, inclusive.
    real(wp), dimension(:), intent(out) :: array   !! Output array to populate
    real(wp),               intent(in)  :: first   !! Value of first element
    real(wp),               intent(in)  :: last    !! Value of last  element
    integer                             :: n

    do n=1,size(array)
      array(n) = first + ((last-first)*(n-1))/(size(array)-1)
    end do
  end subroutine
end module


PROGRAM F044

    ! Copyright 2021 Melwyn Francis Carlo

    IMPLICIT NONE

    INTEGER, PARAMETER :: MAX_N = 5E3

    INTEGER :: MIN_PD = 1E7

    INTEGER :: I, J, P1, P2, P1PP2, P1MP2

    REAL    :: SQRT_TERM

    DO I = 1, MAX_N

        P1 = FLOOR(0.5 * I * ((3 * I) - 1))

        DO J = (I + 1), MAX_N

            P2 = FLOOR(0.5 * J * ((3 * J) - 1))

            P1PP2 = P1 + P2

            SQRT_TERM = SQRT(1.0E0 + (24.0E0 * REAL(P1PP2)))

            IF (SQRT_TERM - INT(SQRT_TERM) > 0) CYCLE

            IF (MOD((INT(SQRT_TERM) + 1), 6) /= 0) CYCLE

            P1MP2 = P2 - P1

            SQRT_TERM = SQRT(1.0E0 + (24.0E0 * REAL(P1MP2)))

            IF (SQRT_TERM - INT(SQRT_TERM) > 0) CYCLE

            IF (MOD((INT(SQRT_TERM) + 1), 6) == 0) THEN
                IF (P1MP2 < MIN_PD) MIN_PD = P1MP2
            END IF

        END DO

    END DO

    PRINT ('(I0)'), MIN_PD

END PROGRAM F044


function norm(A,nrm_type) result(nrm)
! Returns matrix norm of A. Only Supports 1 norm and Inf norm
! === Parameters ===
! A         - (matrix)
! nrm_type  - (integer) nrm_type=1 for one norm and nrm_type=-1 for Inf norm
! === Output ===
! nrm       - (double) matrix norm
complex(kind=8),  intent(in) :: A(:,:)
integer, intent(in)          :: nrm_type
real(kind=8)                 :: nrm, nrm_canidate
integer :: i,j,d1,d2
d1 = size(A,1)
d2 = size(A,2)
nrm = 0.d0
if(nrm_type == -1) then     ! Infinity nrm
    do i=1,d1
        nrm_canidate = 0.d0
        do j=1,d2
            nrm_canidate = nrm_canidate + abs(A(i,j))
        enddo
        if(nrm_canidate > nrm) then
            nrm = nrm_canidate
        endif
    enddo
elseif(nrm_type == 1) then ! 1 nrm
    do j=1,d2
        nrm_canidate = 0.d0
        do i=1,d1
            nrm_canidate = nrm_canidate + abs(A(i,j))
        enddo
        if(nrm_canidate > nrm) then
            nrm = nrm_canidate
        endif
    enddo
endif
end function norm


!Autor: Claudio Iván Esparza Castañeda
!Título: Newton-Raphson simple
!Descripción: Calcula las raíces de una función por medio del método de Newton-Raphson
!Fecha: 17/03/2020

Program newrap
  implicit none
  REAL::e, er, x, y, f, fp, xe
  INTEGER::i
  CALL graf1()
  WRITE(*, *) "Valor inicial" !Preguntar final del intervalo
  READ(*, *) x !Ingresar final del intervalo
  WRITE(*, *) "Error esperado" !Preguntar el error
  READ(*, *) er !Ingresar el error
  i=0 !Inicializar contador de ciclos
  do
     i=i+1 !Añadir uno al contador
     xe=x !Asignar x anterior
     x=x-f(x)/fp(x)
     if (x .NE. 0) then !Validación del intervalo
        e=abs((x-xe)/x)*100 !Cálculo del error
     end if
     if (e<er) then !Validar si el error es menor al esperado
        EXIT
     end if
  end do
  write(*, *) "       x                 f(x)            e               i" !Cabecera del resultado
  write(*, *) x, f(x), e, i !Imprimir resultado
  open(unit=3, file="Punto.dat", status="unknown") !Archivo para graficar el punto de intersección
  write(3, *) x, f(x) !Escribir en archivo
  close(3)
  CALL graf2()
end Program newrap

subroutine graf1() !subrutina que grafica
  implicit none !Quitar variables implícitas
  REAL::x, y, f, h, a, b !Variables de tipo real
  INTEGER::N, i !Variables de tipo entero
  open(unit=1, file="Datos.dat", status="unknown") !Abrir archivo para guardar puntos
  open(unit=2, file="Graf.plt", status="unknown") !Abrir archivo para guardar información de la gŕafica
  WRITE(*, *) "Inicio de la gráfica" !Preguntar inicio de gráfica
  READ(*, *) a !Ingresar inicio de la gráfica
  WRITE(*, *) "Final de la gráfica" !Preguntar final de la gráfica
  READ(*, *) b !Ingresar final de la gráfica
  WRITE(*, *) "¿Con cuántos puntos?" !Preguntar número de puntos
  READ(*, *) N !Ingresar número de puntos
  h=(b-a)/N !Tamaño de paso
  do i=0, N !Construir datos
     x=a+i*h
     y=f(x)
     WRITE(1, *) x, y !Escribir datos en archivo
  end do
  close(1)
  !Establecer todos los parámetros de la gráfica
  WRITE(2, *) "set title 'y=sin(x)-cos(x)'"
  WRITE(2, *) "set xlabel 'x'"
  WRITE(2, *) "set ylabel 'y'"
  WRITE(2, *) "m='./Datos.dat'"
  WRITE(2, *) "set nokey"
  WRITE(2, *) "set grid"
  WRITE(2, *) "p m w l"
  WRITE(2, *) "replot"
  close(2)
  CALL SYSTEM("gnuplot -p Graf.plt") !Llamar a GNUPlot desde la terminal
end subroutine graf1

subroutine graf2() !subrutina que grafica
  implicit none !Quitar variables implícitas
  REAL::x, y, f, h, a, b !Variables de tipo real
  INTEGER::N, i !Variables de tipo entero
  open(unit=1, file="Datos.dat", status="unknown") !Abrir archivo para guardar puntos
  open(unit=2, file="Graf.plt", status="unknown") !Abrir archivo para guardar información de la gŕafica
  WRITE(*, *) "Inicio de la gráfica" !Preguntar inicio de gráfica
  READ(*, *) a !Ingresar inicio de la gráfica
  WRITE(*, *) "Final de la gráfica" !Preguntar final de la gráfica
  READ(*, *) b !Ingresar final de la gráfica
  WRITE(*, *) "¿Con cuántos puntos?" !Preguntar número de puntos
  READ(*, *) N !Ingresar número de puntos
  h=(b-a)/N !Tamaño de paso
  do i=0, N !Construir datos
     x=a+i*h
     y=f(x)
     WRITE(1, *) x, y !Escribir datos en archivo
  end do
  close(1)
  !Establecer todos los parámetros de la gráfica
  WRITE(2, *) "set title 'y=sin(x)-cos(x)'"
  WRITE(2, *) "set xlabel 'x'"
  WRITE(2, *) "set ylabel 'y'"
  WRITE(2, *) "m='./Datos.dat'"
  WRITE(2, *) "n='./Punto.dat'"
  WRITE(2, *) "set nokey"
  WRITE(2, *) "set grid"
  WRITE(2, *) "p m w l, n"
  WRITE(2, *) "set term png"
  WRITE(2, *) "set out 'Graf.png'"
  WRITE(2, *) "replot"
  close(2)
  CALL SYSTEM("gnuplot -p Graf.plt") !Llamar a GNUPlot desde la terminal
end subroutine graf2

function f(x) !Función que genera los puntos
  implicit none
  REAL::f, x
  f=sin(x)-cos(x)
end function f

function fp(x) !Función derivada
  implicit none
  REAL::fp, x
  fp=cos(x)+sin(x)
end function fp


! Created by EverLookNeverSee@GitHub on 4/22/20.
! This program finds all numbers between 100 and 999 such that the
! number is equal to the sum of the cubes of the digits. For Example:
! 153 = (1 ** 3) + (5 ** 3) + (3 ** 3)

program number_cube
    implicit none
    ! defining integer variables
    integer :: number, d1, d2, d3, d_temp
    ! printing a statement
    print *, "The numbers are:"
    ! Extracting digits using do
    do number = 100, 999
        d1 = number / 100       ! The left most digit of number
        d_temp = mod(number, 100)
        d2 = d_temp / 10        ! The second digit
        d3 = mod(d_temp, 10)    ! The right most digit
        if (d1 ** 3 + d2 ** 3 + d3 ** 3 == number) then
            print *, number
        end if
    end do
end program number_cube


!*****************************************************************************************
!>
!  Units test for 1d-6d tensor product b-spline interpolation.

    program bspline_test

    use bspline_module
    use bspline_kinds_module, only: wp, ip

    implicit none

    integer(ip),parameter :: nx = 50     !! number of points in x
    integer(ip),parameter :: nx_new = 512     !! nbr of interpolated points
    integer(ip),parameter :: kx = 4     !! order in x

    integer(ip),parameter :: iknot = 0  !! automatically select the knots

    real(wp), parameter   :: x_min=0._wp, x_max=10._wp !! range og x-grid

    real(wp) :: x(nx),tx(nx+kx)
    real(wp) :: fcn_1d(nx)

    real(wp),dimension(3*kx)                     :: w1_1d

    real(wp) :: tol,dx,dx_new,int_1d,int_1d_new
    real(wp),dimension(6) :: val,tru,err,errmax
    logical :: fail
    integer(ip) :: i,j,k,l,m,n,idx,idy,idz,idq,idr,ids
    integer(ip),dimension(6) :: iflag
    integer(ip) :: inbvx,inbvy,inbvz,inbvq,inbvr,inbvs
    integer(ip) :: iloy,iloz,iloq,ilor,ilos
    integer ::     count_rate, count_max,count,t_start,t_final
    real    ::     time_s

    real(wp), allocatable :: xout(:),fout(:)

    call system_clock(count_max=count_max, count_rate=count_rate)

    call system_clock(t_start)

    print*, ""
    print*, "-----------1D-Bspline Interpolation--------------"
    print*, ""

!print out the output file
    open(100,file='1D-TestBspline-Without-Interpolation.dat')
    open(101,file='1D-TestBspline-With-Interpolation.dat')

    fail = .false.
    tol = 100 * epsilon(1.0_wp)
    idx = 0

    allocate(xout(nx_new)); allocate(fout(nx_new))

     dx = (x_max-x_min)/real(nx-1,wp)
     do i=1,nx
        x(i) = x_min + real(i-1,wp)*dx
     end do
     do i=1,nx
        fcn_1d(i) = f1(x(i))
     end do

!defining the interpolated grid
     dx_new = (x_max-x_min)/real(nx_new-1,wp)
     do i=1,nx_new
        xout(i) = x_min + real(i-1,wp)*dx_new
     enddo
     print*,"--Grid parameter----"
     print*, "--nbr of point:nx, nx_new",nx, nx_new
     print*, "--spatial step:dx, dx_new", dx, dx_new
     print*,"--xout(1),xout(nx_new)",xout(1),xout(nx_new)
     print*,"--x(a),x(nx)",x(1),x(nx)

    !have to set these before the first evaluate call:
    inbvx = 1

    ! initialize
    call db1ink(x,nx,fcn_1d,kx,iknot,tx,fcn_1d,iflag(1))

    if (any(iflag/=0)) then
        do i=1,1
            if (iflag(i)/=0) then
                write(*,*) 'Error initializing ',i,'D spline: '//get_status_message(iflag(i))
            end if
        end do
    end if

    ! compute max error at interpolation points

     errmax = 0.0_wp
     do i=1,size(xout)
       call db1val(xout(i),idx,&
           tx,nx,kx,fcn_1d,val(1),iflag(1),inbvx,&
           w1_1d)
                        tru(1)    = f1(x(i))
                        err(1)    = abs(tru(1)-val(1))
                        errmax(1) = max(err(1),errmax(1))
           fout(i) = val(1)
     end do

    ! check max error against tolerance
    do i=1,1
        write(*,*) i,'D: max error:', errmax(i)
!        if (errmax(i) >= tol) then
!            write(*,*)  ' ** test failed ** '
!        else
!            write(*,*)  ' ** test passed ** '
!        end if
        write(*,*) ''
    end do

!Evaluate the integral
   int_1d = sum(fcn_1d(1:nx))*dx
   int_1d_new = sum(fout(1:nx_new))*dx_new

   print*,"--1D-Integral without interpolation", int_1d
   print*,"--1D-Integral with interpolation", int_1d_new

   call system_clock(t_final)

   time_s = real(t_final - t_start)/real(count_rate)
   print*,""
   print*, '--Time it takes (s)', time_s

!prinout data
!data without interpolation
    do i=1,nx
      write(100,*)x(i),fcn_1d(i)
   enddo
!data with interpolation
   do i=1,size(xout)
      write(101,*)xout(i),fout(i)
   enddo

    contains

        real(wp) function f1(x) !! 1d test function
        implicit none
        real(wp) :: x
        !f1 = 0.5_wp * (x*exp(-x) + sin(x) )
         f1 = sin(x)
        end function f1

        real(wp) function f2(x,y) !! 2d test function
        implicit none
        real(wp) x,y,piov2
        piov2 = 2.0_wp * atan(1.0_wp)
        f2 = 0.5_wp * (y*exp(-x) + sin(piov2*y) )
        end function f2

        real(wp) function f3 (x,y,z) !! 3d test function
        implicit none
        real(wp) x,y,z,piov2
        piov2 = 2.0_wp*atan(1.0_wp)
        f3 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) )
        end function f3

        real(wp) function f4 (x,y,z,q) !! 4d test function
        implicit none
        real(wp) x,y,z,q,piov2
        piov2 = 2.0_wp*atan(1.0_wp)
        f4 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) + q )
        end function f4

        real(wp) function f5 (x,y,z,q,r) !! 5d test function
        implicit none
        real(wp) x,y,z,q,r,piov2
        piov2 = 2.0_wp*atan(1.0_wp)
        f5 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) + q*r )
        end function f5

        real(wp) function f6 (x,y,z,q,r,s) !! 6d test function
        implicit none
        real(wp) x,y,z,q,r,s,piov2
        piov2 = 2.0_wp*atan(1.0_wp)
        f6 = 0.5_wp*( y*exp(-x) + z*sin(piov2*y) + q*r + 2.0_wp*s )
        end function f6

    end program bspline_test


program SqrtPrime
implicit none

    integer:: i,j,n
    read*, n

    j = sqrt(real(n))
    i = 2
    do while(i<=j .and. mod(n,i)/=0)
        i = i + 1
    end do

    if (i>j) then
    print*,n, 'is a prime number'
    else
    print*,n, 'is NOT a prime number'
    end if
end


MODULE funcs
IMPLICIT NONE
  INTEGER :: i, prod = 1
  CONTAINS
  INTEGER FUNCTION factorial(k)
  IMPLICIT NONE
    INTEGER, INTENT(IN) :: k
    IF (k .eq. 0) THEN
      factorial = 1
    ELSE
      DO i = 1, k
        prod = prod * (i)
      END DO
    END IF
    factorial = prod
  END FUNCTION factorial
END MODULE funcs

PROGRAM cars_passing
IMPLICIT NONE
  INTEGER :: factorial
  REAL :: poisson
  REAL :: t = 1.0, lambda = 1.6
  INTEGER :: i
  !WRITE(*, *) factorial(0), factorial(1), factorial(5)
  WRITE(*, '(F6.4, A, F6.4, A)') lambda, " cars pass in ", t, " minutes."
  DO i = 0, 5
    WRITE(*, '(A, I2, A, F14.10)') "Probability of ", i, " cars passing:", poisson(i, t, lambda)
  END DO
END PROGRAM cars_passing

REAL FUNCTION poisson(k, t, lambda)
USE funcs
IMPLICIT NONE
  INTEGER, INTENT(IN) :: k
  REAL, INTENT(IN) :: t, lambda
  REAL, PARAMETER :: E = 2.71828
  poisson = (E**(-lambda * t)) * (((lambda * t)**k) / REAL(factorial(k)))
END FUNCTION poisson


module matmod
  implicit none

! Overloading the ** operator does not work because the compiler cannot
! differentiate between matrix exponentiation and the elementwise raising
! of an array to a power therefore we define a new operator
  interface operator (.matpow.)
    module procedure matrix_exp
  end interface

contains

function matrix_exp(m, n) result (res)
  real, intent(in)  :: m(:,:)
  integer, intent(in)  :: n
  real :: res(size(m,1),size(m,2))
  integer :: i

  if(n == 0) then
    res = 0
    do i = 1, size(m,1)
      res(i,i) = 1
    end do
    return
  end if

  res = m
  do i = 2, n
    res = matmul(res, m)
  end do

end function matrix_exp
end module matmod

program Matrix_exponentiation
  use matmod
  implicit none

  integer, parameter :: n = 3
  real, dimension(n,n) :: m1, m2
  integer :: i, j

  m1 = reshape((/ (i, i = 1, n*n) /), (/ n, n /), order = (/ 2, 1 /))

  do i = 0, 4
    m2 = m1 .matpow. i
    do j = 1, size(m2,1)
      write(*,*) m2(j,:)
    end do
    write(*,*)
  end do

end program Matrix_exponentiation


program greatest_common_divisor
    implicit none
    integer, parameter :: min_val = 1, max_val = 20
    integer :: n, p, a, b

    do n = min_val, max_val
        do p = min_val, max_val
            a = n
            b = p
            do while (a /= b)
                if (a < b) then
                    b = b - a
                else if (a > b) then
                    a = a - b
                end if
            end do
            print *, n, p, a
        end do
    end do

end program greatest_common_divisor


! Test complex munbers
program testcmplx
   implicit none
   complex(kind=4) c, d
   complex(kind=8) z
   real(kind=4) x, y
   real(kind=8) q

   ! cmplx intrinsic
   x = 3
   y = 4
   c = cmplx(x,y)
   if (c .ne. (3.0, 4.0)) call abort
   x = 4
   y = 3
   z = cmplx(x, y, 8)
   if (z .ne. (4.0, 3.0)) call abort
   z = c
   if (z .ne. (3.0, 4.0)) call abort

   ! dcmplx intrinsic
   x = 3
   y = 4
   z = dcmplx (x, y)
   if (z .ne. (3.0, 4.0)) call abort

   ! conjucates and aimag
   c = (1.0, 2.0)
   c = conjg (c)
   x = aimag (c)
   if (abs (c - (1.0, -2.0)) .gt. 0.001) call abort
   if (x .ne. -2.0) call abort
   z = (2.0, 1.0)
   z = conjg (z)
   q = aimag (z)
   if (z .ne. (2.0, -1.0)) call abort
   if (q .ne. -1.0) call abort

   ! addition, subtraction and multiplication
   c = (1, 3)
   d = (5, 2)
   if (c + d .ne. ( 6, 5)) call abort
   if (c - d .ne. (-4, 1)) call abort
   if (c * d .ne. (-1, 17)) call abort

   ! test for constant folding
   if ((35.,-10.)**0.NE.(1.,0.)) call abort
end program


program main
  ! Default
  implicit none

  integer(4), parameter :: grid_size = 20
  integer(8) :: nvalid

  ! compute combinatorics
  nvalid = two_n_choose_n(grid_size)
  write(*,*) "number of valid paths: ",nvalid

contains

  pure function two_n_choose_n(n)
    ! Default
    implicit none

    ! Function arguments
    integer(4), intent(in) :: n
    integer(8)             :: two_n_choose_n

    ! Local variables
    integer(4) :: i

    two_n_choose_n = 1
    do i=1,n
       two_n_choose_n = two_n_choose_n * (n+i)/i
    enddo

    return
  end function two_n_choose_n

end program main


!  Task
!  1. if you define the input as int, then it should has a range
!  2.  make a data structure to store  denumerator which makes `flag = 1`.
!

PROGRAM discernPrimeNum
  IMPLICIT NONE
  INTEGER :: input
  INTEGER :: i, flag = 0
  READ (*,*) input
  DO i = 2, INT(input/2)
     IF (MOD(input,i) == 0) THEN
        flag = 1
     END IF
     EXIT
  END DO
  IF (flag == 0) THEN
     PRINT *, input, "is a prime numbe"
  ELSE
     PRINT *, input, "is a composite number"
  END IF

END PROGRAM discernPrimeNum


C     Matrix multiplicaiton, version with call to MATMUL

      PROGRAM MAIN
      PARAMETER (L=200, M=200, N=200)
      REAL Z(L,N), X(L,M), Y(M,N)

C     Initialization

      DO I = 1,L
         DO J = 1,M
            X(I,J) = I
         ENDDO
      ENDDO

      DO J = 1,M
         DO K = 1,N
            Y(J,K) = J
         ENDDO
      ENDDO

      CALL MATMUL(Z,X,Y,L,M,N)

      END

      SUBROUTINE MATMUL(Z,X,Y,L,M,N)
      REAL Z(L,N), X(L,M), Y(M,N)

      DO I=1,L
         DO K=1,N
            Z(I,K) = 0.
            DO J=1,M
               Z(I,K) = Z(I,K) + X(I,J)*Y(J,K)
            ENDDO
         ENDDO
      ENDDO
      END


program list_primes

    ! this program takes an integer and then constructs and array of primes upto that number, and only checks
    ! the number against primes it has already calculated and stored in an array. It also skips all even numbers.

    implicit none
    integer(kind=16) :: a,i,p,k    !a is number to list primes till, i p k serve as counters for loop, array element, array loop
    integer, dimension(:), allocatable :: arr
    print *, "Give integer(>2) to list primes upto"
    read *, a
    if (a < 2) stop
    allocate (arr(a))    !could replace 'a' in this by estimates of prime counting to reduce memory usage
    arr(1) = 1
    arr(2)=2
    p=2
    do i=3,a,2
        do k=2,p
            if (mod(i,arr(k)) .eq. 0) exit
            if (k==p) arr(p+1) = i     !if k has cycled through all and still not found 0 then add to array as prime
            if (k==p) p = p+1          ! update element counter for the addition to the array above
        end do
    end do
    print *, 'Total Primes:',p
    print *, ' ---------------------------------------------------------------------------------------------------'
    print *,  arr(1:p)
end program list_primes


SUBROUTINE colinearity_angle (r_sat, v_sat, r_sun, epsilon_angle, epsilon_dot)

! ----------------------------------------------------------------------
! SUBROUTINE: colinearity_angle.f90
! ----------------------------------------------------------------------
! Purpose:
!  Computation of the colinearity angle between the orbital plane and the Sun vector
! ----------------------------------------------------------------------
! Input arguments:
! - r_sat: 			Satellite position vector (m)
! - v_sat: 			Satellite velocity vector (m/sec)
! - r_sun:			Sun position vector (m)
!
! Output arguments:
! - epsilon_angle:		Colinearity angle in degrees
! - epsilon_angle:		Colinearity angle partial derivative w.r.t. time
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou at Geoscience Australia
! Created:	24 April 2020
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      REAL (KIND = prec_d), INTENT(IN) :: r_sat(3), v_sat(3), r_sun(3)
! OUT
      REAL (KIND = prec_d), INTENT(OUT) :: epsilon_angle, epsilon_dot
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      REAL (KIND = prec_d) :: Xsat(3), dXsat(3), Xsun(3)
      REAL (KIND = prec_q) :: r_norm, v_norm
      REAL (KIND = prec_q) :: rr_dot, vv_dot
      REAL (KIND = prec_q) :: h_angmom(3), h_dot, h_norm
      REAL (KIND = prec_q) :: er(3), et(3), en(3)
	  REAL (KIND = prec_d) :: sn_dot, rn_cross(3), srn_dot, x_cross(3), y_cross(3)
	  REAL (KIND = prec_d) :: ry_dot, vy_dot
	  REAL (KIND = prec_d) :: acos_ry

! ----------------------------------------------------------------------
! Unit Vectors
! ----------------------------------------------------------------------
! Xsat:		Satellite position unit vector
      Xsat = (1D0 / sqrt(r_sat(1)**2 + r_sat(2)**2 + r_sat(3)**2) ) * r_sat

! dXsat:	Satellite Velocity unit vector
      dXsat = (1D0 / sqrt(v_sat(1)**2 + v_sat(2)**2 + v_sat(3)**2) ) * v_sat

! Xsun:		Sun position unit vector
      Xsun = (1D0 / sqrt(r_sun(1)**2 + r_sun(2)**2 + r_sun(3)**2) ) * r_sun
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Orbit normal vector (cross-track)
! ----------------------------------------------------------------------
! cross product of r,v : angular momentum per unit mass
      CALL productcross(r_sat, v_sat, h_angmom)
      CALL productdot(h_angmom, h_angmom, h_dot)
      h_norm = sqrt(h_dot)

! Cross-track or normal component
     en = (1D0 / h_norm) * h_angmom
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Colinearity angle: epsilon
! ----------------------------------------------------------------------
CALL productcross(en, Xsun,    x_cross)

CALL productcross(en, x_cross, y_cross)

CALL productdot(Xsat, y_cross, ry_dot)

CALL productdot(dXsat, y_cross, vy_dot)

acos_ry = ACOS( ry_dot ) * (180.0D0 / PI_global)

! Epsilon angle and partial derivative of epsilon w.r.t. time
IF ( acos_ry <= 90.0D0 ) THEN
	epsilon_angle = acos_ry
	epsilon_dot = (-1.0D0 / sin(epsilon_angle) ) * vy_dot

ELSE
	epsilon_angle = 180.0D0 - acos_ry
	epsilon_dot = (1.0D0 / sin(epsilon_angle) ) * vy_dot

END IF

END


module matrix_multiplier_mod
    use,intrinsic :: iso_fortran_env
    implicit none
contains
    function matmul_mod(a,b,md) result(ret)
        integer(int64),intent(in):: a(:,:),b(:,:),md
        integer(int64),allocatable:: ret(:,:)
        integer(int32):: i,j,k,ni,nj,nk

        ni = size(a(1,:))
        nj = size(b(:,1))
        nk = size(a(:,1))
        allocate(ret(ni,nj), source=0_int64)

        do i=1,ni
            do j=1,nj
                do k=1,nk
                    ret(j,i) = mod(ret(j,i)+mod(a(k,i)*b(j,k),md),md)
                end do
            end do
        end do
    end function

    function matmuler(a,e,md) result(ret)
        integer(int64),intent(in):: a(:,:),md
        integer(int64),value:: e
        integer(int64), allocatable:: ma(:,:), ret(:,:)
        integer(int32):: i

        allocate(ma, source=a)
        allocate(ret, mold=a)
        ret(:,:) = 0
        do i=1,size(ret(:,1))
            ret(i,i) = 1
        end do
        do while(e>0)
            if (btest(e,0)) then
                ret = matmul_mod(ret, ma, md)
            end if
            e = shiftr(e,1)
            ma = matmul_mod(ma,ma, md)
        end do
    end function
end module


! cholesky_d.f -*-f90-*-
! Using Cholesky decomposition, cholesky_d.f solve a linear equation Ax=b,
! where A is a n by n positive definite real symmetric matrix, x and b are
! real*8 vectors length n.
!
! Time-stamp: <2015-06-25 18:05:47 takeshi>
! Author: Takeshi NISHIMATSU
! Licence: GPLv3
!
! [1] A = G tG, where G is a lower triangular matrix and tG is transpose of G.
! [2] Solve  Gy=b with  forward elimination
! [3] Solve tGx=y with backward elimination
!
! Reference: Taketomo MITSUI: Solvers for linear equations [in Japanese]
!            http://www2.math.human.nagoya-u.ac.jp/~mitsui/syllabi/sis/info_math4_chap2.pdf
!
! Comment:   This Cholesky decomposition is used in src/elastic.F and
!            src/optimize-inho-strain.F of feram http://loto.sourceforge.net/feram/ .
!!
      subroutine solve(nn,n, G, b)
          implicit none
          integer,    intent(in)    :: n,nn
          real*8,     intent(in)    :: G(nn,nn)
          real*8,     intent(out)   :: b(nn)
          real*8 :: tmp
          integer    :: i,j

      ! [2]
      do i = 1, n
         tmp = 0.0d0
         do j = 1, i-1
            tmp = tmp + G(i,j)*b(j)
         end do
         b(i) = (b(i)-tmp)/G(i,i)
      end do

      ! [3]
      do i = n, 1, -1
         tmp = 0.0d0
         do j = i+1, n
            tmp = tmp + b(j)*G(j,i)
         end do
         b(i) = (b(i)-tmp)/G(i,i)
      end do

      end subroutine