!##############################################################################
! PROGRAM newton
!
! ## The Newton method to find the root of a function
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
program newton

    implicit none
    integer :: iter
    real*8 :: xold, x, f, fprime

    ! set initial guess
    xold = 0.05d0

    ! start iteration process
    do iter = 1, 200

        ! calculate function value
        f = 0.5d0*xold**(-0.2d0)+0.5d0*xold**(-0.5d0)-2d0

        ! calculate derivative
        fprime = -0.1d0*xold**(-1.2d0)-0.25d0*xold**(-1.5d0)

        ! calculate new value
        x = xold - f/fprime

        write(*,'(i4,f12.7)')iter, abs(x-xold)

        ! check for convergence
        if(abs(x-xold) < 1d-6)then
            write(*,'(/a,f12.7,a,f12.9)')' x = ',x,'    f = ',f
            stop
        endif

        ! copy old value
        xold = x
    enddo

    write(*,'(a)')'Error: no convergence'

end program


! compute pi using the sum in Leibniz formula
program sum
    implicit none
    real :: s
    integer :: i,N

    N = 100000
    s = 0.

    do i = 1,N
        if (mod(i, 2) == 0) then
            s = s - 1. / (2. * i - 1.)
        else
            s = s + 1. / (2. * i - 1.)
        end if
    end do

    write (*,*) s * 4.

end program


program exo4_5
    !  A program which reads an integer value limit and print the first limit prime numbers, by any method.
    implicit none
    integer :: limit, limit_counter = 0, number = 2

    write(6, '(a)', advance='no') "Number of primes: "
    read(5, '(i3)') limit
    if ( limit .eq. 0 ) stop '`limit` must be at least 1'
    write(6, '(a, i3, a)') 'The first ', limit, ' prime number(s) are: '

    do
        if ( is_prime(number) .eqv. .true. ) then
            limit_counter = limit_counter + 1
            write(6, '(i5, a)', advance='no') number, ' '
        end if

        if ( limit_counter .eq. limit ) then
            write(6, '(a)') ' '
            exit
        end if

        number = number + 1
    end do

contains

    logical function is_prime(n)
        integer, intent(in) :: n
        integer             :: iter_i
        is_prime  = .true.
        do iter_i = 2, int( sqrt( real(n) ) )
            if ( modulo(n, iter_i) .eq. 0 ) then
                is_prime  = .false.
                exit
            end if
        end do
    end function is_prime

end program exo4_5


! Exercise 2, p. 68
!
! Calculating the temperature due to cold front passage

program ex_2

    use iso_fortran_env, only: real32, int32, output_unit

    implicit none

    real(real32), parameter :: temp1 = 12.  ! temperature in Atlanta (°C)
    real(real32), parameter :: temp2 = 24.  ! temperature in Miami (°C)

    real(real32), parameter :: dx = 960.    ! distance between Atlanta & Miami (km)
    real(real32), parameter :: c = 20.      ! speed in km/h

    real(real32), parameter :: dt = 1.      ! time increment (h)

    integer(int32) :: i

    ! update temperature in Miami
    time_loop: do i = 6, 48, 6
        ! print result to screen
        write(output_unit, *) "Temperature after", i*dt, " hours is" , update_temp(temp1, temp2, c, dx, i*dt), "degrees."
    end do time_loop

    contains

        real(real32) pure function update_temp(temp1, temp2, c, dx, dt)
            real(real32), intent(in) :: temp1, temp2, c, dx, dt

            update_temp = temp2 - c * (temp2 - temp1) / dx * dt
        end function update_temp

end program ex_2


subroutine mg_residual(phi, ap, aw, ae, as, an, b, f, nx, ny, xi, xf, res)
use kind_parameters
implicit none

integer, intent(in):: nx, ny, xi, xf
real(kind=dp), intent(in), dimension(nx,xi-1:xf+1):: phi, ap, b, aw, ae, as, an, f
real(kind=dp), intent(out), dimension(nx,xi-1:xf+1):: res
!real(kind=dp), dimension(nx), intent(in):: dx
!real(kind=dp), dimension(ny), intent(in):: dy
integer:: i, j

! Calculate the residual r = f - Au, where u is the guessed value
! Input
! u      Matrix for variables
! f      Right Hand Side
! hx     grid spacing in x direction
! hy     grid spacing in y direction
!
! Output
! r      Residual

! Author: Pratanu Roy
! History:
! First Written: July 20, 2012
! Modified: Feb 11, 2013

do j = xi,xf

    do i = 2,nx-1

        !res(i,j) = 1.0/(dx(i)*dy(j))*(ap(i,j)*phi(i,j) - (aw(i,j)*phi(i-1,j) + ae(i,j)*phi(i+1,j) + as(i,j)*phi(i,j-1) + an(i,j)*phi(i,j+1)) - b(i,j)*dx(i)*dy(j) - f(i,j)*dx(i)*dy(j))
        res(i,j) = ap(i,j)*phi(i,j) - (aw(i,j)*phi(i-1,j) + ae(i,j)*phi(i+1,j) + as(i,j)*phi(i,j-1) + an(i,j)*phi(i,j+1)) - b(i,j)- f(i,j)
        !res(i,j) = 1.0/(dx(i)*dy(j))*(ap(i,j)*phi(i,j) - (aw(i,j)*phi(i-1,j) + ae(i,j)*phi(i+1,j) + as(i,j)*phi(i,j-1) + an(i,j)*phi(i,j+1)) - b(i,j)*dx(i)*dy(j) - f(i,j)*dx(i)*dy(j))

    end do

end do

call exchange_data(res, nx, xi, xf)

end subroutine


program jacobi
  use tools

  implicit none
  integer, parameter :: dim = 3 ! matirx dimension
  real(dp), parameter :: eps = 0.5e-4
  real(dp), dimension(dim, dim) :: a
  real(dp), dimension(dim, 2) :: x
  real(dp), dimension(dim) :: b

  real(dp) :: error
  integer :: i, itn

  ! the A,B matrix
  ! data(a(1, i), i=1, 4)/10.0, -2.0, -1.0, -1.0/
  ! data(a(2, i), i=1, 4)/-2.0, 10.0, -1.0, -1.0/
  ! data(a(3, i), i=1, 4)/-1.0, -1.0, 10.0, -2.0/
  ! data(a(4, i), i=1, 4)/-1.0, -1.0, -2.0, 10.0/
  ! data(b(i), i=1, 4)/3.0, 15.0, 27.0, -9.0/

  ! data(a(1, i), i=1, 3)/9.0, 2.0, 4.0/
  ! data(a(2, i), i=1, 3)/1.0, 10.0, 4.0/
  ! data(a(3, i), i=1, 3)/2.0, -4.0, 10.0/
  ! data(b(i), i=1, 3)/20, 6, -15/

  ! data(a(1, i), i=1, 3)/4.0, -1.0, -1.0/
  ! data(a(2, i), i=1, 3)/-2.0, 6.0, 1.0/
  ! data(a(3, i), i=1, 3)/-1.0, 1.0, 7.0/
  ! data(b(i), i=1, 3)/3.0, 9.0, -6.0/

  data(a(1, i), i=1, 3)/6.0, 1.0, 1.0/
  data(a(2, i), i=1, 3)/1.0, 4.0, -1.0/
  data(a(3, i), i=1, 3)/1.0, -1.0, 5.0/
  data(b(i), i=1, 3)/20.0, 6.0, 7.0/

  call dominance(dim, a) ! to check if it is strictly dominant

  print *, ''
  print *, 'table:'
  write (*, form_header6) 'itn', 'x1', 'x2', 'x3', 'x4', 'error'
  write (*, line6) '-------', '-------', '-------', '-------', '-------', '---------'

  x(:, 1) = 1.0
  itn = 0

  call jac(dim, a, x, b, error, itn)

  do while (error >= eps)
    x(:, 1) = x(:, 2)
    itn = itn + 1
    call jac(dim, a, x, b, error, itn)
  end do

  print *, ''
  print *, 'result:'
  write (*, form_result1rj) (x(i, 2), '-- value of x', i, i=1, dim)
end program jacobi


MODULE LagrangePolynomialsModule

  USE KindModule, ONLY: &
    DP, Zero, One

  IMPLICIT NONE
  PRIVATE

  PUBLIC :: LagrangeP
  PUBLIC :: dLagrangeP

CONTAINS

  PURE REAL(DP) FUNCTION LagrangeP( x, i, xx, nn )

    INTEGER,  INTENT(in) :: i, nn
    REAL(DP), INTENT(in) :: x, xx(nn)

    INTEGER :: j

    LagrangeP = One
    DO j = 1, nn
      IF( j == i ) CYCLE
      LagrangeP = LagrangeP * ( x - xx(j) ) / ( xx(i) - xx(j) )
    END DO

    RETURN
  END FUNCTION LagrangeP

  PURE REAL(DP) FUNCTION dLagrangeP( x, i, xx, nn )

    INTEGER,  INTENT(in) :: i, nn
    REAL(DP), INTENT(in) :: x, xx(nn)

    INTEGER  :: j, k
    REAL(DP) :: Denominator, Numerator

    Denominator = One
    DO j = 1, nn
      IF( j == i ) CYCLE
      Denominator = Denominator * ( xx(i) - xx(j) )
    END DO

    dLagrangeP = Zero
    DO j = 1, nn
      IF( j == i ) CYCLE
      Numerator = One
      DO k = 1, nn
        IF( k == i .OR. k == j ) CYCLE
        Numerator = Numerator * ( x - xx(k) )
      END DO
      dLagrangeP = dLagrangeP + Numerator / Denominator
    END DO

    RETURN
  END FUNCTION dLagrangeP

END MODULE LagrangePolynomialsModule


module tools
  use types
  ! ----------------------------------------------------------------
  ! tools:
  !   This module contains all the functions and subroutines
  ! author:
  !   Exam-roll -- 20419PHY083
  ! env details:
  !   compiler -- gfortran v10.2.0
  !   OS       -- macOS 12.0 x86_64
  !   Kernel   -- Darwin 21.0.0
  ! Note:
  !   - depends on the module "types"
  ! ----------------------------------------------------------------
  implicit none

contains
  function fn(x) result(z)
    ! ----------------------------------------------------------------
    ! Single variable function:
    !   function with one variable that needs to be calculated
    ! input:
    !   x -- input of the function
    ! output:
    !   z -- output of the function f(x)
    ! ----------------------------------------------------------------
    implicit none
    real(dp), intent(in) :: x
    real(dp) :: z

    z = 2.0*x**3.0 - 3.0*x**2.0 + 4.0*x - 5.0
    ! z = 0.5*exp(-((1 + x)/2.0)**2.0)
    ! z = 1/(x + 2)
  end function fn

  function f(x, y) result(z)
    ! ----------------------------------------------------------------
    ! Two variable function:
    !   function with two variables that needs to be calculated
    ! inputs:
    !   x,y -- inputs of the function
    ! output:
    !   z   -- output of the function f(x,y)
    ! ----------------------------------------------------------------
    implicit none
    real(dp), intent(in) :: x, y
    real(dp) :: z

    ! z = exp(x) + y
    z = -x*y
    ! z = sqrt(1 - x**2.0)
  end function f

  subroutine oela(x0, y0, x_point, h)
    ! ----------------------------------------------------------------
    ! Euler method:
    !   Finds the value of y at a given x by using a picewise linear
    !   approximation of the solution
    ! inputs:
    !   h         -- interval size (keep it small for better result)
    !   x0        -- initial value of x (also used as output)
    !   y0        -- initial value of y (also used as output)
    !   x_point   -- the value of x at which y (f(x)) is to be calculated
    ! internals:
    !   x_new     -- new value of x's calculated
    !   y_new     -- new value of y's calculated
    !   k1        -- slope
    ! outputs:
    !   y0, x0    -- values of the required y at given x
    ! ----------------------------------------------------------------
    implicit none
    real(dp), intent(in) :: x_point, h
    real(dp) :: x0, y0
    real(dp) :: k1, x_new, y_new
    integer :: itn

    x_new = x0
    y_new = y0
    itn = 0

    do while (x_new <= x_point)
      ! displaying the values
      write (*, form_table3) itn, x_new, y_new
      x0 = x_new
      y0 = y_new

      ! valus of slope
      k1 = f(x_new, y_new)
      ! calculating the y
      y_new = y_new + h*k1

      ! preparing for the next value
      x_new = x_new + h
      itn = itn + 1
    end do
  end subroutine oela

  subroutine mod_oela(x0, y0, x_point, h)
    ! ----------------------------------------------------------------
    ! Modified Euler method:
    !   Finds the value of y at a given x also known as Heun's method
    ! inputs:
    !   h         -- interval size (keep it small for better result)
    !   x0        -- initial value of x (also used as output)
    !   y0        -- initial value of y (also used as output)
    !   x_point   -- the value of x at which y (f(x)) is to be calculated
    ! internals:
    !   x_new     -- new value of x's calculated
    !   y_new     -- new value of y's calculated
    !   k1, k2    -- slope
    ! outputs:
    !   y0, x0    -- values of the required y at given x
    ! ----------------------------------------------------------------
    implicit none
    real(dp), intent(in) :: h, x_point
    real(dp) :: x0, y0
    real(dp) :: k1, k2, k, x_new, y_new
    integer :: itn

    x_new = x0
    y_new = y0
    itn = 0

    do while (x_new <= x_point)
      ! displaying the values
      write (*, form_table3) itn, x_new, y_new
      x0 = x_new
      y0 = y_new

      ! values of slope
      k1 = f(x_new, y_new)
      k2 = f(x_new + h, y_new + h*k1)

      ! weighted average of the slopes
      k = (k1 + k2)/2.0

      ! calculating the y
      y_new = y_new + h*k

      ! preparing for the next value
      x_new = x_new + h
      itn = itn + 1
    end do
  end subroutine mod_oela

  subroutine g_quad(k, a, b, int_val)
    ! ----------------------------------------------------------------
    ! Gaussian quadrature method:
    !   Integrates a given function by fitting a polynomial at unequal
    !   intervals whose abscissa and weights are calculated using the
    !   zeros of the legendre polynomial and Newton's method.
    ! inputs:
    !   k         -- number of points needed
    !   x()       -- the arrays of x's
    !   y()       -- the arrays of corresponding y's (f(x)'s)
    !   x_point   -- the value of x at which f'(x) is to be calculated
    ! internal:
    !   h         -- class height
    !   loc       -- determines the position of x_point on the table
    !                and gets the respective index for calculation
    !   y         -- value of the integral before scaling
    ! output:
    !   int_val   -- the result of the derivation after scaling
    ! Note:
    !   - used function fn() because only 1 variable
    !   - used subroutine absc_wght() for abscissa and weights
    ! ----------------------------------------------------------------
    implicit none
    integer, intent(in) :: k
    integer, intent(in) :: a, b
    real(dp), intent(out) :: int_val

    real(dp), dimension(k) :: x, w
    real(dp) :: fun, y, p, q
    integer :: i

    call absc_wght(k, x, w) ! calculating the weighting factors

    ! printing the above weighting factors
    write (*, form_header2) 'abscissa', 'weights'
    write (*, line2) '--------', '--------'
    do i = 1, k
      write (*, form_table2) x(i), w(i)
    end do

    ! main integration
    y = 0.0
    p = (a + b)/2.0; q = (b - a)/2.0

    ! loop to calculate the values for each weighted factor
    do i = 1, k
      fun = fn(p + q*x(i))
      y = y + w(i)*fun
    end do

    int_val = q*y ! final result
  end subroutine g_quad

  subroutine absc_wght(points, abscissa, weights)
    ! ----------------------------------------------------------------
    ! Gaussian quadrature Weighting Factors:
    !   calculate the abscissa and weights  for the gaussian quadrature
    !   method {g_quad()} using the zeros of the legendre polynomial
    ! inputs:
    !   points    -- number of data points
    !   abscissa  -- the abscissa
    !   weights   -- the weights
    ! internals:
    !   p0        -- Pn coefficient of the legendre polynomial
    !   p1        -- Pn-1 coefficient of the legendre polynomial
    !   p2        -- Pn-2 coefficient of the legendre polynomial
    !   m         -- finds the mid-point
    !   x         -- initial guess of the abscissa which is further refined
    !               using the Newton-rhapson method
    !   p0_dash   -- the derivative of the legendre polynomial
    ! Note:
    !   - Newton's method is used to refine the value of abscissa (x)
    !   - since the weighted factors are symmetric we can break it into half
    !     and calculate only one half and then set the other half
    ! ----------------------------------------------------------------
    implicit none
    integer, intent(in) :: points
    real(dp), dimension(points), intent(out) :: abscissa, weights

    real(dp), parameter :: eps = 1.0e-15
    integer :: i, j, m
    real(dp) :: p0, p1, p2, p0_dash, x, x_old

    if (mod(points, 2) == 0) then ! finding the mid-point
      m = points/2
    else
      m = (points + 1)/2
    end if

    ! loop to calculate the zeros of legendre polynomial
    do i = 1, m
      x = cos(pi*(i - 0.25)/(points + 0.5)) ! initial guess of x

      do while (abs(x - x_old) > eps)
        p0 = 1.0
        p1 = x

        ! loop to calculate the legendre polynomial
        do j = 1, points
          p2 = p1
          p1 = p0
          p0 = ((2.0*j - 1.0)*x*p1 - (j - 1.0)*p2)/j ! legendre polynomial
        end do

        p0_dash = points*(x*p0 - p1)/(x**2.0 - 1.0) ! legendre polynomial derivative

        x_old = x
        x = x_old - p0/p0_dash ! newton's method for refining x

        ! arranging the abscissa
        abscissa(i) = -x ! the -abscissa's
        abscissa(points + 1 - i) = x ! the +abscissa's

        ! arranging the weights
        weights(i) = (2.0*(1 - x**2.0))/(points*p1)**2.0 ! the weights for -abscissa
        weights(points + 1 - i) = weights(i) ! the weights for +abscissa
      end do
    end do
  end subroutine absc_wght

  subroutine rungkut_2(x0, y0, x_point, h)
    ! ----------------------------------------------------------------
    ! Runge-Kutte two point method:
    !   Finds the value of y at a given x also known as Polygon method
    ! inputs:
    !   h         -- interval size (keep it small for better result)
    !   x0        -- initial value of x (also used as output)
    !   y0        -- initial value of y (also used as output)
    !   x_point   -- the value of x at which y (f(x)) is to be calculated
    ! internals:
    !   x_new     -- new value of x's calculated
    !   y_new     -- new value of y's calculated
    !   k1, k2    -- slopes
    ! outputs:
    !   y0, x0    -- values of the required y at given x
    ! ----------------------------------------------------------------
    implicit none
    real(dp), intent(in) :: h, x_point
    real(dp) :: x0, y0
    real(dp) :: k1, k2, x_new, y_new
    integer :: itn

    x_new = x0
    y_new = y0
    itn = 0

    do while (x_new <= x_point)
      ! displaying the values
      write (*, form_table3) itn, x_new, y_new
      x0 = x_new
      y0 = y_new
      ! value of slopes
      k1 = f(x_new, y_new)
      k2 = f(x_new + h/2.0, y_new + k1*h/2.0)
      ! calculating the y
      y_new = y_new + h*k2
      ! preparing for next values
      x_new = x_new + h
      itn = itn + 1
    end do
  end subroutine rungkut_2

  subroutine rungkut_4(x0, y0, x_point, h)
    ! ----------------------------------------------------------------
    ! Runge-Kutte two point method:
    !   Finds the value of y at a given x also known as Polygon method
    ! inputs:
    !   h         -- interval size (keep it small for better result)
    !   x0        -- initial value of x (also used as output)
    !   y0        -- initial value of y (also used as output)
    !   x_point   -- the value of x at which y (f(x)) is to be calculated
    ! internals:
    !   x_new     -- new value of x's calculated
    !   y_new     -- new value of y's calculated
    !   k1,k2,k3,k4  -- slopes
    ! outputs:
    !   y0, x0    -- values of the required y at given x
    ! ----------------------------------------------------------------
    implicit none
    real(dp), intent(in) :: x_point, h
    real(dp) :: x0, y0
    real(dp) :: k1, k2, k3, k4, k, x_new, y_new
    integer :: itn

    x_new = x0
    y_new = y0
    itn = 0

    do while (x_new <= x_point)
      ! displaying the values
      write (*, form_table3) itn, x_new, y_new
      x0 = x_new
      y0 = y_new

      ! values of slopes
      k1 = f(x_new, y_new)
      k2 = f(x_new + h/2.0, y_new + k1*h/2.0)
      k3 = f(x_new + h/2.0, y_new + k2*h/2.0)
      k4 = f(x_new + h, y_new + k3*h)

      ! weighted average of the slopes
      k = (k1 + 2.0*(k2 + k3) + k4)/6.0

      ! calculating the y
      y_new = y_new + k*h

      ! preparingg for the next value
      x_new = x_new + h
      itn = itn + 1
    end do
  end subroutine rungkut_4

  subroutine neum_diff(n, x, y, x_point, poly, deriv)
    ! ----------------------------------------------------------------
    ! Newton's differentiation:
    !   Calculates the differentiation of y at a given x using newton's
    !   interpolation polynomial and the difference table calculated
    !   by the subroutine newinter()
    ! inputs:
    !   n         -- number of points for interpolation
    !   x()       -- the arrays of x's
    !   y()       -- the arrays of corresponding y's (f(x)'s)
    !   x_point   -- the value of x at which f'(x) is to be calculated
    ! internal:
    !   m         -- the mid-point of the table of n points
    !   h         -- class height
    !   loc       -- determines the position of x_point on the table
    !               and gets the respective index for calculation
    ! output:
    !   deriv     -- the result of the derivation
    !   poly      -- the used interpolation polynomial
    ! Note:
    !   - used the subroutine newinter
    !   - used forward difference table and modified the formula a bit
    !     to calculate the backward differentiation.
    ! ----------------------------------------------------------------
    implicit none
    integer, intent(in) :: n
    real(dp), dimension(n), intent(in) :: x, y
    real(dp), intent(in) :: x_point
    real(dp), intent(out) :: deriv
    character(len=8), intent(out) :: poly

    real(dp), dimension(n, n) :: del_f
    real(dp) :: h, sum_1, sum_2, x_sum
    integer :: a, b, m, loc

    ! condition to get the mid-point of the data points
    if (mod(n, 2) == 0) then
      m = n/2
    else
      m = (n + 1)/2
    end if

    loc = minloc(x, mask=(x >= x_point), dim=1) ! position of an x in the array

    ! check if x_point is outside the given data points
    if ((loc == 0) .or. (loc == n + 1)) then
      stop 'your {x_point} is outside the given data points'
    end if

    call newinter(n, x, y, del_f) ! calculating the difference table

    ! conditon for forward and backward differentiation
    if (x_point <= x(m)) then ! forward case
      poly = 'forward'
      if (loc == 1) then
        a = loc
        b = a + 1
      else
        a = loc
        b = a - 1
      end if

      ! calculation of the derivative
      h = abs(x(a) - x(b))
      x_sum = ((x_point - x(b)) + (x_point - x(a)))
      sum_1 = del_f(b, 1)/h
      sum_2 = del_f(b, 2)/(2.0*h*h)

    else if (x_point > x(m)) then ! backward case
      poly = 'backward'
      if (loc == n) then
        a = loc
        b = a - 1
      else
        a = loc
        b = a + 1
      end if

      ! calculation of the derivative
      h = abs(x(a) - x(b))
      x_sum = ((x_point - x(b)) + (x_point - x(a)))
      sum_1 = del_f(b, 1)/h
      sum_2 = del_f(b - 1, 2)/(2.0*h*h)
    end if

    deriv = sum_1 + sum_2*x_sum ! final result
  end subroutine neum_diff

  subroutine newinter(n, x, y, del_f)
    ! ----------------------------------------------------------------
    ! Newton's interpolation table:
    !   Calculates the forward differences and gives us the F.D. table
    ! inputs:
    !   n         -- number of points for interpolation
    !   x()       -- the arrays of x's (used just for tabulation)
    !   y()       -- the arrays of corresponding y's (f(x)'s)
    ! output:
    !   del_f(,)  -- the forward difference coefficients
    ! Note:
    !   - This same table is used for backward difference because it is
    !     same as forward difference, just the position is different.
    ! ----------------------------------------------------------------
    implicit none
    integer, intent(in) :: n
    real(dp), dimension(n), intent(in) :: y, x
    real(dp), dimension(n, n), intent(out) :: del_f

    real(dp), dimension(n, n) :: del_y
    integer :: i, j, p

    ! loop to calculate the differences
    do j = 1, n
      do i = 1, n - j
        if (j == 1) then ! calculating the 1st difference column
          del_y(i, 1) = y(i + 1) - y(i)
        else ! calculate the other coloumns
          del_y(i, j) = del_y(i + 1, j - 1) - del_y(i, j - 1)
        end if
      end do
    end do

    del_f = del_y

    ! printing the difference table
    print *, 'the difference table:'
    write (*, form_header3n) 'x', 'y', "del_f's"
    write (*, line3n) '------', '------', '-------------------------'
    do i = 1, n
      write (*, form_tableip) x(i), y(i), (del_f(i, p), p=1, n - i)
    end do
  end subroutine newinter

  subroutine jac(n, a, x, b, err, itn)
    ! ----------------------------------------------------------------
    ! Jacobi method:
    !   calculate the single value of x,y and z using the iterative
    !   method of simultaneous displacememnts
    ! inputs:
    !   n         -- number of data points (dimension of the matrix)
    !   a         -- matrix of the coefficients A
    !   b         -- matrix of the constants B
    !   x(:,1)    -- initial x1,x2,x3
    !   itn       -- iteration number
    ! internals:
    !   sum_ax()  -- sum of the off diagonal terms of A
    !   aberror   -- difference of the values of old x's with new x's
    ! output:
    !   err       -- the eucledian norm of "error"
    !   x(:,2)    -- final x1,x2,x3
    ! Note:
    !   - use the subroutine dominance() to check if the solution will
    !     converge or not
    ! ----------------------------------------------------------------
    implicit none
    integer, intent(in) :: n, itn
    real(dp), dimension(n), intent(in) :: b
    real(dp), dimension(n, n), intent(in) :: a
    real(dp), intent(out) :: err
    real(dp), dimension(n, 2) :: x

    real(dp), dimension(n) :: sum_ax, aberror
    integer :: p, q

    !loop to calculate x1,x2,x3
    do p = 1, n
      sum_ax(p) = 0.0
      do q = 1, n
        if (q /= p) then
          sum_ax(p) = sum_ax(p) + a(p, q)*x(q, 1)
        end if
      end do
      x(p, 2) = (b(p) - sum_ax(p))/a(p, p)
    end do

    ! error calculation
    aberror = x(:, 1) - x(:, 2)
    err = norm2(aberror) ! taking the eucledian norm

    ! printing the values
    write (*, form_table6) itn, (x(p, 2), p=1, n), err
  end subroutine jac

  subroutine dominance(n, a)
    ! ----------------------------------------------------------------
    ! Diagonally dominance checker:
    !   checks if the matrix is strictly diagonally dominant
    ! inputs:
    !   n         -- dimension of the matrix
    !   a         -- matrix of the coefficients A
    ! internals:
    !   row_sum   -- sum of the off diagonal row elements
    ! Note:
    !   - used for the jacobi method equation solver.
    !   - if dominance test failed, need to make the matrix dominant
    ! ----------------------------------------------------------------
    implicit none
    integer, intent(in) :: n
    real(dp), dimension(n, n), intent(in) :: a

    real(dp) :: row_sum
    integer :: p, q

    ! loop to calculate the sum of off diagonal terms
    do p = 1, n
      row_sum = 0.0
      do q = 1, n
        if (q /= p) then
          row_sum = row_sum + abs(a(p, q)) ! off-diag element sum
        end if
      end do

      ! condition for strictly diagonally dominant
      if (abs(a(p, p)) < row_sum) then
        stop "-- !! the matirx is NOT strictly diagonally dominant !! --"
      end if
    end do
  end subroutine dominance

  subroutine monte_pi(sq_points, points_inside, approx_pi)
    ! ----------------------------------------------------------------
    ! Monte Carlo Pi:
    !   Calculates the approximate value of pi using Monte Carlo method
    ! inputs:
    !   sq_points     -- total points inside square including the circle
    !   points_inside -- total points inside the circle
    ! internals:
    !   rand_x, rand_y -- uniform random number in the range [0,1)
    ! ----------------------------------------------------------------
    implicit none
    integer, intent(in) :: sq_points
    integer, intent(out) :: points_inside
    real(dp), intent(out) :: approx_pi

    integer :: i, cr_points
    real(dp) :: x, y, rand_x, rand_y, cr_radi

    call random_seed() ! to maintain the state random_number generator

    do i = 1, sq_points
      ! generating uniform random numbers in the range [0,1)
      call random_number(rand_x)
      call random_number(rand_y)

      ! scaling in the range [a,b]: x = a + (b-a)*x
      x = -1 + 2*rand_x
      y = -1 + 2*rand_y

      cr_radi = x**2.0 + y**2.0 ! radius of the circle

      ! condition to check if the hits were perfect
      if (cr_radi <= 1.0) then
        cr_points = cr_points + 1
      end if
    end do

    ! final result
    points_inside = cr_points
    approx_pi = 4.0*(float(cr_points)/float(sq_points))
  end subroutine monte_pi

  subroutine monte_int(a, b, s_size, approx_int)
    ! ----------------------------------------------------------------
    ! Monte Carlo Integration:
    !   Calculates the approximate value of integral using MC method
    ! inputs:
    !   a,b           -- lower and upper limit
    !   s_size        -- size of the sample
    ! internals:
    !   rand_x, rand_y -- uniform random number in the range [0,1)
    !   sum_f         -- sum of the function from 1 to sample size
    ! output:
    !   approx_int    -- the approximate value of the integral
    ! ----------------------------------------------------------------
    implicit none
    integer, intent(in) :: a, b, s_size
    real(dp), intent(out) :: approx_int

    real(dp) :: x, y, sum_f, rand_x, rand_y
    integer :: i

    call random_seed() ! to maintain the state random_number generator

    ! loop to calculate the integral
    do i = 1, s_size
      ! generating uniform random numbers in the range [0,1)
      call random_number(rand_x)
      call random_number(rand_y)

      ! scaling in the range [a,b]: x = a + (b-a)*x
      x = a + rand_x*(b - a)
      y = a + rand_y*(b - a)

      sum_f = sum_f + f(x, y) ! summing all the values of the given function
    end do

    approx_int = float(b - a)*(sum_f/float(s_size)) ! final result of integral
  end subroutine monte_int

  subroutine garphmonte_pi(sq_points, points_inside, approx_pi)
    ! ----------------------------------------------------------------
    ! Monte Carlo Pi:
    !   Calculates the approximate value of pi using Monte Carlo method
    ! inputs:
    !   sq_points     -- total points inside square including the circle
    !   points_inside -- total points inside the circle
    ! internals:
    !   rand_x, rand_y -- uniform random number in the range [0,1)
    ! Note:
    !   - this subroutine can be used to get the points in a output file
    !     and can be plotted using a graphing tool
    ! ----------------------------------------------------------------
    implicit none
    integer, intent(in) :: sq_points
    integer, intent(out) :: points_inside
    real(dp), intent(out) :: approx_pi

    integer :: i, cr_points
    real(dp) :: cr_radi
    real(dp) :: x, y, rand_x, rand_y

    call random_seed() ! to maintain the state random_number generator

    open (1, file='values_inside.dat')
    open (2, file='values_outside.dat')

    do i = 1, sq_points
      ! generating uniform random numbers in the range [0,1)
      call random_number(rand_x)
      call random_number(rand_y)

      ! scaling in the range [a,b]: x = a + (b-a)*x
      x = -1 + 2*rand_x
      y = -1 + 2*rand_y

      cr_radi = x**2.0 + y**2.0 ! radius of the circle

      ! condition to check if the hits were perfect
      if (cr_radi <= 1.0) then
        cr_points = cr_points + 1
        write (1, "(2f15.5)") x, y
      else
        write (2, "(2f15.5)") x, y
      end if
    end do

    close (1); close (2)

    ! final result
    points_inside = cr_points
    approx_pi = 4.0*(float(cr_points)/float(sq_points))
  end subroutine garphmonte_pi

end module tools


PROGRAM  question4
    IMPLICIT NONE

    INTEGER:: i, n
    REAL, DIMENSION(:), ALLOCATABLE:: x
    REAL:: sum = 0.0, mean, variance

    WRITE(*, *) "Enter dimention of the array"
    READ(*, *) n
    ALLOCATE(x(n))
    WRITE(*, 10) n
    10 FORMAT(/,"Enter ", i0, " real number for this array")
    READ(*, *) (x(i), i = 1, n)

    DO i = 1, n
        sum = sum + x(i)
    ENDDO

    mean = sum/n
    sum = 0.0
    DO i = 1, n
        sum = sum + (x(i) - mean)**2
    ENDDO
    variance = sum/(n-1)

    WRITE(*, 11) mean, variance
    11 FORMAT(/,"mean of data = ", f0.3/, "variance of the data = ", f0.3/)

END


module forlab_math

    use stdlib_kinds, only: sp, dp, qp, int8, int16, int32, int64
    use stdlib_optval, only: optval
    implicit none
    private

    public :: angle
    public :: cosd, sind, tand
    public :: acosd, asind, atand
    public :: arange, signum

    public :: is_close, all_close
    public :: cross, operator(.c.)

    interface acosd
        !! degree circular functions
        pure elemental module function acosd_sp(x)
            real(sp), intent(in)::x
            real(sp)::acosd_sp
        end function acosd_sp
        pure elemental module function acosd_dp(x)
            real(dp), intent(in)::x
            real(dp)::acosd_dp
        end function acosd_dp
    end interface acosd
    interface asind
        !! degree circular functions
        pure elemental module function asind_sp(x)
            real(sp), intent(in)::x
            real(sp)::asind_sp
        end function asind_sp
        pure elemental module function asind_dp(x)
            real(dp), intent(in)::x
            real(dp)::asind_dp
        end function asind_dp
    end interface asind
    interface atand
        !! degree circular functions
        pure elemental module function atand_sp(x)
            real(sp), intent(in)::x
            real(sp)::atand_sp
        end function atand_sp
        pure elemental module function atand_dp(x)
            real(dp), intent(in)::x
            real(dp)::atand_dp
        end function atand_dp
    end interface atand

    interface cosd
        pure elemental module function cosd_sp(x)
            real(sp), intent(in)::x
            real(sp)::cosd_sp
        end function cosd_sp
        pure elemental module function cosd_dp(x)
            real(dp), intent(in)::x
            real(dp)::cosd_dp
        end function cosd_dp
    end interface cosd
    interface sind
        pure elemental module function sind_sp(x)
            real(sp), intent(in)::x
            real(sp)::sind_sp
        end function sind_sp
        pure elemental module function sind_dp(x)
            real(dp), intent(in)::x
            real(dp)::sind_dp
        end function sind_dp
    end interface sind
    interface tand
        pure elemental module function tand_sp(x)
            real(sp), intent(in)::x
            real(sp)::tand_sp
        end function tand_sp
        pure elemental module function tand_dp(x)
            real(dp), intent(in)::x
            real(dp)::tand_dp
        end function tand_dp
    end interface tand

    interface angle
        !! Version: experimental
        !!
        !! angle compute the phase angle.
        !!([Interface](../interface/angle.html))
        module procedure :: angle_sp
        pure module function angle_2_sp(x, y) result(angle)
            real(sp), dimension(3), intent(in) :: x, y
            real(sp) :: angle
        end function angle_2_sp
        module procedure :: angle_dp
        pure module function angle_2_dp(x, y) result(angle)
            real(dp), dimension(3), intent(in) :: x, y
            real(dp) :: angle
        end function angle_2_dp
    end interface angle

    !> Version: experimental
    !>
    !> Returns a boolean scalar/array where two scalar/arrays are element-wise equal within a tolerance.
    !> ([Specification](../page/specs/forlab_math.html#is_close))
    interface is_close
        elemental module function is_close_rsp(a, b, rel_tol, abs_tol) result(close)
            real(sp), intent(in) :: a, b
            real(sp), intent(in), optional :: rel_tol, abs_tol
            logical :: close
        end function is_close_rsp
        elemental module function is_close_rdp(a, b, rel_tol, abs_tol) result(close)
            real(dp), intent(in) :: a, b
            real(dp), intent(in), optional :: rel_tol, abs_tol
            logical :: close
        end function is_close_rdp
        elemental module function is_close_csp(a, b, rel_tol, abs_tol) result(close)
            complex(sp), intent(in) :: a, b
            real(sp), intent(in), optional :: rel_tol, abs_tol
            logical :: close
        end function is_close_csp
        elemental module function is_close_cdp(a, b, rel_tol, abs_tol) result(close)
            complex(dp), intent(in) :: a, b
            real(dp), intent(in), optional :: rel_tol, abs_tol
            logical :: close
        end function is_close_cdp
    end interface is_close

    !> Version: experimental
    !>
    !> Returns a boolean scalar where two arrays are element-wise equal within a tolerance.
    !> ([Specification](../page/specs/forlab_math.html#all_close))
    interface all_close
        logical module function all_close_rsp(a, b, rel_tol, abs_tol) result(close)
            real(sp), intent(in) :: a(..), b(..)
            real(sp), intent(in), optional :: rel_tol, abs_tol
        end function all_close_rsp
        logical module function all_close_rdp(a, b, rel_tol, abs_tol) result(close)
            real(dp), intent(in) :: a(..), b(..)
            real(dp), intent(in), optional :: rel_tol, abs_tol
        end function all_close_rdp
        logical module function all_close_csp(a, b, rel_tol, abs_tol) result(close)
            complex(sp), intent(in) :: a(..), b(..)
            real(sp), intent(in), optional :: rel_tol, abs_tol
        end function all_close_csp
        logical module function all_close_cdp(a, b, rel_tol, abs_tol) result(close)
            complex(dp), intent(in) :: a(..), b(..)
            real(dp), intent(in), optional :: rel_tol, abs_tol
        end function all_close_cdp
    end interface all_close

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

    !> Version: experimental
    !>
    !> `signum` returns the sign of variables.
    !> ([Specification](../page/specs/forlab_math.html#signum))
    interface signum
        real(sp) elemental module function signum_rsp(x) result(sign)
            real(sp), intent(in) :: x
        end function signum_rsp
        real(dp) elemental module function signum_rdp(x) result(sign)
            real(dp), intent(in) :: x
        end function signum_rdp
        integer(int8) elemental module function signum_iint8(x) result(sign)
            integer(int8), intent(in) :: x
        end function signum_iint8
        integer(int16) elemental module function signum_iint16(x) result(sign)
            integer(int16), intent(in) :: x
        end function signum_iint16
        integer(int32) elemental module function signum_iint32(x) result(sign)
            integer(int32), intent(in) :: x
        end function signum_iint32
        integer(int64) elemental module function signum_iint64(x) result(sign)
            integer(int64), intent(in) :: x
        end function signum_iint64
        complex(sp) elemental module function signum_csp(x) result(sign)
            complex(sp), intent(in) :: x
        end function signum_csp
        complex(dp) elemental module function signum_cdp(x) result(sign)
            complex(dp), intent(in) :: x
        end function signum_cdp
    end interface signum

    interface cross
        pure module function cross_rsp(x, y) result(cross)
            real(sp), intent(in) :: x(3), y(3)
            real(sp) :: cross(3)
        end function cross_rsp
        pure module function cross_rdp(x, y) result(cross)
            real(dp), intent(in) :: x(3), y(3)
            real(dp) :: cross(3)
        end function cross_rdp
        pure module function cross_iint8(x, y) result(cross)
            integer(int8), intent(in) :: x(3), y(3)
            integer(int8) :: cross(3)
        end function cross_iint8
        pure module function cross_iint16(x, y) result(cross)
            integer(int16), intent(in) :: x(3), y(3)
            integer(int16) :: cross(3)
        end function cross_iint16
        pure module function cross_iint32(x, y) result(cross)
            integer(int32), intent(in) :: x(3), y(3)
            integer(int32) :: cross(3)
        end function cross_iint32
        pure module function cross_iint64(x, y) result(cross)
            integer(int64), intent(in) :: x(3), y(3)
            integer(int64) :: cross(3)
        end function cross_iint64
    end interface cross

    interface operator(.c.)
        procedure :: cross_rsp
        procedure :: cross_rdp
        procedure :: cross_iint8
        procedure :: cross_iint16
        procedure :: cross_iint32
        procedure :: cross_iint64
    end interface operator(.c.)

contains

    elemental function angle_sp(value) result(angle)
        real(sp) :: angle
        complex(sp), intent(in) :: value

        angle = aimag(log(value))

    end function angle_sp
    elemental function angle_dp(value) result(angle)
        real(dp) :: angle
        complex(dp), intent(in) :: value

        angle = aimag(log(value))

    end function angle_dp

end module forlab_math


program Simspson_Rule

    implicit none

    real :: a,b,h,s,Integration
    integer :: n,i
    real,parameter :: pi=3.14

    print*,"SIMPSON's 1/3rd RULE"
    print*,"Function : y=5*(x**3)-3*(x**2)+(2*x)+1"

    print*,"Enter lower limit :"
    read*,a

    print*,"Enter upper limit :"
    read*,b

    print*,"Enter number of iterations (it must be even) :"
    read*,n

    h=(b-a)/n
    s=f(a)+f(b)

    do i=1,2,(n-1)
        s=s+4*f(a+i*h)
    end do
    do i=2,2,(n-2)
        s=s+2*f(a+i*h)
    end do

    Integration=(h*s)/3
    print*,"Answer of Integration : ",Integration

end program

function f(x)
    implicit none
    real :: f   ! Dummy Variable
    real :: x   ! Local Variable
!    f=5*x**3-3*x**2+2*x+1
    f=x*sin(x)
end function


module math
  ! Module with some mathematical functions
  implicit none

  public :: newton
  private :: norm, distance_between_points

contains

  function norm(r_in) result(norm_value)
    ! 2-norm of r
    implicit none
    real(8), dimension(3), intent(in) :: r_in
    real(8) :: norm_value
    norm_value = sqrt(sum((r_in)**2.0))
  end function norm

  function distance_between_points(r1,r2) result(r)
    ! distance between two points
    implicit none
    real(8), dimension(3), intent(in) :: r1, r2
    real(8) :: r
    r = norm(r2-r1)
  end function distance_between_points

  function newton(m1,m2,r1,r2) result(f)
    ! Newton's universal law of gravity
    implicit none
    real(8), intent(in) :: m1, m2
    real(8), dimension(3), intent(in) :: r1, r2
    real(8), dimension(3) :: f, r12
    real(8) :: r
    real(8), parameter :: G = 6.67384e-11
    r = distance_between_points(r1,r2)
    r12 = (r2-r1)/r
    f = -G*m1*m2/r**2.0*r12
  end function newton

end module math


! Created by mus on 29/07/2021.
! Derivation of Lagrange polynomials at the GLL points based on results from Funaro 1993 || Check Heiner Igel pg 196
! N: Polynomial order
! primed: derivative of lagrange polynomial matrix, each "k" row is the derivative of "lk(xi)" Lagrange polynomial. Each row is a the value of the derivative at a GLL point
! dummy arguments: dij -> derivation matrix | xi, wi -> GLL points and weights ...
! ... Lxi, Lxj -> Legendre polynomial value at xi and xj | lk -> k-th lagrange polynomial | sum -> summation return for the last derivation sum

subroutine lagrangeprime(N,primed)
    implicit none
    integer, intent(in)                            :: N
    real (kind=8), dimension(N+1,N+1), intent(out) :: primed
    real (kind=8), dimension(N+1,N+1)              :: dij
    real (kind=8), dimension(N+1)                  :: xi, wi
    real (kind=8)                                  :: Lxi, Lxj, sum, lk
    integer                                        :: i,j,k
    real (kind=8), external                        :: legendrep

    call zwgljd(xi,wi,N+1,0.,0.)

    do i=0,N
        do j=0,N
            if (i/=j) then
                Lxi = legendrep(N,xi(i+1))
                Lxj = legendrep(N,xi(j+1))
                dij(i+1,j+1) = (Lxi / Lxj) / (xi(i+1) - xi(j+1))
            elseif (i==j) then
                if (i==0 .and. j==0) then
                    dij(i+1,j+1) = -0.25 * N * (N + 1)
                elseif (i>=1 .and. i<=N-1) then
                    dij(i+1,j+1) = 0
                elseif (i==N) then
                    dij(i+1,j+1) = 0.25 * N *(N + 1)
                endif
            end if
        end do
    end do

    do k=0,N
        do i=0,N
            sum = 0
            do j=0,N
                call lagrangep(N,k,xi(j+1),lk,1)
                sum = sum + dij(i+1,j+1) * lk
            end do
            primed(k+1,i+1) = sum
        end do
    end do
end subroutine lagrangeprime


***********************************************************************
c                    ORBEL_EGET.F
***********************************************************************
*     PURPOSE:  Solves Kepler's eqn.   e is ecc.   m is mean anomaly.
*
*             Input:
*                           e ==> eccentricity anomaly. (real scalar)
*                           m ==> mean anomaly. (real scalar)
*             Returns:
*                  orbel_eget ==>  eccentric anomaly. (real scalar)
*
*     ALGORITHM: Quartic convergence from Danby
*     REMARKS: For results very near roundoff, give it M between
*           0 and 2*pi. One can condition M before calling EGET
*           by calling my double precision function MOD2PI(M).
*           This is not done within the routine to speed it up
*           and because it works fine even for large M.
*     AUTHOR: M. Duncan
*     DATE WRITTEN: May 7, 1992.
*     REVISIONS: May 21, 1992.  Now have it go through EXACTLY two iterations
*                with the premise that it will only be called if
*	         we have an ellipse with e between 0.15 and 0.8
***********************************************************************

	real*8 function orbel_eget(e,m)

      include '../swift.inc'

c...  Inputs Only:
	real*8 e,m

c...  Internals:
	real*8 x,sm,cm,sx,cx
	real*8 es,ec,f,fp,fpp,fppp,dx

c----
c...  Executable code

c Function to solve Kepler's eqn for E (here called
c x) for given e and M. returns value of x.
c MAY 21 : FOR e < 0.18 use ESOLMD for speed and sufficient accuracy
c MAY 21 : FOR e > 0.8 use EHIE - this one may not converge fast enough.

	  call orbel_scget(m,sm,cm)

c  begin with a guess accurate to order ecc**3
	  x = m + e*sm*( 1.d0 + e*( cm + e*( 1.d0 -1.5d0*sm*sm)))

c  Go through one iteration for improved estimate
	  call orbel_scget(x,sx,cx)
	  es = e*sx
	  ec = e*cx
	  f = x - es  - m
	  fp = 1.d0 - ec
	  fpp = es
	  fppp = ec
	  dx = -f/fp
	  dx = -f/(fp + dx*fpp/2.d0)
	  dx = -f/(fp + dx*fpp/2.d0 + dx*dx*fppp/6.d0)
	  orbel_eget = x + dx

c Do another iteration.
c For m between 0 and 2*pi this seems to be enough to
c get near roundoff error for eccentricities between 0 and 0.8

	  x = orbel_eget
	  call orbel_scget(x,sx,cx)
	  es = e*sx
	  ec = e*cx
	  f = x - es  - m
	  fp = 1.d0 - ec
	  fpp = es
	  fppp = ec
	  dx = -f/fp
	  dx = -f/(fp + dx*fpp/2.d0)
	  dx = -f/(fp + dx*fpp/2.d0 + dx*dx*fppp/6.d0)

	  orbel_eget = x + dx

	return
	end  ! orbel_eget
c---------------------------------------------------------------------


! Created by EverLookNeverSee@GitHub on 5/29/20
! For more information see FCS/img/Exercise_03.png

program main
    implicit none
    ! n --> rod length
    ! r --> crank radius
    ! w --> angular Velocity(rpm)
    ! theta --> crank angle
    ! x --> displaceemnt
    ! v --> velocity
    ! declaring variables
    integer :: i,theta, j = 1
    real :: n, r, w, radian_theta
    real, dimension(37) :: x, v
    ! initializing variables
    n = 4; r = 4; w = 2000; theta = 360
    ! making variation of theta
    do i = 0, theta, 10
        ! the argument of trigonometric functions must be in radians
        radian_theta = i * 3.141593 / 180.0
        ! storing results in two arrays
        x(j) = r * (1 + n - cos(radian_theta) - sqrt((n ** 2) - (sin(radian_theta)) ** 2))
        v(j) = (w * r) * (sin(radian_theta) + &
                sin(2 * radian_theta) / 2 * (sqrt(n ** 2 - sin(radian_theta) ** 2)))
        ! increasing counter of arrays blocks
        j = j + 1
    end do
    ! do loop for formated print
    do i = 1, 37, 1
        print "(a2,i2,a3,f15.10,10x,a2,i2,a3,f17.10)", "x(", i, "): ", x(i), "v(", i, "): ", v(i)
    end do
end program main


subroutine fine_to_coarse_vface(r_h, nx, ny, xi_h, xf_h, xi_2h, xf_2h, r_2h)
use kind_parameters
implicit none

integer, intent(in):: nx, ny, xi_h, xf_h, xi_2h, xf_2h
real(kind=dp), intent(in), dimension(nx,xi_h-1:xf_h+1):: r_h
real(kind=dp), intent(out), dimension(nx/2+1,xi_2h-1:xf_2h+1):: r_2h
integer:: i,j
integer:: imax, jmax

! Apply full weighting to get interpolated values from fine to coarse grid
! Input
! r_h   Variable in fine grid
! f     Right Hand Side
! hx, hy     grid spacing
!
! Output
! r_2h     Variable in coarse grid

! Author: Pratanu Roy
! History:
! First Written: July 20, 2012
! Indices Rechecked on Jan 13, 2013

imax = nx/2+1
jmax = (ny+1)/2

do j = xi_2h,xf_2h

    do i = 2,imax-1

        r_2h(i,j) = 1.0d0/2.0d0*(r_h(2*i-2,2*j-1) + r_h(2*i-1,2*j-1))
        !r_2h(i,j) = (r_h(2*i-2,2*j-1) + r_h(2*i-1,2*j-1))

     end do

end do

if (xi_2h .eq. 2) then

do j = 1,1

 do i = 2,imax-1

    r_2h(i,j) = 1.0/2.0*(r_h(2*i-2,2*j-1) + r_h(2*i-1,2*j-1))
    !r_2h(i,j) = (r_h(2*i-2,2*j-1) + r_h(2*i-1,2*j-1))

 end do

end do

else if (xf_2h .eq. jmax-1) then

do j = jmax,jmax

 do i = 2,imax-1

    r_2h(i,j) = 1.0/2.0*(r_h(2*i-2,2*j-1) + r_h(2*i-1,2*j-1))
    !r_2h(i,j) = (r_h(2*i-2,2*j-1) + r_h(2*i-1,2*j-1))

 end do

end do

end if

do j = xi_2h,xf_2h

 do i = 1,1

    r_2h(i,j) = r_h(2*i-1,2*j-1)

 end do

end do

do j = xi_2h,xf_2h

 do i = imax,imax

    r_2h(i,j) = r_h(2*i-2,2*j-1)

 end do

end do

call exchange_data(r_2h, imax, xi_2h, xf_2h)

end subroutine


module tools
  use mpi
  implicit none
contains
  !*****************************************************************************!

   function cross(a, b)
     real(8),dimension(3) :: cross
     real(8),dimension(3),intent(in) :: a, b

     cross(1) = a(2) * b(3) - a(3) * b(2)
     cross(2) = a(3) * b(1) - a(1) * b(3)
     cross(3) = a(1) * b(2) - a(2) * b(1)
   end function cross

   !*****************************************************************************!

   function dot(a, b)
     real(8) :: dot
     real(8),dimension(3),intent(in) :: a, b

     dot = a(1)*b(1) + a(2)*b(2) + a(3)*b(3)

   end function dot

   !*****************************************************************************!

   function dot3d(a, b)
     real(8) :: dot3d
     real(8),dimension(3),intent(in) :: a, b

     dot3d = a(1)*b(1) + a(2)*b(2) + a(3)*b(3)

   end function dot3d

   !*****************************************************************************!

   function norm3d(a)
     real(8) :: norm3d
     real(8),dimension(3),intent(in) :: a

     norm3d = sqrt(a(1)**2 + a(2)**2 + a(3)**2)

   end function norm3d

!*****************************************************************************!
subroutine gaussQuadrature(t,w,npts)
  implicit none
  integer,intent(in) :: npts
  real(8),intent(out) :: t(:),w(:)
  ! allocate(t(1:npts))
  ! allocate(w(1:npts))
  if (npts==1) then
    t(1) = 0.0d0
    w(1) = 2.0d0
  elseif (npts==2) then
    t(1) = -1.0d0/sqrt(3.0d0)
    t(2) = -t(1)
    w(1) = 1.0d0
    w(2) = w(1)
  elseif (npts==3) then
    t(1) = 0.000000000000000d0
    t(2) = 0.774596669241483d0
    t(3) = -t(2)
    w(1) = 0.888888888888889d0
    w(2) = 0.555555555555556d0
    w(3) = w(2)
  elseif (npts==4) then
    t(1) = 0.339981043584856d0
    t(2) = 0.861136311594053d0
    t(3:4) = -t(1:2)
    w(1) = 0.652145154862546d0
    w(2) = 0.347854845137454d0
    w(3:4) = w(1:2)
  elseif (npts==5) then
    t(1) = 0.000000000000000d0
    t(2) = 0.538469310105683d0
    t(3) = 0.906179845938664d0
    t(4:5) = -t(2:3)
    w(1) = 0.568888888888889d0
    w(2) = 0.478628670499366d0
    w(3) = 0.236926885056189d0
    w(4:5) = w(2:3)
  elseif (npts==6) then
    t(1) = 0.238619186083197d0
    t(2) = 0.661209386466265d0
    t(3) = 0.932469514203152d0
    t(4:6) = -t(1:3)
    w(1) = 0.467913934572691d0
    w(2) = 0.360761573048139d0
    w(3) = 0.171324492379170d0
    w(4:6) = w(1:3)
  elseif (npts==7) then
    t(1) = 0.000000000000000d0
    t(2) = 0.405845151377397d0
    t(3) = 0.741531185599394d0
    t(4) = 0.949107912342759d0
    t(5:7) = -t(2:4)
    w(1) = 0.417959183673469d0
    w(2) = 0.381830050505119d0
    w(3) = 0.279705391489277d0
    w(4) = 0.129484966168870d0
    w(5:7) = w(2:4)
  elseif(npts ==8) then
    t(1) = 0.183434642495650d0
    t(2) = 0.525532409916329d0
    t(3) = 0.796666477413627d0
    t(4) = 0.960289856497536d0
    t(5:8) = -t(1:4)
    w(1) = 0.362683783378362d0
    w(2) = 0.313706645877887d0
    w(3) = 0.222381034453374d0
    w(4) = 0.101228536290376d0
    w(5:8) = w(1:4)
  endif

  return

end subroutine gaussQuadrature
!*****************************************************************************!
subroutine gaussQuadratureTriangles(V,wei,nQ)
  implicit none
  integer,intent(in) :: nQ
  real(8),intent(out) :: V(:,:),wei(:)
  if (nQ==3) then
    V(1,:) = (/ 4.0d0, 1.0d0, 1.0d0 /)
    V(2,:) = (/ 1.0d0, 4.0d0, 1.0d0 /)
    V(3,:) = (/ 1.0d0, 1.0d0, 4.0d0 /)
    V = V/6.0d0
    wei =1.0d0/3.0d0
  elseif (nQ==4) then

    V(1,:) = (/0.33333333d0, 0.33333333d0, 0.33333333d0/)
    V(2,:) = (/0.60000000d0, 0.20000000d0, 0.20000000d0/)
    V(3,:) = (/0.20000000d0, 0.60000000d0, 0.20000000d0/)
    V(4,:) = (/0.20000000d0, 0.20000000d0, 0.60000000d0/)
    wei = (/-0.56250000d0,0.52083333d0,0.52083333d0,0.52083333d0/)
  elseif (nQ==6) then

    V(1,:) = (/ 0.10810301d0, 0.44594849d0, 0.44594849d0 /)
    V(2,:) = (/ 0.44594849d0, 0.10810301d0, 0.44594849d0 /)
    V(3,:) = (/ 0.44594849d0, 0.44594849d0, 0.10810301d0 /)
    V(4,:) = (/ 0.81684757d0, 0.09157621d0, 0.09157621d0 /)
    V(5,:) = (/ 0.09157621d0, 0.81684757d0, 0.09157621d0 /)
    V(6,:) = (/ 0.09157621d0, 0.09157621d0, 0.81684757d0 /)

    wei = (/0.22338158d0,0.22338158d0,0.22338158d0,0.10995174d0,0.10995174d0,0.10995174d0/)
  elseif (nQ==7) then

    V(1,:) = (/ 0.33333333d0, 0.33333333d0, 0.33333333d0 /)
    V(2,:) = (/ 0.05971587d0, 0.47014206d0, 0.47014206d0 /)
    V(3,:) = (/ 0.47014206d0, 0.05971587d0, 0.47014206d0 /)
    V(4,:) = (/ 0.47014206d0, 0.47014206d0, 0.05971587d0 /)
    V(5,:) = (/ 0.79742698d0, 0.10128650d0, 0.10128650d0 /)
    V(6,:) = (/ 0.10128650d0, 0.79742698d0, 0.10128650d0 /)
    V(7,:) = (/ 0.10128650d0, 0.10128650d0, 0.79742698d0 /)

    wei = (/0.22500000d0,0.13239415d0,0.13239415d0,0.13239415d0,0.12593918d0,0.12593918d0,0.12593918d0/)
  endif
  return
end subroutine gaussQuadratureTriangles
!*****************************************************************************!
   subroutine divide_work(start,finish,n_size)

     implicit none

     integer :: ierr , n_procs , id , lWork

     integer, intent(out) :: start , finish

     integer, intent(in)  :: n_size

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

     call mpi_comm_size(MPI_COMM_WORLD,N_procs,ierr)

     call mpi_comm_rank(MPI_COMM_WORLD,id,ierr)

     lWork = n_size / n_procs

     start  = 1+id*lWork

     finish = (id+1)*lWork

     if (id == N_procs-1) then

       finish = n_size

     endif

     return

   end subroutine divide_work
end module


module interact_module

    contains
    subroutine interact(a, b, c, ok)
        implicit none

        real, intent(out) :: a, b, c
        logical, intent(out) :: ok
        integer :: io_status = 0

        print *, &
            ' type in the coefficients a, b and c'
        read(*,*,iostat=io_status) a, b, c

        ok = io_status==0
    end subroutine
end module

module solve_module

    contains
    subroutine solve(e, f, g, root1, root2, ifail)
        implicit none

        real, intent(in) :: e, f, g
        real, intent(out) :: root1, root2
        integer, intent(inout) :: ifail
        real :: term, a2

        term = f*f-4.*e*g
        a2 = e*2.
        if (term<0.) then
            ifail = 1
        else
            term = sqrt(term)
            root1 = (-f+term)/a2
            root2 = (-f-term)/a2
        end if
    end subroutine
end module

program ch1901
    ! Roots of a Quadratic Equation
    use interact_module
    use solve_module
    implicit none

    real :: p, q, r, root1, root2
    integer :: ifail = 0
    logical :: ok = .true.

    call interact(p,q,r,ok)
    if (ok) then
        call solve(p,q,r,root1,root2,ifail)
        if (ifail==1) then
            print *, ' complex roots'
            print *, ' calculation abandoned'
        else
            print *, ' roots are ', root1, ' ', root2
        end if
    else
        print *, ' error in data input program ends'
    end if
end program


      subroutine wtan(xr,xi,yr,yi)
*
*     PURPOSE
*        wtan compute the tangent of a complex number
*        y = yr + i yi = tan(x), x = xr + i xi
*
*     CALLING LIST / PARAMETERS
*        subroutine wtan(xr,xi,yr,yi)
*        double precision xr,xi,yr,yi
*
*        xr,xi: real and imaginary parts of the complex number
*        yr,yi: real and imaginary parts of the result
*               yr,yi may have the same memory cases than xr et xi
*
*     ALGORITHM
*        based on the formula :
*
*                         0.5 sin(2 xr) +  i 0.5 sinh(2 xi)
*        tan(xr + i xi) = ---------------------------------
*                             cos(xr)^2  + sinh(xi)^2
*
*        noting  d = cos(xr)^2 + sinh(xi)^2, we have :
*
*                yr = 0.5 * sin(2 * xr) / d       (1)
*
*                yi = 0.5 * sinh(2 * xi) / d      (2)
*
*        to avoid spurious overflows in computing yi with
*        formula (2) (which results in NaN for yi)
*        we use also the following formula :
*
*                yi = sign(xi)   when |xi| > LIM  (3)
*
*        Explanations for (3) :
*
*        we have d = sinh(xi)^2 ( 1 + (cos(xr)/sinh(xi))^2 ),
*        so when :
*
*           (cos(xr)/sinh(xi))^2 < epsm   ( epsm = max relative error
*                                          for coding a real in a f.p.
*                                          number set F(b,p,emin,emax)
*                                             epsm = 0.5 b^(1-p) )
*        which is forced  when :
*
*            1/sinh(xi)^2 < epsm   (4)
*        <=> |xi| > asinh(1/sqrt(epsm)) (= 19.06... in ieee 754 double)
*
*        sinh(xi)^2 is a good approximation for d (relative to the f.p.
*        arithmetic used) and then yr may be approximate with :
*
*         yr = cosh(xi)/sinh(xi)
*            = sign(xi) (1 + exp(-2 |xi|))/(1 - exp(-2|xi|))
*            = sign(xi) (1 + 2 u + 2 u^2 + 2 u^3 + ...)
*
*        with u = exp(-2 |xi|)). Now when :
*
*            2 exp(-2|xi|) < epsm  (2)
*        <=> |xi| > 0.5 * log(2/epsm) (= 18.71... in ieee 754 double)
*
*        sign(xi)  is a good approximation for yr.
*
*        Constraint (1) is stronger than (2) and we take finaly
*
*        LIM = 1 + log(2/sqrt(epsm))
*
*        (log(2/sqrt(epsm)) being very near asinh(1/sqrt(epsm))
*
*     AUTHOR
*        Bruno Pincon <Bruno.Pincon@iecn.u-nancy.fr>
*
      implicit none

*     PARAMETER
      double precision xr, xi, yr, yi

*     LOCAL VAR
      double precision sr, si, d
*     EXTERNAL

      double precision dlamch

      external dlamch

*     STATIC VAR
      logical first

      double precision LIM

      save    first
      data    first /.true./
      save    LIM

      if (first) then
*        epsm is gotten with dlamch('e')
         LIM = 1.d0 + log(2.d0/sqrt(dlamch('e')))
         first = .false.
      endif

*     (0) avoid memory pb ...
      sr = xr
      si = xi

*     (1) go on ....
      d = cos(sr)**2 + sinh(si)**2
      yr= 0.5d0*sin(2.d0*sr)/d
      if (abs(si) .lt. LIM) then
         yi=0.5d0*sinh(2.d0*si)/d
      else
         yi=sign(1.d0,si)
      endif

      end


! Compute the Planck spectrum for a multigroup problem, to serve as
! initial conditions.

module constants_module

  use amrex_fort_module, only : rt => amrex_real

  ! fundamental constants
  real(rt), parameter :: h_planck = 6.62606896e-27_rt  ! erg s
  real(rt), parameter :: k_B = 1.3806504e-16_rt  ! erg / K
  real(rt), parameter :: c_light = 2.99792458e10_rt  ! cm / s
  real(rt), parameter :: ev2erg = 1.602176487e-12_rt ! erg/eV
  real(rt), parameter :: pi = 3.14159265358979323846e0_rt
  real(rt), parameter :: sigma_SB = 5.670400e-5_rt  ! erg/s/cm^2/K^4
  real(rt), parameter :: a_rad = 4.0e0_rt*sigma_SB/c_light

  ! problem parameters

  ! specify the energy groups.  Ultimately we will work in terms of
  ! frequency, but we set the limits in terms of energy.

  ! note: E_min and E_max MUST match the parameters used in CASTRO
  ! to define the group structure.
  integer, parameter :: ngroups_derive = 128          ! number of groups to compute
  real(rt), parameter :: E_min = 0.5e0_rt*ev2erg ! min group energy (erg)
  real(rt), parameter :: E_max = 306e3_rt*ev2erg ! max group energy (erg)

  ! instead of computing the group structure based on the above, read the group
  ! structure in from group_structure.dat
  logical, parameter :: use_group_file = .false.

  ! physical parameters
  real(rt), parameter :: E_rad = 1.e12_rt ! initial radiation energy density
  real(rt), parameter :: T_0 = (E_rad/a_rad)**0.25e0_rt

end module constants_module

function safe_print(x) result (sx)
  implicit none
  real(rt) :: x, sx
  sx = x
  if (x < 1.e-99_rt) sx = 0.e0_rt

  return
end function safe_print

function planck(nu,T) result (B)

  ! the Planck function for a Blackbody (actually, energy density,
  ! B = (4 pi / c) I, where I is the normal Planck function
  !
  ! nu = frequency (Hz)
  ! T  = temperature (K)

  ! see Swesty and Myra (2009), eq. 23, but note that we are working
  ! in Hz here, so we have units of erg / cm^3 / Hz, where they
  ! have units of erg / cm^3 / MeV.  As a result, we have one
  ! less factor of h_planck.
  use constants_module
  implicit none

  real(rt), intent(in) :: nu, T
  real(rt) :: B

  B = (8.e0_rt*pi*h_planck*nu**3/c_light**3)/(exp(h_planck*nu/(k_B*T)) - 1.e0_rt)

  return
end function planck

program analytic

  ! compute the analytic solution to the radiating sphere, as given
  ! by Swesty and Myra (2009), Eq. 76.

  use constants_module

  implicit none

  integer :: ngroups
  real(rt), allocatable :: nu_groups(:), dnu_groups(:), xnu(:)
  real(rt) :: alpha
  real(rt) :: E, F
  real(rt) :: F_radsphere, planck
  real(rt) :: P_simpsonrule
  real(rt) :: safe_print
  integer :: n

  character(len=256) :: header_line
  integer :: ipos

  if (use_group_file) then
     ! open the file
     open(unit=10,file="group_structure.dat")

     ! read in the number of groups
     read(10,fmt='(a256)') header_line
     ipos = index(header_line, "=") + 1
     read (header_line(ipos:),*) ngroups

     allocate (nu_groups(ngroups), dnu_groups(ngroups))

     ! skip the next header line
     read(10,*) header_line

     ! read in the group centers and weights (widths)
     do n = 1, ngroups
        read(10,*) nu_groups(n), dnu_groups(n)
     enddo

  else
     ngroups = ngroups_derive
     allocate(nu_groups(ngroups),dnu_groups(ngroups),xnu(ngroups+1))

     ! try to mimic the way the groups are setup in RadMultiGroup.cpp

     ! do geometrically spaced group BOUNDARIES
     xnu(1) = E_min/h_planck
     alpha = (E_max/E_min)**(1.e0_rt/(ngroups))

     do n = 2, ngroups+1
        xnu(n) = alpha*xnu(n-1)
     enddo

     do n = 1, ngroups
        nu_groups(n) = 0.5e0_rt*(xnu(n) + xnu(n+1))
     enddo

     do n = 1, ngroups
        if (n == 1) then
           dnu_groups(n) = 0.5e0_rt*(nu_groups(2) - nu_groups(1))

        else if (n < ngroups) then
           dnu_groups(n) = 0.5e0_rt*(nu_groups(n+1) - nu_groups(n-1))

        else
           dnu_groups(n) = 0.5e0_rt*(nu_groups(n) - nu_groups(n-1))
        endif

     enddo

  endif

  ! compute the analytic radiating sphere solution for each point
1000 format(1x, i3, 4(1x,g20.10))

  print *, "# group, group center (Hz), ambient BB spectrum x dnu (erg/cm^3)"
  do n = 1, ngroups
     P_simpsonrule = (dnu_groups(n)/6.0e0_rt)* &
          (     planck(xnu(n),T_0) + &
          4.0e0_rt*planck(nu_groups(n),T_0) + &
          planck(xnu(n+1),T_0))

     write(*,1000) n, nu_groups(n), dnu_groups(n), &
          safe_print(planck(nu_groups(n),T_0)*dnu_groups(n))

  enddo

end program analytic


! SYNOPSIS:
!
! # gfortran -o gcd-f gcd.f03
! # ./gcd-f 11 22 33 121
!

program GCD
  implicit none

  integer, allocatable :: ns(:)
  integer :: i, n
  character*20 :: tmpstr

  n = command_argument_count()

  allocate (ns(n)) ! allocate memory for numbers given in command line

  do i = 1, n
    call get_command_argument(i, tmpstr)
    ns(i) = str2int(tmpstr)
  end do

  print *, gcdn(ns)

  deallocate (ns)

! If we declare functions first,
! we have to specify its types within
! the `program' section.
! See http://en.wikibooks.org/wiki/Fortran/Fortran_procedures_and_functions
contains

  pure integer function str2int(s)
    character*(*), intent(in) :: s
    read (s, *) str2int
  end function

  pure recursive integer function gcd2(a, b) result(GCD)
    integer, intent(in) :: a, b
    if (b == 0) then
      GCD = a
    else
      GCD = gcd2(b, mod(a, b))
    end if
  end function gcd2

  pure integer function gcdn(n)
    integer, intent(in) :: n(:) ! n is an array
    integer :: i
    gcdn = n(1)
    do i = 2, size(n)
      gcdn = gcd2(gcdn, n(i))
    end do
  end function

end program


FUNCTION expint_sp(n,x)
    USE mo_kind,            ONLY : i4, sp
    USE mo_nrutil,          ONLY : arth,assert,nrerror
    USE mo_constants,       ONLY : EULER
    USE mo_utils,           ONLY : eq

    IMPLICIT NONE

    INTEGER(i4), INTENT(IN) :: n
    REAL(SP), INTENT(IN) :: x
    REAL(SP) :: expint_sp
    INTEGER(i4), PARAMETER :: MAXIT=100_i4
    REAL(SP), PARAMETER :: EPS=epsilon(x),BIG=huge(x)*EPS
    INTEGER(i4) :: i,nm1
    REAL(SP) :: a,b,c,d,del,fact,h

    call assert(n >= 0_i4, x >= 0.0_sp, (x > 0.0_sp .or. n > 1_i4), &
    'expint_sp args')

    if (n == 0_i4) then
        expint_sp=exp(-x)/x
        RETURN
    end if

    nm1=n-1_i4

    if (eq(x,0.0_sp)) then
        expint_sp=1.0_sp/nm1

    else if (x > 1.0_sp) then
        b=x+n
        c=BIG
        d=1.0_sp/b
        h=d

        do i=1_i4,MAXIT
            a=-i*(nm1+i)
            b=b+2.0_sp
            d=1.0_sp/(a*d+b)
            c=b+a/c
            del=c*d
            h=h*del
            if (abs(del-1.0_sp) <= EPS) exit
        end do

        if (i > MAXIT) call nrerror('expint_sp: continued fraction failed')
        expint_sp=h*exp(-x)

    else
        if (nm1 /= 0_i4) then
        expint_sp=1.0_sp/nm1
        else
            expint_sp=-log(x)-EULER
        end if

        fact=1.0_sp

        do i=1_i4,MAXIT
            fact=-fact*x/i
            if (i /= nm1) then
                del=-fact/(i-nm1)
            else
                del=fact*(-log(x)-EULER+sum(1.0_sp/arth(1_i4,1_i4,nm1)))
            end if

            expint_sp=expint_sp+del

            if (abs(del) < abs(expint_sp)*EPS) exit
        end do

        if (i > MAXIT) call nrerror('expint_sp: series failed')
    end if
END FUNCTION expint_sp

FUNCTION expint_dp(n,x)
    USE mo_kind,            ONLY : i4, dp
    USE mo_nrutil,          ONLY : arth,assert,nrerror
    USE mo_constants,       ONLY : EULER_D
    USE mo_utils,           ONLY : eq

    IMPLICIT NONE

    INTEGER(i4), INTENT(IN) :: n
    REAL(dp), INTENT(IN) :: x
    REAL(dp) :: expint_dp
    INTEGER(i4), PARAMETER :: MAXIT=100_i4
    REAL(dp), PARAMETER :: EPS=epsilon(x),BIG=huge(x)*EPS
    INTEGER(i4) :: i,nm1
    REAL(dp) :: a,b,c,d,del,fact,h

    call assert(n >= 0_i4, x >= 0.0_dp, (x > 0.0_dp .or. n > 1_i4), &
    'expint_dp args')

    if (n == 0_i4) then
        expint_dp=exp(-x)/x
        RETURN
    end if

    nm1=n-1_i4

    if (eq(x,0.0_dp)) then
        expint_dp=1.0_dp/nm1

    else if (x > 1.0_dp) then
        b=x+n
        c=BIG
        d=1.0_dp/b
        h=d

        do i=1_i4,MAXIT
            a=-i*(nm1+i)
            b=b+2.0_dp
            d=1.0_dp/(a*d+b)
            c=b+a/c
            del=c*d
            h=h*del
            if (abs(del-1.0_dp) <= EPS) exit
        end do

        if (i > MAXIT) call nrerror('expint_dp: continued fraction failed')
        expint_dp=h*exp(-x)

    else
        if (nm1 /= 0_i4) then
            expint_dp=1.0_dp/nm1
        else
            expint_dp=-log(x)-EULER_D
        end if

        fact=1.0_dp

        do i=1_i4,MAXIT
            fact=-fact*x/i
            if (i /= nm1) then
                del=-fact/(i-nm1)
            else
                del=fact*(-log(x)-EULER_D+sum(1.0_dp/arth(1_i4,1_i4,nm1)))
            end if

            expint_dp=expint_dp+del

            if (abs(del) < abs(expint_dp)*EPS) exit
        end do

        if (i > MAXIT) call nrerror('expint_dp: series failed')
    end if
END FUNCTION expint_dp


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! d_rot2_vec2gen
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine computes the generator for a Givens rotation represented by 2
! real numbers: A strictly real cosine and a scrictly real sine.  The first
! column is constructed to be parallel with the real vector [A,B]^T.
!
! The rot2 refers to a rotation desribed by two double and the vec2 to a vector
! of lenght two described by two double.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  A               REAL(8)
!                    the first component of the real vector [A,B]^T
!
!  B               REAL(8)
!                    the second component of the real vector [A,B]^T
!
! OUTPUT VARIABLES:
!
!  C               REAL(8)
!                    on exit contains the generator for the cosine
!                    component of the Givens rotation
!
!  S               REAL(8)
!                    on exit contains the generator for the sine
!                    component of the Givens rotation
!
!  NRM             REAL(8)
!                    on exit contains the norm of the vector [A,B]^T
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine d_rot2_vec2gen(A,B,C,S,NRM)

  implicit none

  ! input variables
  real(8), intent(in) :: A,B
  real(8), intent(inout) :: C,S,NRM

  ! construct rotation
  if ((A.EQ.0d0).AND.(B.EQ.0d0)) then
     C = 1d0
     S = 0d0
     NRM = 0d0
  else if (abs(A).GE.abs(B)) then
     S = B/A
     NRM = sign(sqrt(1d0 + S*S),A)
     C =  1.d0/NRM
     S =  S*C
     NRM =  A*NRM
  else
     C = A/B;
     NRM = sign(sqrt(1d0 + C*C),B)
     S =  1.d0/NRM
     C =  C*S
     NRM =  B*NRM
  end if

end subroutine d_rot2_vec2gen


!Subroutine comes here

!Subroutine to find the inverse of a square matrix
!Author : Louisda16th a.k.a Ashwith J. Rego
!Reference : Algorithm has been well explained in:
!http://math.uww.edu/~mcfarlat/inverse.htm
!http://www.tutor.ms.unimelb.edu.au/matrix/matrix_inverse.html
SUBROUTINE FINDInv(matrix, inverse, n, errorflag)
     use prec
     IMPLICIT NONE
     !Declarations
     INTEGER, INTENT(IN) :: n
     INTEGER, INTENT(OUT) :: errorflag  !Return error status. -1 for error, 0 for normal
     REAL(dp), INTENT(IN), DIMENSION(n,n) :: matrix  !Input matrix
     REAL(dp), INTENT(OUT), DIMENSION(n,n) :: inverse !Inverted matrix

     LOGICAL :: FLAG = .TRUE.
     INTEGER :: i, j, k, l
     REAL(dp) :: m
     REAL(dp), DIMENSION(n,2*n) :: augmatrix !augmented matrix

     !Augment input matrix with an identity matrix
     DO i = 1, n
        DO j = 1, 2*n
            IF (j <= n ) THEN
                  augmatrix(i,j) = matrix(i,j)
                ELSE IF ((i+n) == j) THEN
                  augmatrix(i,j) = 1d0
                Else
                 augmatrix(i,j) = 0d0
             ENDIF
         END DO
     END DO

     !Reduce augmented matrix to upper traingular form
     DO k =1, n-1
        IF (augmatrix(k,k) == 0d0) THEN
             FLAG = .FALSE.
             DO i = k+1, n
                IF (augmatrix(i,k) /= 0d0) THEN
                    DO j = 1,2*n
                       augmatrix(k,j) = augmatrix(k,j)+augmatrix(i,j)
                    END DO
                    FLAG = .TRUE.
                    EXIT
                ENDIF
                IF (FLAG .EQV. .FALSE.) THEN
                    PRINT*, "Matrix is non - invertible"
                    inverse = 0d0
                    errorflag = -1
                    return
                ENDIF
             END DO
        ENDIF
        DO j = k+1, n
              m = augmatrix(j,k)/augmatrix(k,k)
              DO i = k, 2*n
                     augmatrix(j,i) = augmatrix(j,i) - m*augmatrix(k,i)
              END DO
        END DO
     END DO

     !Test for invertibility
     DO i = 1, n
         IF (augmatrix(i,i) == 0d0) THEN
                PRINT*, "Matrix is non - invertible"
                inverse = 0d0
                errorflag = -1
                return
        ENDIF
     END DO

     !Make diagonal elements as 1
     DO i = 1 , n
        m = augmatrix(i,i)
        DO j = i , (2 * n)
               augmatrix(i,j) = (augmatrix(i,j) / m)
        END DO
     END DO

     !Reduced right side half of augmented matrix to identity matrix
     DO k = n-1, 1, -1
        DO i =1, k
           m = augmatrix(i,k+1)
                DO j = k, (2*n)
                   augmatrix(i,j) = augmatrix(i,j) -augmatrix(k+1,j) * m
                END DO
        END DO
     END DO

     !store answer
     DO i =1, n
        DO j = 1, n
          inverse(i,j) = augmatrix(i,j+n)
        END DO
     END DO
     errorflag = 0
END SUBROUTINE FINDinv


Calculate various trigonometric functions from the Fortran library.
      INTEGER BIT(32),B,IP	!Stuff for bit fiddling.
      INTEGER ENUFF,I		!Step through the test angles.
      PARAMETER (ENUFF = 17)	!A selection of special values.
      INTEGER ANGLE(ENUFF)	!All in whole degrees.
      DATA ANGLE/0,30,45,60,90,120,135,150,180,	!Here they are.
     1 210,225,240,270,300,315,330,360/		!Thus check angle folding.
      REAL PI,DEG2RAD		!Special numbers.
      REAL D,R,FD,FR,AD,AR	!Degree, Radian, F(D), F(R), inverses.
      PI = 4*ATAN(1.0)		!SINGLE PRECISION 1·0.
      DEG2RAD = PI/180		!Limited precision here too for a transcendental number.
Case the first: sines.
      WRITE (6,10) ("Sin", I = 1,4)	!Supply some names.
   10 FORMAT (" Deg.",A7,"(Deg)",A7,"(Rad)   Rad - Deg",	!Ah, layout.
     1 6X,"Arc",A3,"D",6X,"Arc",A3,"R",9X,"Diff")
      DO I = 1,ENUFF		!Step through the test values.
        D = ANGLE(I)			!The angle in degrees, in floating point.
        R = D*DEG2RAD			!Approximation, in radians.
        FD = SIND(D); AD = ASIND(FD)		!Functions working in degrees.
        FR = SIN(R);  AR = ASIN(FR)/DEG2RAD	!Functions working in radians.
        WRITE (6,11) INT(D),FD,FR,FR - FD,AD,AR,AR - AD	!Results.
   11   FORMAT (I4,":",3F12.8,3F13.7)	!Ah, alignment with FORMAT 10...
      END DO			!On to the next test value.
Case the second: cosines.
      WRITE (6,10) ("Cos", I = 1,4)
      DO I = 1,ENUFF
        D = ANGLE(I)
        R = D*DEG2RAD
        FD = COSD(D); AD = ACOSD(FD)
        FR = COS(R);  AR = ACOS(FR)/DEG2RAD
        WRITE (6,11) INT(D),FD,FR,FR - FD,AD,AR,AR - AD
      END DO
Case the third: tangents.
      WRITE (6,10) ("Tan", I = 1,4)
      DO I = 1,ENUFF
        D = ANGLE(I)
        R = D*DEG2RAD
        FD = TAND(D); AD = ATAND(FD)
        FR = TAN(R);  AR = ATAN(FR)/DEG2RAD
        WRITE (6,11) INT(D),FD,FR,FR - FD,AD,AR,AR - AD
      END DO
      WRITE (6,*) "...Special deal for 90 degrees..."
      D = 90
      R = D*DEG2RAD
      FD = TAND(D); AD = ATAND(FD)
      FR = TAN(R);  AR = ATAN(FR)/DEG2RAD
      WRITE (6,*) "TanD =",FD,"Atan =",AD
      WRITE (6,*) "TanR =",FR,"Atan =",AR
Convert PI to binary...
      PI = PI - 3	!I know it starts with three, and I need the fractional part.
      BIT(1:2) = 1	!So, the binary is 11. something.
      B = 2		!Two bits known.
      DO I = 1,26	!For single precision, more than enough additional bits.
        PI = PI*2		!Hoist a bit to the hot spot.
        IP = PI			!The integral part.
        PI = PI - IP		!Remove it from the work in progress.
        B = B + 1		!Another bit bitten.
        BIT(B) = IP		!Place it.
      END DO		!On to the next.
      WRITE (6,20) BIT(1:B)	!Reveal the bits.
   20 FORMAT (" Pi ~ ",2I1,".",66I1)	!A known format.
      WRITE (6,*) "   = 11.00100100001111110110101010001000100001..."	!But actually...
      END		!So much for that.


module math

    use, intrinsic :: iso_fortran_env, dp=>real64

    implicit none

    private

    public :: PI, &
              multiplyMatrixByVector, &
              getSD

    real(dp), parameter :: PI = 4.0_dp * datan(1.0_dp)
    ! TODO: add test as for different PCs NaN code can be different
    real(dp), parameter :: NAN_64 = transfer(-2251799813685248_int64, 1._dp)

contains

    function multiplyMatrixByVector(A,x) result(y)

        real(dp),dimension(3,3),intent(in) :: A
        real(dp),dimension(3),intent(in) :: x
        real(dp),dimension(3) :: y
        ! TODO: rewrite it with elemental operations
        y(1) = A(1, 1)*x(1) + A(1, 2)*x(2) + A(1, 3)*x(3)
        y(2) = A(2, 1)*x(1) + A(2, 2)*x(2) + A(2, 3)*x(3)
        y(3) = A(3, 1)*x(1) + A(3, 2)*x(2) + A(3, 3)*x(3)

    end function

    function getSD(array) result(sD)
        real(dp), dimension(:), intent(in) :: array
        real(dp) :: sD
        real(dp) :: avg
        real(dp) :: sumOfRestsSquared = 0.0_dp

        avg = sum(array) / size(array)
        sumOfRestsSquared = sum((array(:) - avg) ** 2)
        sD = sqrt(sumOfRestsSquared / size(array))
        ! NOTE: this shouldn't be here. What shoud we do when we have
        ! only 1 element?
        if (size(array) == 1) then
            sD = 100.0_dp
        end if
    end function getSD
end module


! Name: ARPIT KUMAR JAIN, Roll No: 180122009
! Home Assignment Programme-1
! UV-vis & CD spectra
!
PROGRAM HA_Q1

    IMPLICIT NONE

    ! Declaration of variables
    REAL, PARAMETER :: pi = acos(-1.0)
    REAL:: sigma, nu, nu_i, E_nu, deltaE_nu
    REAL, DIMENSION(40):: lamda_i, fosc, Rstr
    CHARACTER*11:: filename
    INTEGER:: i, lamda, outunit, inunit

    ! σ = 2480 cm−1
    sigma = 2480

    OPEN(UNIT = inunit, FILE = "input.dat")                 ! Open the input file
        DO i = 1, 40                                        ! loop over input dataset
            READ(inunit, *) lamda_i(i), fosc(i), Rstr(i)    ! Read the input
        ENDDO
    CLOSE(inunit)

    WRITE(filename, fmt = "(A)") "output1.dat"  ! filename = output1.dat

    OPEN(UNIT = outunit, FILE = filename, FORM = "formatted")   ! Open the output file
        DO lamda = 200, 600

            ! V = 1/λ, λ in "nm" and V in "cm" so multiply by 10^7
            nu = 10**7 / lamda

            ! Set E_nu and deltaE_nu = 0.0 in each iteration so that for each nu we have new E and delE
            E_nu = 0.0
            deltaE_nu = 0.0

            DO i = 1, 40
                nu_i = 10**7 / lamda_i(i)                   ! Vi = 1/λi, λi in "nm" and Vi in "cm" so multiply by 10^7

                ! Calculation for E_nu & deltaE_nu "SUM i = 1 to n" part
                E_nu = E_nu + fosc(i) * EXP(-( ( (nu - nu_i) / sigma) * ( (nu - nu_i) / sigma)))
                deltaE_nu = deltaE_nu + nu_i * Rstr(i) * EXP(-( ( (nu - nu_i) / sigma) * ( (nu - nu_i) / sigma)))
            ENDDO

            ! Multiply E_nu with constant part which is not effected by SUM over 1 to n
            E_nu = E_nu * 1.3062974 * (10**8) / sigma

            ! Multiply deltaE_nu with its constant part
            deltaE_nu = deltaE_nu * ( 1.0 / (22.96 * sqrt(pi) * sigma))     ! (10^-40) / (2.296 * 10^-39) = 1 / 22.96

            WRITE(outunit, *) lamda, E_nu, deltaE_nu                        ! Write the Output in file
        ENDDO
    CLOSE(outunit)
END PROGRAM HA_Q1


program heat
    implicit none
    ! introduce a constants M and pi
    integer, parameter :: M = 10
    real, parameter :: pi = 4. * atan(1.)
    integer :: i, k, N
    real :: h, tau,  x
    real, dimension(M + 1) :: u, v

    h = 1. / M
    tau = h * h / 2.
    N = 1. / tau

    ! initialize the initial data and print the values
    do k=1,M + 1
        x = (k - 1) * h
        u(k) = sin(pi * x)
        write(*,*)0., x, u(k)
    end do
    ! print empty line
    write(*,*)

    do i=1,N

        ! one step of explicit finite difference method
        v(1) = u(1) ! constant boundary condition
        do k = 2,M
            v(k) = u(k) + (tau / (h * h)) * (u(k - 1) - 2 * u(k) + u(k + 1))
        end do
        v(M + 1) = u(M + 1) ! constant boundary condition

        ! can be also written as
        ! v(2:M) = u(2:M) + (tau / (h * h)) * (u(1:M-1) - 2 * u(2:M) + u(3:M+1))

        ! print solution values
        do k = 1, M + 1
            write(*,*)i * tau, (k - 1) * h, v(k)
        end do
        ! print empty line
        write(*,*)

        u = v
    end do

end program


! HOW TO COMPILE THROUGH COMMAND LINE (CMD OR TERMINAL)
! gfortran -c newton_interpolation.f95
! gfortran -o newton_interpolation newton_interpolation.o
!
! The program is open source and can use to numeric study purpose.
! The program was build by Aulia Khalqillah,S.Si., M.Si
!
! email: auliakhalqillah.mail@gmail.com
! ==============================================================================
program newtonint
    implicit none

    integer, parameter :: N = 5
    integer :: nrow,ncol
    integer :: i,j,k
    real :: x(N),y(N), ms(N-1)
    real :: m(N,N)
    real :: xq, P

    ! Initial data
    x(1) = 0.0
    x(2) = 0.2
    x(3) = 0.4
    x(4) = 0.6
    x(5) = 0.8
    y(1) = 1.0
    y(2) = 1.2214
    y(3) = 1.4918
    y(4) = 1.8221
    y(5) = 2.2255

    ! Generate initial zero matrix NxN
    nrow = N
    ncol = N
    do i = 1,nrow
        do j = 1,ncol
            m(i,j) = 0
            write(*,*) i,j,m(i,j)
        end do
    end do

    write(*,*)
    ! Save the y data to the first column of matrix as zero degree
    do i = 1,nrow
        m(i,1) = y(i)
    end do

    ! Check the current matrix
    do i = 1,nrow
        write(*,*) (m(i,j), j = 1,ncol)
    end do

    write(*,*)
    ! Calculate the data for remaining column of matrix by using y data
    do j = 2,ncol
        do i = j,nrow
            m(i,j) = (m(i,j-1) - m(i-1,j-1))/(x(i) - x(i-(j-1)))
        end do
    end do

    ! Check the current matrix
    do i = 1,nrow
        write(*,*) (m(i,j), j = 1,ncol)
    end do

    write(*,*)
    ! Calculate the newton interpolation
    xq = 0.75
    ! Calculate multiplication iteration section
    ms(1) = (xq - x(1))
    do k = 1,n-1
        ms(k+1) = ms(k) * (xq - x(k+1))
    end do

    write(*,*)
    ! calculate the summation section
    P = 0
    do k = 2,n
        P = P + (m(k,k) * ms(k-1))
    end do

    P = y(1) + P
    write(*,*) P
end program newtonint


      subroutine DSBASD(KORDER, LEFT, T, X, IDERIV, BDERIV)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 DSBASD Krogh  Changes to use M77CON
c>> 1993-01-12 DSBASD CLL  Bringing all computation inline.
c>> 1992-11-02 C. L. Lawson, JPL
c>> 1988-03-22 C. L. Lawson, JPL
c
c     Given the knot-set T(i), i = 1, ..., NT, this subr computes
c     values at X of the derivative of order IDERIV of each of the
c     the KORDER B-spline basis functions of order KORDER
c     that are nonzero on the open interval (T(LEFT), T(LEFT+1).
c     Require T(LEFT) < T(LEFT+1) and KORDER .le. LEFT .le.
c     NT-KORDER.
c     For proper evaluation, X must lie in the closed interval
c     [T(LEFT), T(LEFT+1], otherwise the computation constitutes
c     extrapolation.
c     The basis functions whose derivatives are returned will be those
c     indexed from LEFT+1-KORDER through LEFT, and their values will be
c     stored in BDERIV(I), I = 1, ..., KORDER.
c     ------------------------------------------------------------------
c  Method:
c
c  In general there are two stages: First compute values of basis
c  functions of order KORDER-IDERIV.  Then, if IDERIV > 0, transform
c  these values to produce values of higher order derivatives of
c  higher order basis functions, ultimately obtaining values of
c  the IDERIV derivative of basis functions of order KORDER.
c
c  The first stage uses the recursion:
C
C                       X - T(I)              T(I+J+1) - X
C     B(I,J+1)(X)  =  -----------B(I,J)(X) + ---------------B(I+1,J)(X)
C                     T(I+J)-T(I)            T(I+J+1)-T(I+1)
C
c  where B(I,J) denotes the basis function of order J and index I.
c  For order J, the only basis functions that can be nonzero on
c  [T(LEFT), T(LEFT+1] are those indexed from LEFT+1-J to LEFT.
c  For order 1, the only basis function nonzero on this interval is
c  is B(LEFT,1), whose value is 1.  The organization of the calculation
c  using the above recursion follows Algorithm (8) in Chapter X of the
c  book by DeBoor.
c
c  For the second stage, let B(ID, K, J) denote the value at X of the
c  IDth derivative of the basis function of order K, with index J.
c  From the first stage we will have values of B(0, KORDER-IDERIV, j)
c  for j = LEFT+1-KORDER+IDERIV), ..., LEFT, stored in BDERIV(i), for
c  i = 1+IDERIV, ..., KORDER.
c
c     Loop for ID = 1, ..., IDERIV
c        Replace the contents of BDERIV() by values of
c        B(ID, KORDER-IDERIV+ID, j) for
c        j = LEFT+1-KORDER+IDERIV-ID), ..., LEFT, storing these in
c        BDERIV(i), i = 1+IDERIV-ID, ..., KORDER.
c     End loop
c
c  The above loop uses formula (10), p. 138, of
c  A PRACTICAL GUIDE TO SPLINES by Carl DeBoor, Springer-Verlag,
c  1978, when ID = 1, and successive derivatives of that formula
c  when ID > 1.  Note that we are using Formula (10) in the special
c  case in which (Alpha sub i) = 1, and all other Alpha's are zero.
c
c  This approach and implementation by C. L. Lawson, JPL, March 1988.
C     ------------------------------------------------------------------
C  KORDER [in]  Gives both the order of the B-spline basis functions
c        whose derivatives are to be evaluated,
c        and the number of such functions to be evaluated.
c        Note that the polynomial degree of these functions is one less
c        than the order.  Example:  For cubic splines the order is 4.
c        Require 1 .le. KORDER .le. KMAX, where KMAX is an internal
c        parameter.
c  LEFT  [in]  Index identifying the left end of the interval
c        [T(LEFT), T(LEFT+1)] relative to which the B-spline basis
c        functions will be evaluated.
c        Require        KORDER .le. LEFT .le. NT-KORDER
c        and            T(LEFT) < T(LEFT+1)
c        The evaluation is proper if T(LEFT) .le. X .le. T(LEFT+1), and
c        otherwise constitutes extrapolation.
C        DIVISION BY ZERO  will result if T(LEFT) = T(LEFT+1)
C  T()   [in]  Knot sequence, indexed from 1 to NT, with
c        NT .ge. LEFT+KORDER.  Knot values must be nonincreasing.
c        Repetition of values is permitted and has the effect of
c        decreasing the order of contimuity at the repeated knot.
c        Proper function representation by splines of order K is
c        supported on the interval from T(K) to T(NT+1-K).
c        Extrapolation can be done outside this interval.
C  X     [in]  The abcissa at which the B-spline basis functions are to
c        be evaluated.  The evaluation is proper if T(KORDER) .le. X .le
c        T(NT+1-KORDER), and constitutes extrapolation otherwise.
c  IDERIV [in]  Order of derivative requested.  Require IDERIV .ge. 0.
c        Derivatives of order .ge. KORDER are zero.
C  BDERIV()  [out]  On normal return, this array will contain in
c        BDERIV(i), i = 1, ...,KORDER, the values computed by this subr.
c        These are values at X of the derivative of order IDERIV of each
c        of the basis functions indexed LEFT+1-KORDER through LEFT.
C     ------------------------------------------------------------------
c--D replaces "?": ?SBASD
c     Both versions use IERM1, IERV1
C     ------------------------------------------------------------------
      integer KMAX
      parameter(KMAX = 20)
      integer I, I1, ID, IDERIV, ISTART, IT1, IT2
      integer J, JP1, K1, KORDER, LEFT
      double precision BDERIV(KORDER), DELTAL(KMAX), DELTAR(KMAX), FLK1
      double precision SAVED, T(LEFT+KORDER), TERM, X
C     ------------------------------------------------------------------
      ID = IDERIV
      if(ID .lt. 0 ) then
         call IERM1('DSBASD',2,2,'Require IDERIV .ge. 0',
     *   'IDERIV',ID,'.')
         return
      endif
      if(ID .ge. KORDER) then
         do 5 I = 1, KORDER
            BDERIV(I) = 0.0d0
    5    continue
         return
      endif
      if(KORDER .gt. KMAX) then
         call IERM1('DSBASD',1,2,'Require KORDER .le. KMAX.',
     *   'KORDER',KORDER,',')
         call IERV1('KMAX',KMAX,'.')
         return
      endif
      ISTART = 1+ID
      K1 = KORDER - ID
c
c        Evaluate K1 basis functions of order K1.  Store values in
c        BDERIV(ISTART:ISTART+K1-1)
c
      BDERIV(ISTART) = 1.0d0
      do 30 J = 1, K1-1
         JP1 = J + 1
         DELTAR(J) = T(LEFT+J) - X
         DELTAL(J) = X - T(LEFT+1-J)
         SAVED = 0.0d0
         do 26 I=1,J
            TERM = BDERIV(ID+I)/(DELTAR(I) + DELTAL(JP1-I))
            BDERIV(ID+I) = SAVED + DELTAR(I)*TERM
            SAVED = DELTAL(JP1-I)*TERM
   26    continue
         BDERIV(ID+JP1) = SAVED
   30 continue
c
c     Loop IDERIV times, each time advancing the order of the
c     derivative by one, so final results are values of derivatives
c     of order IDERIV.
c
      do 70 I1 = ISTART, 2, -1
         FLK1 = dble(K1)
         IT1 = LEFT+1-I1
         IT2 = IT1 - K1
         do 50 I = I1, KORDER
            BDERIV(I) = BDERIV(I) * FLK1 /(T(IT1+I) - T(IT2+I))
   50    continue
c
         BDERIV(I1-1) = -BDERIV(I1)
         do 60 I = I1, KORDER-1
            BDERIV(I) = BDERIV(I) - BDERIV(I+1)
   60    continue
         K1 = K1 + 1
   70 continue
      return
      end


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

 subroutine gauss(n,a,b,c)

!                                                                               !
! This subroutine solves the n x n linear system ac = b                         !
! by Gauss-elimination with pivoting                                            !
!                                                                               !
! On input:                                                                     !
! n              dimension of the system                                        !
! a(n,n)         coefficient matrix                                             !
! b(n)           righthand side                                                 !
!                                                                               !
! On output:                                                                    !
! c(n)           solutions to the system                                        !
!                                                                               !
!  Authors:                                                                     !
!  Per J\"onsson, Malm\"o University, Sweden                                    !
!  e-mail per.jonsson@ts.mah.se                                                 !
!                                                                               !
!  Lars Eklundh, Lund University, Sweden                                        !
!  e-mail lars.eklundh@nateko.lu.se                                             !
!                                                                               !
!  Updated 26/3-2005                                                            !
!                                                                               !
!-------------------------------------------------------------------------------!

 implicit none

 integer :: i,j,k,n,pos(1)
 double precision :: a(n,n),b(n),c(n),f,temp1(n),temp2

!---- Elimination ---------------------------------------------------------------

 do i = 1,n-1
   pos(1:1) = maxloc(abs(a(i:n,i)))
   if (pos(1) > 1) then
     temp1  = a(i,:)
     temp2  = b(i)
     a(i,:) = a(i+pos(1)-1,:)
     b(i)   = b(i+pos(1)-1)
     a(i+pos(1)-1,:) = temp1
     b(i+pos(1)-1)   = temp2
   end if
   do j = i+1,n
     f = - a(j,i)/a(i,i)
     a(j,:) = a(j,:) + f*a(i,:)
     b(j) = b(j) + f*b(i)
   end do
 end do

!---- Back substitution ---------------------------------------------------------

 do i = 1,n
   if (abs(a(i,i)) < 1d-80) then
     c = 0.d0
!	 write(*,*) 'Bad condition in gauss'
     return
   end if
 end do

 c(n) = b(n)/a(n,n)
 do i = n-1,1,-1
   c(i) = (b(i) - sum(a(i,i+1:n)*c(i+1:n)) )/a(i,i)
 end do

 end subroutine gauss


SUBROUTINE spear(data1,data2,n,wksp1,wksp2,d,zd,probd,rs,probrs)
INTEGER n
REAL*8 d,probd,probrs,rs,zd,data1(n),data2(n),wksp1(n),wksp2(n)
!CU    USES betai,crank,erfcc,sort2
INTEGER j
REAL*8 aved,df,en,en3n,fac,sf,sg,t,vard,betai,erfcc
do j=1,n
  wksp1(j)=data1(j)
  wksp2(j)=data2(j)
enddo
call sort2(n,wksp1,wksp2)
call crank(n,wksp1,sf)
call sort2(n,wksp2,wksp1)
call crank(n,wksp2,sg)
d=0.
do j=1,n
  d=d+(wksp1(j)-wksp2(j))**2
enddo
en=n
en3n=en**3-en
aved=en3n/6.-(sf+sg)/12.
fac=(1.-sf/en3n)*(1.-sg/en3n)
vard=((en-1.)*en**2*(en+1.)**2/36.)*fac
zd=(d-aved)/sqrt(vard)
probd=erfcc(abs(zd)/1.4142136)
rs=(1.-(6./en3n)*(d+(sf+sg)/12.))/sqrt(fac)
fac=(1.+rs)*(1.-rs)
if(fac.gt.0.)then
  t=rs*sqrt((en-2.)/fac)
  df=en-2.
  probrs=betai(0.5*df,0.5,df/(df+t**2))
else
  probrs=0.
endif
return
END


program main
  implicit none
  integer :: i, n
  real(8) :: ff_0, ff_p, ff_m, dfdx_f, dfdx_m, dfdx_e
  real(8) :: x, h

  x = 0d0
  dfdx_e = exp(x)

  h = 1d0

  n = 16
  open(20,file="fd_error.out")
  do i = 1, n
     ff_0   = exp(x)
     ff_p = exp(x+h)
     ff_m = exp(x-h)

     dfdx_f = (ff_p-ff_0)/h
     dfdx_m = (ff_p-ff_m)/(2d0*h)

     write(20,"(5e16.6e3)")h,dfdx_f,abs(dfdx_f - dfdx_e),dfdx_m,abs(dfdx_m - dfdx_e)

     h = h/2d0
  end do
  close(20)

end program main


	FUNCTION PR_WCMP  ( drct, sped, dcmp )
C************************************************************************
C* PR_WCMP 								*
C*									*
C* This function computes the wind component toward a specified		*
C* direction.  The following equation is used:				*
C*									*
C*    WCMP = -COS ( DRCT - DCMP ) * SPED				*
C*									*
C*         WCMP = component of wind in meters/second			*
C*         DRCT = wind direction in degrees				*
C*         DCMP = direction of desired component			*
C*         SPED = wind speed in meters/second				*
C*									*
C* REAL PR_WCMP ( DRCT, SPED, DCMP )					*
C*									*
C* Input parameters:							*
C*	DRCT		REAL		Wind direction in degrees	*
C*	SPED		REAL		Wind speed in meters/second	*
C*	DCMP		REAL		Direction of desired component	*
C*									*
C* Output parameters:							*
C*	PR_WCMP		REAL		Component of wind in m/s	*
C**									*
C* Log:									*
C* John Nielsen/MIT	 9/88						*
C* John Nielsen/SUNYA	 8/90	GEMPAK 5				*
C* J. Whistler/SSAI	 7/91	Changed COSD to COS and converted to rad*
C* T. Piper/GSC		11/98	Updated prolog				*
C************************************************************************
C*
	INCLUDE		'GEMPRM.PRM'
	INCLUDE		'ERMISS.FNC'
C------------------------------------------------------------------------
C
C* 	Check for missing input parameters.
C
	IF ( ERMISS (sped) .or. ERMISS (drct) .or. ERMISS (dcmp)) THEN
	    PR_WCMP = RMISSD
	  ELSE
C
C*	Calculate wind speed toward specified direction.
C
	    PR_WCMP = (-COS( ( drct - dcmp ) * DTR )) * sped
	END IF
C*
	RETURN
	END


  !! ----------------------------------------------------------------------- !!
  !>
  !! Tsunami initial height.
  !! Tsunami height eta(:,:) ( in m-unit ) must be defined here.
  !<
  !! --
  block

    real, parameter :: aa = 16000.
    real, parameter :: bb = 16000.
    integer :: i, j, i0, j0
    real :: hx, hy
    !! ----

    i0 = nx/2
    j0 = ny/2
    eta(:,:) = 0.0
    do j=1, ny
       if( -bb <= (j-j0)*dy  .and. (j-j0) * dy <= bb ) then
          hy = ( 1 + cos( pi * ( j-j0 ) * dy / bb ) ) / 2.0
       else
          hy = 0.0
       end if
       do i=1, nx

          if( -aa <= (i-i0)*dx  .and. (i-i0) * dx <= aa ) then
             hx = ( 1 + cos( pi * ( i-i0 ) * dx / aa ) ) / 2.0
          else
             hx = 0.0
          end if

          eta(i,j) = hx * hy

       end do

    end do

  end block


MODULE vector_module
IMPLICIT NONE
TYPE :: vector
  REAL :: x
  REAL :: y
END TYPE vector

CONTAINS
  TYPE (vector) FUNCTION vector_add(v1, v2)
  IMPLICIT NONE
  TYPE (vector), INTENT(IN) :: v1, v2
  vector_add = vector(v1%x + v2%x, v1%y + v2%y)
  END FUNCTION vector_add

  TYPE (vector) FUNCTION vector_sub(v1, v2)
  IMPLICIT NONE
  TYPE (vector), INTENT(IN) :: v1, v2
  vector_sub = vector(v1%x - v2%x, v1%y - v2%y)
  END FUNCTION vector_sub
END MODULE vector_module

PROGRAM test_vectors
USE vector_module
IMPLICIT NONE
TYPE (vector) :: a, b, c
a = vector(1., 2.)
b = vector(6., 9.)
c = vector_add(a, b)
WRITE(*, *) c
c = vector_sub(a, b)
WRITE(*, *) c
END PROGRAM test_vectors


subroutine apply_pde_operator(t, q, output)

! For the PDE q_t = g(q), calculates g(q).
!
! Args:
!   t: Time at which the operator is evaluated.
!   q: PDE solution at time t.
!   output: g(q), calculated here.

    implicit none

    integer :: mx, mbc, meqn
    double precision :: x_lower, dx
    common /claw_config/ mx, mbc, x_lower, dx, meqn

    double precision, intent(in) :: t
    double precision, dimension(1-mbc:mx+mbc, meqn), intent(in) :: q
    double precision, dimension(1-mbc:mx+mbc, meqn), intent(out) :: output

    integer :: ix

    do ix = 1, mx
        output(ix, 1) = (q(ix-1, 1) - 2 * q(ix, 1) + q(ix+1, 1)) / dx**2
    end do

end subroutine apply_pde_operator