! In program name, - is not allowed
!works till 100938872634753805466563377840038871040
! Commenting out of the reasonable bounds for calculation
program prime_check
  character(len=10) :: argument
  Character(26) :: low = 'abcdefghijklmnopqrstuvwxyz'
  Character(26) :: cap = 'ABCDEFGHIJKLMNOPQRSTUVWXYZ'
  integer :: check_capital_letters, check_small_letters, i, decimal_check, even_check, remainder, flag_prime
  integer(kind = 16):: number
  ! Anything not equal to single argument, Print Error
  IF(COMMAND_ARGUMENT_COUNT().NE.1)THEN
    write(*,'(g0.8)')"Usage: please input a non-negative integer"
    STOP
  ENDIF

  CALL GET_COMMAND_ARGUMENT(1,argument)
  if (argument == "") then
    write(*,'(g0.8)')"Usage: please input a non-negative integer"
    STOP
  endif
  ! Scan for letters
  check_capital_letters = scan(argument, cap)
  check_small_letters = scan(argument, low)
  decimal_check = scan(argument, '.')
  ! If capital letters exist, print error
  if (check_capital_letters > 0) then
    write(*,'(g0.8)')"Usage: please input a non-negative integer"
    STOP
  endif
  ! If small letters exist, print error
  if (check_small_letters > 0) then
    write(*,'(g0.8)')"Usage: please input a non-negative integer"
    STOP
  endif

  ! Decimal Check
  if (decimal_check > 0) then
    write(*,'(g0.8)')"Usage: please input a non-negative integer"
    STOP
  endif
  ! read the cmd line arg into number
  read (argument, '(I10)') number

  ! negative number
  if (number < 0) then
    write(*,'(g0.8)')"Usage: please input a non-negative integer"
    STOP
  endif

  ! ! Maximum Limit
  ! if (number > 100938872634753805466563377840038871040) then
  !   write(*,'(g0.8)')"Input is out of the reasonable bounds for calculation"
  !   STOP
  ! endif

  ! 2 is Prime
  if (number == 2) then
    write(*,'(g0.8)')"Prime"
    STOP
  endif
  ! 0, 1 and even numbers are Even
  even_check = modulo(number, 2)
  if ((number == 0) .or. (number == 1) .or. ( even_check == 0 )) then
    write(*,'(g0.8)')"Composite"
    STOP
  endif
  ! Check Prime
  max = number / 2
  flag_prime = 1
  do i = 3, max
    remainder = modulo(number, i)
    if (remainder == 0) then
      flag_prime = 0
      exit
    end if
  end do

  if(flag_prime == 1) then
    write(*,'(g0.8)') "Prime"
  else
    write(*,'(g0.8)') "Composite"
  end if
end program


module surfaces

    use vector_class, only : vector
    use constants,    only : wp

    implicit none

    private
    public :: intersect_sphere, intersect_cylinder, intersect_ellipse, intersect_cone
    public :: reflect_refract

    contains

    logical function intersect_sphere(orig, dir, t, centre, radius)
    ! calculates where a line, with origin:orig and direction:dir hits a sphere, centre:centre and radius:radius
    ! returns true if intersection exists
    ! returns t, the paramertised parameter of the line equation
    ! adapted from scratchapixel

        implicit none

        type(vector),  intent(IN)  :: dir, orig, centre
        real(kind=wp), intent(OUT) :: t
        real(kind=wp), intent(IN)  :: radius

        type(vector)  :: L
        real(kind=wp) :: t0, t1, a, b, c, tmp

        intersect_sphere = .false.

        L = orig - centre
        a = dir .dot. dir
        b = 2._wp * (dir .dot. L)
        c = (l .dot. l) - radius**2

        if(.not. solveQuadratic(a, b, c, t0, t1))return
        if(t0 > t1)then
            tmp = t1
            t1 = t0
            t0 = tmp
        end if
        if(t0 < 0._wp)then
            t0 = t1
            if(t0 < 0._wp)return
        end if

        t = t0
        intersect_sphere = .true.
        return

    end function intersect_sphere

    logical function intersect_cylinder(orig, dir, t, centre, radius)
    ! calculates where a line, with origin:orig and direction:dir hits a cylinder, centre:centre and radius:radius
    ! returns true if intersection exists
    ! returns t, the paramertised parameter of the line equation
    ! adapted from scratchapixel
    ! need to check z height after moving ray
    ! if not this is an infinte cylinder
    ! cylinder lies length ways along z-axis

        implicit none

        type(vector),  intent(IN)  :: dir, orig, centre
        real(kind=wp), intent(OUT) :: t
        real(kind=wp), intent(IN)  :: radius

        type(vector)  :: L
        real(kind=wp) :: t0, t1, a, b, c, tmp

        intersect_cylinder = .false.

        L = orig - centre
        a = dir%z**2 + dir%y**2
        b = 2._wp * (dir%z * L%z + dir%y * L%y)
        c = L%z**2 + L%y**2 - radius**2

        if(.not. solveQuadratic(a, b, c, t0, t1))return
        if(t0 > t1)then
            tmp = t1
            t1 = t0
            t0 = tmp
        end if
        if(t0 < 0._wp)then
            t0 = t1
            if(t0 < 0._wp)return
        end if

        t = t0
        intersect_cylinder = .true.
        return
    end function intersect_cylinder

    logical function intersect_ellipse(orig, dir, t, centre, semia, semib)
    ! calculates where a line, with origin:orig and direction:dir hits a ellipse, centre:centre and axii:semia, semib
    ! returns true if intersection exists
    ! returns t, the paramertised parameter of the line equation
    ! adapted from scratchapixel and pbrt
    ! need to check z height after moving ray
    ! if not this is an infinte ellipse-cylinder
    ! ellipse lies length ways along z-axis
    ! semia and semib are the semimajor axis which are the half width and height.

        implicit none

        type(vector),  intent(IN)  :: dir, orig, centre
        real(kind=wp), intent(OUT) :: t
        real(kind=wp), intent(IN)  :: semia, semib

        type(vector)  :: L
        real(kind=wp) :: t0, t1, a, b, c, tmp, semia2div, semib2div

        intersect_ellipse = .false.

        semia2div = 1._wp / semia**2
        semib2div = 1._wp / semib**2

        L = orig - centre
        a = semia2div * dir%z**2 + semib2div * dir%y**2
        b = 2._wp * (semia2div * dir%z * L%z + semib2div * dir%y * L%y)
        c = semia2div * L%z**2 + semib2div * L%y**2 - 1._wp

        if(.not. solveQuadratic(a, b, c, t0, t1))return
        if(t0 > t1)then
            tmp = t1
            t1 = t0
            t0 = tmp
        end if
        if(t0 < 0._wp)then
            t0 = t1
            if(t0 < 0._wp)return
        end if

        t = t0
        intersect_ellipse = .true.
        return
    end function intersect_ellipse

    logical function intersect_cone(orig, dir, t, centre, radius, height)
    ! calculates where a line, with origin:orig and direction:dir hits a cone, radius:radius and height:height with centre:centre.
    ! centre is the point under the apex at the cone's base.
    ! returns true if intersection exists
    ! returns t, the paramertised parameter of the line equation
    ! adapted from scratchapixel and pbrt
    ! need to check z height after moving ray
    ! if not this is an infinte cone
    ! cone lies height ways along z-axis

        implicit none

        type(vector),  intent(IN)  :: orig, dir, centre
        real(kind=wp), intent(IN)  :: radius, height
        real(kind=wp), intent(OUT) :: t

        type(vector)  :: L
        real(kind=wp) :: t0, t1, a, b, c, tmp, k

        intersect_cone = .false.
        k = radius / height
        k = k**2

        L = orig - centre
        a = dir%x**2 + dir%y**2 - (k*dir%z**2)
        b = 2._wp*((dir%x * L%x) + (dir%y * L%y) - (k*dir%z * (L%z - height)))
        c = L%x**2 + L%y**2 - (k*(L%z - height)**2)

        if(.not. solveQuadratic(a, b, c, t0, t1))return
        if(t0 > t1)then
            tmp = t1
            t1 = t0
            t0 = tmp
        end if
        if(t0 < 0._wp)then
            t0 = t1
            if(t0 < 0._wp)return
        end if

        t = t0

        intersect_cone = .true.
        return

    end function intersect_cone

    logical function solveQuadratic(a, b, c, x0, x1)
    ! solves quadratic equation given coeffs a, b, and c
    ! returns true if real soln
    ! returns x0 and x1
    ! adapted from scratchapixel

        implicit none

        real(kind=wp), intent(IN)  :: a, b, c
        real(kind=wp), intent(OUT) :: x0, x1

        real(kind=wp) :: discrim, q

        solveQuadratic = .false.

        discrim = b**2 - 4._wp * a * c
        if(discrim < 0._wp)then
            return
        elseif(discrim == 0._wp)then
            x0 = -0.5_wp*b/a
            x1 = x0
        else
            if(b > 0._wp)then
                q = -0.5_wp * (b + sqrt(discrim))
            else
                q = -0.5_wp * (b - sqrt(discrim))
            end if
            x0 = q / a
            x1 = c / q
        end if
        solveQuadratic = .true.
        return

    end function solveQuadratic

    subroutine reflect_refract(I, N, n1, n2, rflag)
    ! wrapper routine for fresnel calculation
    !
    !
        use random, only : ran2
        use vector_class

        implicit none

        type(vector),  intent(INOUT) :: I !incident vector
        type(vector),  intent(INOUT) :: N ! normal vector
        real(kind=wp), intent(IN)    :: n1, n2 !refractive indcies
        logical,       intent(OUT)   :: rflag !reflection flag

        rflag = .FALSE.

        !draw random number, if less than fresnel coefficents, then reflect, else refract
        if(ran2() <= fresnel(I, N, n1, n2))then
            call reflect(I, N)
            rflag = .true.
        else
            call refract(I, N, n1/n2)
        end if

    end subroutine reflect_refract

    subroutine reflect(I, N)
    !   get vector of reflected photon
    !
    !
        use vector_class

        implicit none

        type(vector), intent(INOUT) :: I ! incident vector
        type(vector), intent(IN)    :: N ! normal vector

        type(vector) :: R

        R = I - 2._wp * (N .dot. I) * N
        I = R

    end subroutine reflect

    subroutine refract(I, N, eta)
    !   get vector of refracted photon
    !
    !
        use vector_class

        implicit none

        type(vector),  intent(INOUT) :: I
        type(vector),  intent(IN)    :: N
        real(kind=wp), intent(IN)    :: eta

        type(vector)  :: T, Ntmp
        real(kind=wp) :: c1, c2

        Ntmp = N

        c1 = (Ntmp .dot. I)
        if(c1 < 0._wp)then
            c1 = -c1
        else
            Ntmp = (-1._wp) * N
        end if
        c2 = sqrt(1._wp - (eta)**2 * (1._wp-c1**2))

        T = eta*I + (eta * c1 - c2) * Ntmp

        I = T

    end subroutine refract

    function fresnel(I, N, n1, n2) result (tir)
    !   calculates the fresnel coefficents
    !
    !
        use vector_class
        use ieee_arithmetic, only : ieee_is_nan

        implicit none

        real(kind=wp), intent(IN) :: n1, n2
        type(vector),  intent(IN) :: I, N

        real(kind=wp) :: costt, sintt, sint2, cost2, tir, f1, f2

        costt = abs(I .dot. N)

        sintt = sqrt(1._wp - costt * costt)
        sint2 = n1/n2 * sintt
        if(sint2 > 1._wp)then
            tir = 1.0_wp
            return
        elseif(costt == 1._wp)then
            tir = 0._wp
            return
        else
            sint2 = (n1/n2)*sintt
            cost2 = sqrt(1._wp - sint2 * sint2)
            f1 = abs((n1*costt - n2*cost2) / (n1*costt + n2*cost2))**2
            f2 = abs((n1*cost2 - n2*costt) / (n1*cost2 + n2*costt))**2

            tir = 0.5_wp * (f1 + f2)
        if(ieee_is_nan(tir) .or. tir > 1._wp .or. tir < 0._wp)print*,'TIR: ', tir, f1, f2, costt,sintt,cost2,sint2
            return
        end if
    end function fresnel
end module surfaces


program problem76
  implicit none
  integer :: i
  integer, dimension(100) :: memo

  ! https://oeis.org/A000041
  do i=1,100
     memo(i)=-1
  end do
  memo(1:10)=(/ 1, 2, 3, 5, 7, 11, 15, 22, 30, 42 /)

  print *, partitions(100)-1

contains

  pure function plus_minus(n)
    implicit none
    integer, intent(in) :: n
    integer             :: plus_minus

    plus_minus=(-1)**((n-1)/2)

  end function plus_minus

  ! https://oeis.org/A001318
  pure function pentagonal(n)
    implicit none
    integer, intent(in) :: n
    integer             :: pentagonal,m

    if (mod(n,2)==1) then
       m=1
    else
       m=-1
    end if
    m=m*(n+1)/2
    pentagonal=m*(3*m-1)/2

  end function pentagonal

  ! https://en.wikipedia.org/wiki/Partition_(number_theory)#Generating_function
  recursive function partitions(n) result(r)
    implicit none
    integer, intent(in) :: n
    integer             :: r,i

    if (n<0) then
       r=0
       return
    else if (n==0) then
       r=1
       return
    else if (memo(n)>-1) then
       r=memo(n)
       return
    else
       r=0
       i=1
       do while (pentagonal(i)<=n)
          r=r+plus_minus(i)*partitions(n-pentagonal(i))
          ! print *,r,i,plus_minus(i),pentagonal(i),partitions(n-pentagonal(i))
          i=i+1
       end do
       memo(n)=r
       return
    end if

  end function partitions

end program problem76


SUBROUTINE coord_r2sph (r , phi,lamda,radius)

! ----------------------------------------------------------------------
! SUBROUTINE: coord_r2sph.f90
! ----------------------------------------------------------------------
! Purpose:
! Geocentric spherical coordinates
!  Computation of the (geocentric) spherical coordinates i.e. longitude
!  and latitude, from position vector components (Cartesian coordinates)
! ----------------------------------------------------------------------
! Input arguments:
! - r:				Position vector  r = [x y z]
!
! Output arguments:
! - phi:			Latitude  (radians)
! - lamda:			Longitude (radians)
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia                July 2015
! ----------------------------------------------------------------------

      USE mdl_precision
      IMPLICIT NONE

! ---------------------------------------------------------------------------
! Dummy arguments declaration
! ---------------------------------------------------------------------------
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(3) :: r
      REAL (KIND = prec_q), INTENT(OUT) :: phi,lamda,radius
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
! Local variables declaration
! ---------------------------------------------------------------------------
      REAL (KIND = prec_q) :: x,y,z
! ---------------------------------------------------------------------------

! ---------------------------------------------------------------------------
      x = r(1)
      y = r(2)
      z = r(3)

      radius = sqrt(x**2 + y**2 + z**2)

! Phi computation: analytical
      phi = atan( z / sqrt(x**2 + y**2) )

! Lamda computation
      CALL arctan (y,x, lamda)
! ---------------------------------------------------------------------------

END


      subroutine wwdiv(ar, ai, br, bi, cr, ci, ierr)
*
*     PURPOSE
*        complex division algorithm : compute c := a / b
*        where :
*
*        a = ar + i ai
*        b = br + i bi
*        c = cr + i ci
*
*        inputs  : ar, ai, br, bi  (double precision)
*        outputs : cr, ci          (double precision)
*                  ierr  (integer) ierr = 1 if b = 0 (else 0)
*
*     IMPLEMENTATION NOTES
*        1/ Use scaling with ||b||_oo; the original wwdiv.f used a scaling
*           with ||b||_1.  It results fewer operations.  From the famous
*           Golberg paper.  This is known as Smith's method.
*        2/ Currently set c = NaN + i NaN in case of a division by 0 ;
*           is that the good choice ?
*
*     AUTHOR
*        Bruno Pincon <Bruno.Pincon@iecn.u-nancy.fr>
*
      implicit none

*     PARAMETERS
      double precision ar, ai, br, bi, cr, ci
      integer ierr

*     LOCAL VARIABLES
      double precision r, d

*     TEXT
      ierr = 0

*     Treat special cases
      if (bi .eq. 0d0) then
         if (br .eq. 0d0) then
            ierr = 1
*           got NaN + i NaN
            cr = bi / br
            ci = cr
         else
            cr = ar / br
            ci = ai / br
         endif
      elseif (br .eq. 0d0) then
         cr = ai / bi
         ci = (-ar) / bi
      else
*     Generic division algorithm
         if (abs(br) .ge. abs(bi)) then
            r = bi / br
            d = br + r*bi
            cr = (ar + ai*r) / d
            ci = (ai - ar*r) / d
         else
            r = br / bi
            d = bi + r*br
            cr = (ar*r + ai) / d
            ci = (ai*r - ar) / d
         endif
      endif

      end


!================================================================================
! ActII es un codigo para colocar particulas sobre una recta alternando entre po-
! sitvo y negativo segun la particula es par o impar.
! Autor: Martin Alejandro Paredes Sosa
!================================================================================
Program ActII
  Implicit None
  Real *4 :: sep, pos, neg, l
  Integer :: N, i !Numero de particulas , Contador

  !Datos de Entrada
  Write(*,*) "Ingrese el numero de puntos"
  Read(*,*) N
  Write(*,*) "Ingrese la longitud dode poner los puntos"
  Read(*,*) l

  !Separación entre partículas
  sep = l/real(N)

  Open(1, file="Out.dat")   !Abrir Archivo de Salida

  i=1 !Inicio Contador de la particula
  do while (i<=N)                                !Terminar al recorer cada particula
     pos=((-1)**i)*((int((i-1)/2)*sep)+ (sep/2) )!Calculo de Posicion
     write(1,*)i, pos                            !Escribir Valor En Archivo 1 (Out.dat)
     i = i+1                                     !Avance contador

  end do
  close(1)

End Program ActII

!======================================================================
!============== EXTRAS / INTENTOS DIFERENTES ==========================
!======================================================================

  !INTENTO DE COLOCAR UNA PARTICULA CENTRAL !! NO SE LOGRO
  !i=1
  !do while (i<=N)
  !   pos=((-1)**i)*((int((i-1-mod(N,2))/2)*sep)+ (sep*mod(N,2)/2) )
  !   write(*,*)i, pos
  !   i = i+1
  !end do

  !PRIMER INTENTO SE LOGRO REDUCIR
  !Incio de Contador
  !i=1
  !neg = (sep*(-1)) / 2  !Primera Posicion negativa
  !write(*,*) i,neg
  !i=i+1
  !pos = sep / 2         !Primera Posision positiva
  !write(*,*) i,pos
  !do while (i<=N-1)
  !   i = i + 1
  !   neg = neg - sep    !Calculo de los puntos del lado negativo (impares) Posicion
  !   write(*,*) i,neg
  !   if (i==N) exit     !Salida de Emergencia para N impar
  !   i = i + 1
  !   pos = pos + sep    !Calculo de los puntos del lado positivo (pares) Posicion
  !   write(*,*) i,pos
  !end do


program matrix_products

implicit none

interface
	subroutine mat_mul_1(mat_a,mat_b,mat_c)
		real*8, intent(out):: mat_c(:,:)
		real*8, intent(in):: mat_a(:,:), mat_b(:,:)
	end subroutine
end interface

interface
	subroutine mat_mul_2(mat_a,mat_b,mat_c)
		real*8, intent(out):: mat_c(:,:)
		real*8, intent(in):: mat_a(:,:), mat_b(:,:)
	end subroutine
end interface

real*8, allocatable :: A(:,:), B(:,:), C(:,:), D(:,:), E(:,:)
integer*4 :: iterations, max_N, ii, jj
real*4 :: start, finish
real*4, allocatable :: timing(:,:)

write(*,*) "Enter the timing iterations and up to how many rows the test matrices should have"
read(*,*) iterations, max_N

! Allocate the timing array
allocate(timing(2:max_N,0:3))

! Generating two square random matrices, from 2 x 2 to max_N x max_n
do ii = 2, max_N
	! "input size"
	timing(ii,0) = ii

	! Allocate all the matrices using the new size
	allocate(A(1:ii,1:ii))
	allocate(B(1:ii,1:ii))
	allocate(D(1:ii,1:ii))
	allocate(E(1:ii,1:ii))
	allocate(C(1:ii,1:ii))

	! Populate the arrays with uniformly distributed values
	call random_number(A)
	call random_number(B)

	!----------------------
	!    Timing products
	!----------------------
	! Measuring performance of the first product definition
	call cpu_time(start)
	do jj = 1, iterations
		call mat_mul_1(A,B,C)
	end do
	call cpu_time(finish)
	timing(ii,1) = (finish-start)/iterations

	! Measuring performance of the second product definition
	! Transposing and storing before entering the timing loop
	D = transpose(B)
	E = transpose(A)
	call cpu_time(start)
	do jj = 1, iterations
		call mat_mul_2(D,E,C) ! This gives us C transpose
	end do
	call cpu_time(finish)
	timing(ii,2) = (finish-start)/iterations

	! Measuring performance of built-in product definition
	call cpu_time(start)
	do jj = 1, iterations
		C = matmul(A,B)
	end do
	call cpu_time(finish)
	timing(ii,3) = (finish-start)/iterations

	! Release the variables for the incoming allocation
	deallocate(A)
	deallocate(B)
	deallocate(D)
	deallocate(E)
	deallocate(C)
end do

open(15,file = "performance.dat")
! Write the performance measurements
do ii = 2, max_N
	write(15,*) timing(ii,0:3)
end do
close(15)

end program matrix_products

subroutine mat_mul_1(mat_a,mat_b,mat_c)
	implicit none
	real*8, intent(in):: mat_a(:,:), mat_b(:,:)
	real*8, intent(out) :: mat_c(:,:)
	integer*4:: M,N,O,P,ii,jj,kk
	real*8:: cumulative
	integer*4:: shape_a(2), shape_b(2)

	shape_a = shape(mat_a)
	shape_b = shape(mat_b)
	M = shape_a(1)
	N = shape_a(2)
	O = shape_b(1)
	P = shape_b(2)

	do ii = 1,M
		do jj = 1, P
			cumulative = 0.d0
			do kk = 1, N
				cumulative = cumulative + mat_a(ii,kk)*mat_b(kk,jj)
			end do
			mat_c(ii,jj) = cumulative
		end do
	end do

end subroutine

subroutine mat_mul_2(mat_a,mat_b, mat_c)
	implicit none
	real*8, intent(in):: mat_a(:,:), mat_b(:,:)
	real*8, intent(out) :: mat_c(:,:)
	integer*4:: M,N,O,P,ii,jj,kk
	real*8:: cumulative
	integer*4:: shape_a(2), shape_b(2)

	shape_a = shape(mat_a)
	shape_b = shape(mat_b)
	M = shape_a(1)
	N = shape_a(2)
	O = shape_b(1)
	P = shape_b(2)

	do jj = 1,P
		do ii = 1, M
			cumulative = 0.d0
			do kk = 1, N
				cumulative = cumulative + mat_a(ii,kk)*mat_b(kk,jj)
			end do
			mat_c(ii,jj) = cumulative
		end do
	end do

end subroutine


module mod_inv
#include <messenger.h>
    use mod_kinds,       only: rk,ik,rdouble,rsingle
    use mod_constants,   only: ONE
    use mod_determinant, only: det_3x3

    implicit none
    ! External procedures defined in LAPACK
    external DGETRI
    external DGETRF
    external DGECON
    external DLANGE
    external SGETRI
    external SGETRF
    external SGECON
    external SLANGE
    real(rdouble) :: DLANGE
    real(rsingle) :: SLANGE

contains

    !>  Compute and return the inverse of a 3x3 matrix.
    !!
    !!  This implements an explicit formula for inverting a 3x3 matrix.
    !!      See: http://mathworld.wolfram.com/MatrixInverse.html
    !!
    !!  @author Nathan A. Wukie (AFRL)
    !!  @date   8/14/2017
    !!
    !---------------------------------------------------------------------------
    function inv_3x3(A) result(Ainv)
        real(rk),   intent(in)    :: A(3,3)

        real(rk)    :: Ainv(3,3), det

        det = det_3x3(A)

        Ainv(1,1) = ONE/det * (A(2,2)*A(3,3) - A(2,3)*A(3,2))
        Ainv(1,2) = ONE/det * (A(1,3)*A(3,2) - A(1,2)*A(3,3))
        Ainv(1,3) = ONE/det * (A(1,2)*A(2,3) - A(1,3)*A(2,2))

        Ainv(2,1) = ONE/det * (A(2,3)*A(3,1) - A(2,1)*A(3,3))
        Ainv(2,2) = ONE/det * (A(1,1)*A(3,3) - A(1,3)*A(3,1))
        Ainv(2,3) = ONE/det * (A(1,3)*A(2,1) - A(1,1)*A(2,3))

        Ainv(3,1) = ONE/det * (A(2,1)*A(3,2) - A(2,2)*A(3,1))
        Ainv(3,2) = ONE/det * (A(1,2)*A(3,1) - A(1,1)*A(3,2))
        Ainv(3,3) = ONE/det * (A(1,1)*A(2,2) - A(1,2)*A(2,1))

    end function inv_3x3
    !***************************************************************************

    !> Returns the inverse of a matrix calculated by finding the LU
    !! decomposition.  Depends on LAPACK.
    !!
    !!
    !!
    !!
    !!
    !---------------------------------------------------------------------------
    function inv(A) result(Ainv)
        real(rk), dimension(:,:),               intent(inout)   :: A
        real(rk), dimension(size(A,1),size(A,2))                :: Ainv

        real(rk), dimension(size(A,1))   :: work    ! work array for LAPACK
        integer,  dimension(size(A,1))   :: ipiv    ! pivot indices
        integer :: n, info

        ! Store A in Ainv to prevent it from being overwritten by LAPACK
        Ainv = A
        n = size(A,1)

        !
        ! DGETRF computes an LU factorization of a general M-by-N matrix A
        ! using partial pivoting with row interchanges.
        !
        if ( rk == rdouble ) then
            call DGETRF(n, n, Ainv, n, ipiv, info)
        else if ( rk == rsingle ) then
            call SGETRF(n, n, Ainv, n, ipiv, info)
        else
            call chidg_signal(FATAL,"inv: Invalid selected precision for matrix inversion.")
        end if

        if (info /= 0) then
            call chidg_signal(FATAL,"inv: Matrix is numerically singular!")
        end if

        !
        ! DGETRI computes the inverse of a matrix using the LU factorization
        ! computed by DGETRF.
        !
        if ( rk == rdouble ) then
            call DGETRI(n, Ainv, n, ipiv, work, n, info)
        else if ( rk == rsingle ) then
            call SGETRI(n, Ainv, n, ipiv, work, n, info)
        else
            call chidg_signal(FATAL,"inv: Invalid selected precision for matrix inversion.")
        end if

        if (info /= 0) then
            call chidg_signal(FATAL,"inv: matrix inversion failed!.")
        end if

    end function inv
    !**************************************************************************************

end module mod_inv


	FUNCTION PR_TMFK  ( tmpf )
C************************************************************************
C* PR_TMFK								*
C*									*
C* This function computes TMPK from TMPF.  The following equation is	*
C* used:								*
C*									*
C*           TMPK = ( TMPF - 32 ) * 5 / 9 + TMCK			*
C*									*
C* REAL PR_TMFK  ( TMPF )						*
C*									*
C* Input parameters:							*
C*	TMPF		REAL		Temperature in Fahrenheit	*
C*									*
C* Output parameters:							*
C*	PR_TMFK		REAL		Temperature in Kelvin		*
C**									*
C* Log:									*
C* M. Goodman/RDS	 8/84	Original source				*
C* I. Graffman/RDS	12/84	Modified equation			*
C* M. desJardins/GSFC	 4/86	Added PARAMETER statement		*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	 8/88	Modified documentation			*
C* G. Krueger/EAI        4/96   Replaced C->K constant with TMCK	*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ERMISS ( tmpf ) )  THEN
	    PR_TMFK = RMISSD
	  ELSE
	    tmpc = PR_TMFC ( tmpf )
	    PR_TMFK = PR_TMCK ( tmpc )
	END IF
C*
	RETURN
	END


! { dg-do "run" }

  INTEGER            :: i
  INTEGER, PARAMETER :: m(4,4) = RESHAPE([ (i, i=1, 16) ], [4, 4] )
  INTEGER, PARAMETER :: sevens = COUNT (m == 7)
  INTEGER, PARAMETER :: odd(4) = COUNT (MOD(m, 2) == 1, dim=1)
  INTEGER, PARAMETER :: even = COUNT (MOD(m, 2) == 0)

  IF (sevens /= 1) CALL abort()
  IF (ANY(odd /= [ 2,2,2,2 ])) CALL abort()
  IF (even /= 8) CALL abort()

  ! check the kind parameter
  IF (KIND(COUNT (m == 7, KIND=2)) /= 2) CALL abort()
END


subroutine allencahn_fort_rhs(blockno, mbc,mx,my,meqn,mfields, &
                         xlower,ylower,dx,dy,dt, method,q,rhs)
    IMPLICIT NONE

    INTEGER mbc,mx,my, mfields, meqn, method
    DOUBLE PRECISION xlower,ylower,dx,dy, dt
    DOUBLE PRECISION rhs(1-mbc:mx+mbc,1-mbc:my+mbc,mfields)
    DOUBLE PRECISION q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

    INTEGER i,j, blockno
    DOUBLE PRECISION lambda, D, u

    lambda = -1.d0/dt

    D = 0.001d0

    do j = 1,my
        do i = 1,mx
            u = q(i,j,1)
            rhs(i,j,1) = lambda*u - (u-u**3)/D**2
        end do
    end do

end subroutine allencahn_fort_rhs

subroutine allencahn_update_q(mbc,mx,my,meqn,mfields,rhs,q)
    IMPLICIT NONE

    INTEGER mbc,mx,my, mfields, meqn
    DOUBLE PRECISION rhs(1-mbc:mx+mbc,1-mbc:my+mbc,mfields)
    DOUBLE PRECISION q(1-mbc:mx+mbc,1-mbc:my+mbc,meqn)

    INTEGER i,j

    do j = 1-mbc,my+mbc
        do i = 1-mbc,mx+mbc
            q(i,j,1) = rhs(i,j,1)
        end do
    end do
!!100 format(2F16.8)

end subroutine allencahn_update_q


subroutine matgen(imat, a, n, info)
  implicit none

  real(kind(1.d0)), allocatable :: a(:,:)
  integer :: imat, n, info

  real(kind(1.d0)), allocatable :: work(:), d(:)
  character(len=3) :: path
  character :: type, dist
  integer :: kl, ku, mode
  real(kind(1.d0)) :: anorm, cndnum, rcondc
  integer :: iseed(4)
  real(kind(1.d0)), parameter :: done=1.d0, dmone=-1.d0

  !ehouarn
  integer :: i,j
  double precision :: eps, norme_f
  intrinsic epsilon
  !ehouarn

  iseed = (/1988, 1989, 1990, 1991/)
  info  = 0
  path(1:1) = 'Double precision'
  path(2:3) = 'GE'

  select case(imat)
  case(1:11)
     call dlatb4( path, imat, n, n, type, kl, ku, anorm, mode, cndnum, dist )
     rcondc = 1.d0 / cndnum

     write(*,'("=======================")')
     ! write(*,'("Type  : ",a1)')type
     ! write(*,'("KL    : ",i4)')kl
     ! write(*,'("KL    : ",i4)')ku
     write(*,'("Anorm : ",es10.3)')anorm
     write(*,'("Cond  : ",es10.3)')cndnum
  write(*,'(" ")')

     allocate(a(n,n), work(3*n), d(n), stat=info)
     if(info .ne. 0) return

     call dlatms( n, n, dist, iseed, type, &
          & d, mode, cndnum, anorm, kl, ku, &
          & 'no packing', a, n, work, info )
     if(info .ne. 0) return

     deallocate(d, work, stat=info)
  case(12)
      !write(*,'("Generate matrix with bad determinant")')
      !info = 1  ! to remove when the generator is implemented
      write(*,'("Generate numerically singular matrix ")')
      call dlatb4( path, 8, n, n, type, kl, ku, anorm, mode, cndnum, dist )
      rcondc = 1.d0 / cndnum

      write(*,'("=======================")')
      ! write(*,'("Type  : ",a1)')type
      ! write(*,'("KL    : ",i4)')kl
      ! write(*,'("KL    : ",i4)')ku
      write(*,'("Anorm : ",es10.3)')anorm
      write(*,'("Cond  : ",es10.3)')cndnum
      write(*,'(" ")')

      allocate(a(n,n), work(3*n), d(n), stat=info)
      if(info .ne. 0) return

      call dlatms( n, n, dist, iseed, type, &
          & d, mode, cndnum, anorm, kl, ku, &
          & 'no packing', a, n, work, info )
      if(info .ne. 0) return

      deallocate(d, work, stat=info)

      eps=epsilon(eps)
      a(:,1)=eps*a(:,1)
      if(n.gt.5)then
        i=(n+1)/2
        a(:,i)=eps*a(:,i)
      endif
      a(:,n)=eps*a(:,n)

  case default
     write(*,'("Wrong matrix id")')
     info = 1
  end select

  return
end subroutine matgen


C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C     *                                                               *
C     *                  copyright (c) 1999 by UCAR                   *
C     *                                                               *
C     *       UNIVERSITY CORPORATION for ATMOSPHERIC RESEARCH         *
C     *                                                               *
C     *                      all rights reserved                      *
C     *                                                               *
C     *                      FISHPACK version 4.1                     *
C     *                                                               *
C     *     A PACKAGE OF FORTRAN SUBPROGRAMS FOR THE SOLUTION OF      *
C     *                                                               *
C     *      SEPARABLE ELLIPTIC PARTIAL DIFFERENTIAL EQUATIONS        *
C     *                                                               *
C     *                             BY                                *
C     *                                                               *
C     *        JOHN ADAMS, PAUL SWARZTRAUBER AND ROLAND SWEET         *
C     *                                                               *
C     *                             OF                                *
C     *                                                               *
C     *         THE NATIONAL CENTER FOR ATMOSPHERIC RESEARCH          *
C     *                                                               *
C     *                BOULDER, COLORADO  (80307)  U.S.A.             *
C     *                                                               *
C     *                   WHICH IS SPONSORED BY                       *
C     *                                                               *
C     *              THE NATIONAL SCIENCE FOUNDATION                  *
C     *                                                               *
C     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
C
C     PROGRAM TO ILLUSTRATE THE USE OF SUBROUTINE POISTG TO
C     SOLVE THE EQUATION
C
C     (1/COS(X))(D/DX)(COS(X)(DU/DX)) + (D/DY)(DU/DY) =
C
C           2*Y**2*(6-Y**2)*SIN(X)
C
C     ON THE RECTANGLE -PI/2 .LT. X .LT. PI/2 AND
C     0 .LT. Y .LT. 1 WITH THE BOUNDARY CONDITIONS
C
C     (DU/DX) (-PI/2,Y) = (DU/DX)(PI/2,Y) = 0 , 0 .LE. Y .LE. 1  (2)
C
C     U(X,0) = 0                                           (3)
C                                 -PI/2 .LE. X .LE. PI/2
C     (DU/DY)(X,1) = 4SIN(X)                               (4)
C
C     USING FINITE DIFFERENCES ON A STAGGERED GRID WITH
C     DELTAX (= DX) = PI/40 AND DELTAY (= DY) = 1/20 .
C        TO SET UP THE FINITE DIFFERENCE EQUATIONS WE DEFINE
C     THE GRID POINTS
C
C     X(I) = -PI/2 + (I-0.5)DX            I=1,2,...,40
C
C     Y(J) = (J-O.5)DY                    J=1,2,...,20
C
C     AND LET V(I,J) BE AN APPROXIMATION TO U(X(I),Y(J)).
C     NUMBERING THE GRID POINTS IN THIS FASHION GIVES THE SET
C     OF UNKNOWNS AS V(I,J) FOR I=1,2,...,40 AND J=1,2,...,20.
C     HENCE, IN THE PROGRAM M = 40 AND N = 20.  AT THE INTERIOR
C     GRID POINT (X(I),Y(J)), WE REPLACE ALL DERIVATIVES IN
C     EQUATION (1) BY SECOND ORDER CENTRAL FINITE DIFFERENCES,
C     MULTIPLY BY DY**2, AND COLLECT COEFFICIENTS OF V(I,J) TO
C     GET THE FINITE DIFFERENCE EQUATION
C
C     A(I)V(I-1,J) + B(I)V(I,J) + C(I)V(I+1,J)
C
C     + V(I,J-1) - 2V(I,J) + V(I,J+1) = F(I,J)            (5)
C
C     WHERE S = (DY/DX)**2, AND FOR I=2,3,...,39
C
C     A(I) = S*COS(X(I)-DX/2)
C
C     B(I) = -S*(COS(X(I)-DX/2)+COS(X(I)+DX/2))
C
C     C(I) = S*COS(X(I)+DX/2)
C
C     F(I,J) = 2DY**2*Y(J)**2*(6-Y(J)**2)*SIN(X(I)) , J=1,2,...,19.
C
C        TO OBTAIN EQUATIONS FOR I = 1, WE REPLACE EQUATION (2)
C     BY THE SECOND ORDER APPROXIMATION
C
C     (V(1,J)-V(0,J))/DX = 0
C
C     AND USE THIS EQUATION TO ELIMINATE V(0,J) IN EQUATION (5)
C     TO ARRIVE AT THE EQUATION
C
C     B(1)V(1,J) + C(1)V(2,J) + V(1,J-1) - 2V(1,J) + V(1,J+1)
C
C                       = F(1,J)
C
C     WHERE
C
C     B(1) = -S*(COS(X(1)-DX/2)+COS(X(1)+DX/2))
C
C     C(1) = -B(1)
C
C     FOR COMPLETENESS, WE SET A(1) = 0.
C        TO OBTAIN EQUATIONS FOR I = 40, WE REPLACE THE DERIVATIVE
C     IN EQUATION (2) AT X=PI/2 IN A SIMILAR FASHION, USE THIS
C     EQUATION TO ELIMINATE THE VIRTUAL UNKNOWN V(41,J) IN EQUATION
C     (5) AND ARRIVE AT THE EQUATION
C
C     A(40)V(39,J) + B(40)V(40,J)
C
C     + V(40,J-1) - 2V(40,J) + V(40,J+1) = F(40,J)
C
C     WHERE
C
C     A(40) = -B(40) = -S*(COS(X(40)-DX/2)+COS(X(40)+DX/2))
C
C     FOR COMPLETENESS, WE SET C(40) = 0.  HENCE, IN THE
C     PROGRAM MPEROD = 1.
C        FOR J = 1, WE REPLACE EQUATION (3) BY THE SECOND ORDER
C     APPROXIMATION
C
C                (V(I,0) + V(I,1))/2 = 0
C
C     TO ARRIVE AT THE CONDITION
C
C                V(I,0) = -V(I,1) .
C
C     FOR J = 20, WE REPLACE EQUATION (4) BY THE SECOND ORDER
C     APPROXIMATION
C
C                (V(I,21) - V(I,20))/DY = 4*SIN(X)
C
C     AND COMBINE THIS EQUATION WITH EQUATION (5) TO ARRIVE AT
C     THE EQUATION
C
C     A(I)V(I-1,20) + B(I)V(I,20) + C(I)V(I+1,20)
C
C     + V(I,19) - 2V(I,20) + V(I,21) = F(I,20)
C
C     WHERE
C
C     V(I,21) = V(I,20)  AND
C
C     F(I,20) = 2*DY**2*Y(J)**2*(6-Y(J)**2)*SIN(X(I)) - 4*DY*SIN(X(I))
C
C     HENCE, IN THE PROGRAM NPEROD = 2 .
C        THE EXACT SOLUTION TO THIS PROBLEM IS
C
C        U(X,Y) = Y**4*COS(X) .
C
      DIMENSION       F(42,20)   ,A(40)      ,B(40)      ,C(40)      ,
     1                W(600)     ,X(40)      ,Y(20)
C
C     FROM DIMENSION STATEMENT WE GET VALUE OF IDIMF = 42.  ALSO
C     NOTE THAT W HAS BEEN DIMENSIONED
C     9M + 4N + M(INT(LOG2(N))) = 360 + 80 + 160 = 600 .
C
      IDIMF = 42
      MPEROD = 1
      M = 40
      PI = PIMACH(DUM)
      DX = PI/FLOAT(M)
      NPEROD = 2
      N = 20
      DY = 1./FLOAT(N)
C
C     GENERATE AND STORE GRID POINTS FOR COMPUTATION.
C
      DO 101 I=1,M
         X(I) = -PI/2.+(FLOAT(I)-0.5)*DX
  101 CONTINUE
      DO 102 J=1,N
         Y(J) = (FLOAT(J)-0.5)*DY
  102 CONTINUE
C
C     GENERATE COEFFICIENTS .
C
      S = (DY/DX)**2
      A(1) = 0.
      B(1) = -S*COS(-PI/2.+DX)/COS(X(1))
      C(1) = -B(1)
      DO 103 I=2,M
         A(I) = S*COS(X(I)-DX/2.)/COS(X(I))
         C(I) = S*COS(X(I)+DX/2.)/COS(X(I))
         B(I) = -(A(I)+C(I))
  103 CONTINUE
      A(40) = -B(40)
      C(40) = 0.
C
C     GENERATE RIGHT SIDE OF EQUATION.
C
      DO 105 I=1,M
         DO 104 J=1,N
            F(I,J) = 2.*DY**2*Y(J)**2*(6.-Y(J)**2)*SIN(X(I))
  104    CONTINUE
  105 CONTINUE
      DO 106 I=1,M
         F(I,N) = F(I,N)-4.*DY*SIN(X(I))
  106 CONTINUE
      CALL POISTG (NPEROD,N,MPEROD,M,A,B,C,IDIMF,F,IERROR,W)
C
C     COMPUTE DISCRETIZATION ERROR.  THE EXACT SOLUTION IS
C
C     U(X,Y) = Y**4*SIN(X)
C
      ERR = 0.
      DO 108 I=1,M
         DO 107 J=1,N
            T = ABS(F(I,J)-Y(J)**4*SIN(X(I)))
            IF (T .GT. ERR) ERR = T
  107    CONTINUE
  108 CONTINUE
      PRINT 1001 , IERROR,ERR,W(1)
      STOP
C
 1001 FORMAT (1H1,20X,25HSUBROUTINE POISTG EXAMPLE///
     1        10X,46HTHE OUTPUT FROM THE NCAR CONTROL DATA 7600 WAS//
     2        32X,10HIERROR = 0/
     3        18X,34HDISCRETIZATION ERROR = 5.64171E-04/
     4        12X,32HREQUIRED LENGTH OF W ARRAY = 560//
     5        10X,32HTHE OUTPUT FROM YOUR COMPUTER IS//
     6        32X,8HIERROR =,I2/18X,22HDISCRETIZATION ERROR =,E12.5/
     7        12X,28HREQUIRED LENGTH OF W ARRAY =,F4.0)
C
      END


      SUBROUTINE avevar(data,n,ave,var)
      INTEGER n
      REAL ave,var,data(n)
      INTEGER j
      REAL s,ep
      ave=0.0
      do 11 j=1,n
        ave=ave+data(j)
11    continue
      ave=ave/n
      var=0.0
      ep=0.0
      do 12 j=1,n
        s=data(j)-ave
        ep=ep+s
        var=var+s*s
12    continue
      var=(var-ep**2/n)/(n-1)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/avevar.for


C     LAST UPDATE 10/12/92
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE SVDFIT(X,Y,SIG,NDATA,A,MA,U,V,W,MP,NP,CHISQ,FUNCS)
      IMPLICIT NONE
C
C Purpose: Performs linear least squares given a set of NDATA points
C          X(I),Y(I) with individual standard deviations SIG(I) to
C          determine the MA coefficients of A of the fitting function
C          y = sum j {Aj * AFUNCj(x)} by singular value decomposition.
C          of the NDATA by MA matrix. Arrays U,V,W provide workspace
C          on input, on output they define the singular value
C          decomposition and can be used to obtain the covariance
C          matrix. MP,NP are the physical dimensions of the matrices
C          U,V,W . It is necessary that MP>=NDATA, NP>=MA. The program
C          returns values for the MA fit parameters A and CHISQ.
C          The user supplied subroutine FUNCS(X,AFUNC,MA) returns the
C          MA basis functions evaluated at x = X in the array AFUNC.
C
      INTEGER NDATA,MA,MP,NP
      REAL X(NDATA),Y(NDATA),SIG(NDATA)
      REAL A(MA),V(NP,NP),U(MP,NP),W(NP)
      REAL CHISQ
C
C Calls   2: SVDVAR , FUNCS
C Called by:
C
      EXTERNAL FUNCS
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C Local variables:
C
      INTEGER NMAX,MMAX
      REAL TOL
      PARAMETER(NMAX=1000,MMAX=50,TOL=1.0E-05)
      REAL B(NMAX),AFUNC(MMAX)
      REAL THRESH,WMAX,SUM,TMP
      INTEGER I,J
C
C---------------------------------------------------------------------
      DO 20 I=1,NDATA
         CALL FUNCS(X(I),AFUNC,MA)
         TMP = 1.0/SIG(I)
         DO 10 J=1,MA
            U(I,J) = AFUNC(J)*TMP
 10      CONTINUE
         B(I) = Y(I)*TMP
 20   CONTINUE
      CALL SVDCMP(U,NDATA,MA,MP,NP,W,V)
      WMAX = 0.0
      DO 30 J=1,MA
         IF(W(J).GT.WMAX)WMAX = W(J)
 30   CONTINUE
      THRESH = TOL*WMAX
      DO 40 J=1,MA
         IF(W(J).LT.THRESH)W(J) = 0.0
 40   CONTINUE
      CALL SVBKSB(U,W,V,NDATA,MA,MP,NP,B,A)
      CHISQ = 0.0
      DO 60 I=1,NDATA
         CALL FUNCS(X(I),AFUNC,MA)
         SUM = 0.0
         DO 50 J=1,MA
            SUM = SUM + A(J)*AFUNC(J)
 50      CONTINUE
         CHISQ = CHISQ + ((Y(I)-SUM)/SIG(I))**2
 60   CONTINUE
      RETURN
      END


program bisection_method
implicit none

real(kind=8) :: A, B, eps, root, maximum, minimum
integer :: iters

write(*,*) 'number?'
read(*,*) A

B = abs(A) !in case it's a negative number
if (B .ge. 1) then
   maximum = B
else if (B .lt. 1) then
   maximum = 1
end if
minimum = 0.0

eps = 0.00000000000001
iters = 0
do while (abs(B-root*root) .ge. eps)
   root = minimum + (maximum - minimum)/2.0d0
   iters = iters + 1
   write(*,*) iters, root, abs(B-root*root)
   if (root*root .gt. B) then
      maximum = root
   else if (root*root .lt. B) then
      minimum = root
   end if
end do

write(*,*) 'number of iterations:', iters
if (A .ge. 0.0d0)  then
   write(*,*) root
else
   write(*,*) root, 'i' ! because the result is imaginary for a negative A
end if

end program bisection_method


!##############################################################################
! PROGRAM Arrays
!
! ## Use do-loops to fill up arrays with values
!
! 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 Arrays

    implicit none
    real*8 :: x(0:10), y(0:10)
    integer :: j

    ! initialize x and calculate y
    do j = 0, 10
        x(j) = 1d0/10d0*dble(j)
        y(j) = exp(x(j))
    enddo

    ! output table of values
    write(*,'(a)')'         X         Y'
    do j = 0, 10
        write(*,'(2f10.3)')x(j), y(j)
    enddo

end program


program main
  ! Default
  implicit none

  ! Parameters
  integer(8) :: targ = 600851475143

  ! Variables
  integer(8) :: i,max_fac,max_try

  ! Determine maximum value we should try
  max_try = int(sqrt(1D0*targ))

  max_fac = 1
  do i=2,max_try
     ! Check that i is a factor of the number
     if (mod(targ,i)==0) then
        ! Now check to see if i is prime
        if (is_prime(i)) then
           max_fac = i
        endif
     endif
  enddo

  ! Write out answer
  write(*,*) "Max factor: ",max_fac

contains

  pure function is_prime(targ)
    ! Default
    implicit none

    ! Function arguments
    integer(8), intent(in) :: targ
    logical                :: is_prime

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

    ! Find the max we should try
    max_try = int(sqrt(1D0*targ))

    do i=2,max_try
       if (mod(targ,i)==0) then
          is_prime = .false.
          return
       endif
    enddo

    is_prime = .true.
    return
  end function is_prime

end program main


      subroutine mapc2m_torus(blockno,xc,yc,xp,yp,zp,alpha, beta)
      implicit none

      integer blockno
      double precision xc,yc,xp,yp,zp
      double precision alpha, beta, r1, R

      double precision pi, pi2
      common /compi/ pi, pi2

      r1 = alpha*(1 + beta*sin(pi2*xc))
      R = 1 + r1*cos(pi2*yc)

      xp = R*cos(pi2*xc)
      yp = R*sin(pi2*xc)
      zp = r1*sin(pi2*yc)

      end


module fit

implicit none

contains
!----------------------------------------------------
subroutine linear_polynom_fit(n,x,y,p1,p2)

implicit none
integer, intent(in)             :: n
double precision, intent(in)    :: x(n), y(n)
double precision, intent(out)   :: p1, p2
!----------------------------------------------------
double precision                :: sumx, sumy, sumx2, sumxy

sumx = 0.0d0
sumy = 0.0d0
sumx2 = 0.0d0
sumxy = 0.0d0

sumx = sum(x)
sumy = sum(y)
sumx2 = sum(x**2)
sumxy = sum(x*y)

p1 = (n*sumxy - sumx*sumy)/(n*sumx2 - sumx**2)
p2 = (sumy - p1*sumx)/n

end subroutine
!----------------------------------------------------
subroutine quadr_polynom_fit(n,x,y,p1,p2,p3)

implicit none
integer, intent(in)             :: n
double precision, intent(in)    :: x(n), y(n)
double precision, intent(out)   :: p1, p2, p3
!----------------------------------------------------
double precision                :: S1,S2,S3,S4,Sy0,Sy1,Sy2
double precision                :: A(3,3),B(3)
integer                         :: info,lwork,ipiv(3)
double precision                :: work(3)
!----------------------------------------------------

A = 0.0d0
B = 0.0d0

S1 = 0.0d0
S2 = 0.0d0
S3 = 0.0d0
S4 = 0.0d0
Sy0 = 0.0d0
Sy1 = 0.0d0
Sy2 = 0.0d0

S1 = sum(x)
S2 = sum(x*x)
S3 = sum(x*x*x)
S4 = sum(x*x*x*x)

Sy0 = sum(y)
Sy1 = sum(y*x)
Sy2 = sum(y*x*x)

A(1,:) = (/S4, S3, S2/)
A(2,:) = (/S3, S2, S1/)
A(3,:) = (/S2, S1, dble(n)/)

B(:) = (/Sy2, Sy1, Sy0/)

! ==== Calculate inverse of matrix A ==== !

call dgetrf(3,3,A,3,ipiv,info)
lwork = size(work)
call dgetri(3,A,3,ipiv,work,lwork,info)

p1 = dot_product(A(1,:),B)
p2 = dot_product(A(2,:),B)
p3 = dot_product(A(3,:),B)

end subroutine
!----------------------------------------------------
subroutine cubic_polynom_fit(n,x,y,p1,p2,p3,p4)

implicit none
integer, intent(in)             :: n
double precision, intent(in)    :: x(n), y(n)
double precision, intent(out)   :: p1,p2,p3,p4
!----------------------------------------------------
double precision                :: S1,S2,S3,S4,S5,S6
double precision                :: Sy0,Sy1,Sy2,Sy3
double precision                :: A(4,4),B(4)
integer                         :: info,lwork,ipiv(4)
double precision                :: work(4)
!----------------------------------------------------

A = 0.0d0
B = 0.0d0

S1 = sum(x)
S2 = sum(x*x)
S3 = sum(x*x*x)
S4 = sum(x*x*x*x)
S5 = sum(x*x*x*x*x)
S6 = sum(x*x*x*x*x*x)

Sy0 = sum(y)
Sy1 = sum(y*x)
Sy2 = sum(y*x*x)
Sy3 = sum(y*x*x*x)

A(1,:) = (/S6, S5, S4, S3/)
A(2,:) = (/S5, S4, S3, S2/)
A(3,:) = (/S4, S3, S2, S1/)
A(4,:) = (/S3, S2, S1, dble(n)/)

B(:) = (/Sy3, Sy2, Sy1, Sy0/)

! ==== Calculate inverse of matrix A ==== !

call dgetrf(4,4,A,4,ipiv,info)
lwork = size(work)
call dgetri(4,A,4,ipiv,work,lwork,info)

p1 = dot_product(A(1,:),B)
p2 = dot_product(A(2,:),B)
p3 = dot_product(A(3,:),B)
p4 = dot_product(A(4,:),B)

end subroutine
!----------------------------------------------------
subroutine quart_polynom_fit(n,x,y,p1,p2,p3,p4,p5)

implicit none
integer, intent(in)             :: n
double precision, intent(in)    :: x(n), y(n)
double precision, intent(out)   :: p1,p2,p3,p4,p5
!----------------------------------------------------
double precision                :: S1,S2,S3,S4,S5,S6
double precision                :: S7,S8,Sy0,Sy1,Sy2
double precision                :: Sy3,Sy4
double precision                :: A(5,5),B(5)
integer                         :: info,lwork,ipiv(5)
double precision                :: work(5)
!----------------------------------------------------

A = 0.0d0
B = 0.0d0

S1 = sum(x)
S2 = sum(x*x)
S3 = sum(x*x*x)
S4 = sum(x*x*x*x)
S5 = sum(x*x*x*x*x)
S6 = sum(x*x*x*x*x*x)
S7 = sum(x*x*x*x*x*x*x)
S8 = sum(x*x*x*x*x*x*x*x)

Sy0 = sum(y)
Sy1 = sum(y*x)
Sy2 = sum(y*x*x)
Sy3 = sum(y*x*x*x)
Sy4 = sum(y*x*x*x*x)

A(1,:) = (/S8, S7, S6, S5, S4/)
A(2,:) = (/S7, S6, S5, S4, S3/)
A(3,:) = (/S6, S5, S4, S3, S2/)
A(4,:) = (/S5, S4, S3, S2, S1/)
A(5,:) = (/S4, S3, S2, S1, dble(n)/)

B(:) = (/Sy4, Sy3, Sy2, Sy1, Sy0/)

! ==== Calculate inverse of matrix A ==== !

call dgetrf(5,5,A,5,ipiv,info)
lwork = size(work)
call dgetri(5,A,5,ipiv,work,lwork,info)

p1 = dot_product(A(1,:),B)
p2 = dot_product(A(2,:),B)
p3 = dot_product(A(3,:),B)
p4 = dot_product(A(4,:),B)
p5 = dot_product(A(5,:),B)

end subroutine
!-------------------------
end module


FUNCTION declination(idoy)
!
IMPLICIT NONE
!
INCLUDE 'p1unconv.inc'
!
! Function arguments
!
INTEGER :: idoy
REAL :: declination
!
! Local variables
!
REAL :: b
!
!     + + + purpose + + +
!     this function calculates the declination of the earth with respect
!     the sun based on the day of the year

!     + + + keywords + + +
!     solar declination

!     + + + argument declarations + + +

!     + + + argument definitions + + +
!     idoy   - day of year

!     + + + local varaibles + + +

!     + + + local definitions + + +
!     b      - sub calculation (time of year, radians)

!     + + + common blocks + + +

!     + + + end specifications + + +

!     calculate declination angle (dec)
!
b = (360.0/365.0)*(idoy-81.25)*degtorad
declination = 23.45*sin(b)
!
END FUNCTION declination

Project Documents/Source Code Original/Declination.f90


module m_maths
  !! Math routines
  use variableKind
  use m_allocate, only: allocate
  use m_deallocate, only: deallocate
  use m_errors, only: eMsg, msg
  use m_sort, only: argsort
  use m_select, only: argSelect
  use m_array1D, only: arange
  use m_unitTester, only: tester
  implicit none

  private

  public :: crossproduct
  interface crossproduct
    !! Compute the cross product between two arrays of length 2 or 3
    module function crossproduct_r1D(a,b) result(res)
      !! Interfaced with crossproduct()
      real(r32),intent(in) :: a(3) !! 1D Array
      real(r32),intent(in) :: b(3) !! 1D Array
      real(r32) :: res(3) !! cross product
    end function
    module function crossproduct_d1D(a,b) result(res)
      !! Interfaced with crossproduct()
      real(r64),intent(in) :: a(3) !! 1D Array
      real(r64),intent(in) :: b(3) !! 1D Array
      real(r64) :: res(3) !! cross product
    end function
  end interface

  public :: cumprod
  interface cumprod
    !! Compute the variance of an array
    module function cumprod_r1D(this) result(res)
      !! Interfaced with cumprod()
      real(r32),intent(in) :: this(:) !! 1D array
      real(r32) :: res(size(this)) !! Cumulative product
    end function
    module function cumprod_d1D(this) result(res)
      !! Interfaced with cumprod()
      real(r64),intent(in) :: this(:) !! 1D array
      real(r64) :: res(size(this)) !! Cumulative product
    end function
    module function cumprod_i1D(this) result(res)
      !! Interfaced with cumprod()
      integer(i32),intent(in) :: this(:) !! 1D array
      integer(i32) :: res(size(this)) !! Cumulative product
    end function
    module function cumprod_id1D(this) result(res)
      !! Interfaced with cumprod()
      integer(i64),intent(in) :: this(:) !! 1D array
      integer(i64) :: res(size(this)) !! Cumulative product
    end function
  end interface

  public :: cumsum
  interface cumsum
    !! Compute the variance of an array
    module function cumsum_r1D(this) result(res)
      !! Interfaced with cumsum()
      real(r32),intent(in) :: this(:) !! 1D array
      real(r32) :: res(size(this)) !! Cumulative sum
    end function
    module function cumsum_d1D(this) result(res)
      !! Interfaced with cumsum()
      real(r64),intent(in) :: this(:) !! 1D array
      real(r64) :: res(size(this)) !! Cumulative sum
    end function
    module function cumsum_i1D(this) result(res)
      !! Interfaced with cumsum()
      integer(i32),intent(in) :: this(:) !! 1D array
      integer(i32) :: res(size(this)) !! Cumulative sum
    end function
    module function cumsum_id1D(this) result(res)
      !! Interfaced with cumsum()
      integer(i64),intent(in) :: this(:) !! 1D array
      integer(i64) :: res(size(this)) !! Cumulative sum
    end function
  end interface

  public :: geometricMean
  interface geometricMean
    !! Compute the geometric mean of a vector
    module function geometricMean_r1D(this) result(res)
      !! Interfaced with geometricMean()
      real(r32),intent(in) :: this(:)
      real(r64) :: res
    end function
    module function geometricMean_d1D(this) result(res)
      !! Interfaced with geometricMean()
      real(r64),intent(in) :: this(:)
      real(r64) :: res
    end function
    module function geometricMean_i1D(this) result(res)
      !! Interfaced with geometricMean()
      integer(i32),intent(in) :: this(:)
      real(r64) :: res
    end function
    module function geometricMean_id1D(this) result(res)
      !! Interfaced with geometricMean()
      integer(i64),intent(in) :: this(:)
      real(r64) :: res
    end function
  end interface

  public :: mean
  interface mean
    !! Compute the mean
    module function mean_r1D(this) result(res)
      !! Interfaced with mean()
      real(r32), intent(in) :: this(:) !! 1D array
      real(r64) :: res !! mean
    end function
    module function mean_d1D(this) result(res)
      !! Interfaced with mean()
      real(r64), intent(in) :: this(:) !! 1D array
      real(r64) :: res !! mean
    end function
    module function mean_i1D(this) result(res)
        !! Interfaced with mean()
      integer(i32), intent(in) :: this(:) !! 1D array
      real(r64) :: res !! mean
    end function
    module function mean_id1D(this) result(res)
      !! Interfaced with mean()
      integer(i64), intent(in) :: this(:) !! 1D array
      real(r64) :: res !! mean
    end function
  end interface

  public :: median
  interface median
    !! Compute the median of a set of numbers
    module function median_r1D(this) result(res)
      !! Interfaced with median()
      real(r32), intent(in) :: this(:) !! 1D array
      real(r32) :: res !! median
    end function
    module function median_d1D(this) result(res)
      !! Interfaced with median()
      real(r64), intent(in) :: this(:) !! 1D array
      real(r64) :: res !! median
    end function
    module function median_i1D(this) result(res)
      !! Interfaced with median()
      integer(i32), intent(in) :: this(:) !! 1D array
      real(r64) :: res !! median
    end function
    module function median_id1D(this) result(res)
      !! Interfaced with median()
      integer(i64), intent(in) :: this(:) !! 1D array
      real(r64) :: res !! median
    end function
  end interface

  public :: norm1
  interface norm1
    !! Compute the L1 norm of a set of numbers
    module function norm1_r1D(this) result(res)
      !! Interfaced with norm1()
      real(r32), intent(in) :: this(:) !! 1D array
      real(r32) :: res !! L1 norm
    end function
    module function norm1_d1D(this) result(res)
      !! Interfaced with norm1()
      real(r64), intent(in) :: this(:) !! 1D array
      real(r64) :: res !! L1 norm
    end function
    module function norm1_i1D(this) result(res)
      !! Interfaced with norm1()
      integer(i32), intent(in) :: this(:) !! 1D array
      real(r64) :: res !! L1 norm
    end function
    module function norm1_id1D(this) result(res)
      !! Interfaced with norm1()
      integer(i64), intent(in) :: this(:) !! 1D array
      real(r64) :: res !! L1 norm
    end function
  end interface

  public :: normI
  interface normI
    !! Compute the Linfinity norm of a set of numbers
    module function normI_r1D(this) result(res)
      !! Interfaced with normI()
      real(r32), intent(in) :: this(:) !! 1D array
      real(r32) :: res !! Linfinity norm
    end function
    module function normI_d1D(this) result(res)
      !! Interfaced with normI()
      real(r64), intent(in) :: this(:) !! 1D array
      real(r64) :: res !! Linfinity norm
    end function
    module function normI_i1D(this) result(res)
      !! Interfaced with normI()
      integer(i32), intent(in) :: this(:) !! 1D array
      integer(i32) :: res !! Linfinity norm
    end function
    module function normI_id1D(this) result(res)
      !! Interfaced with normI()
      integer(i64), intent(in) :: this(:) !! 1D array
      integer(i64) :: res !! Linfinity norm
    end function
  end interface

  public :: project
  interface project
    !! Project a vector a onto vector b
    module function project_r1D(a,b) result(c)
      !! Interfaced with project()
      real(r32),intent(in) :: a(:) !! 1D array
      real(r32),intent(in) :: b(size(a)) !! 1D array
      real(r32) :: c(size(a)) !! 1D array
    end function
    module function project_d1D(a,b) result(c)
      !! Interfaced with project()
      real(r64),intent(in) :: a(:) !! 1D array
      real(r64),intent(in) :: b(size(a)) !! 1D array
      real(r64) :: c(size(a)) !! 1D array
    end function
  end interface

  public :: trimmedmean
  interface trimmedmean
    !! Compute the Trimmed mean of an array,  alpha is a percent value to trim from either end
    module function trimmedmean_r1D(this,alpha) result(res)
      !! Interfaced with trimmedmean()
      real(r32), intent(in) :: this(:) !! 1D array
      real(r32), intent(in) :: alpha !! Percentage to trim off each end
      real(r64) :: res !! trimmedmean
    end function
    module function trimmedmean_d1D(this,alpha) result(res)
      !! Interfaced with trimmedmean()
      real(r64), intent(in) :: this(:) !! 1D array
      real(r64), intent(in) :: alpha !! Percentage to trim off each end
      real(r64) :: res !! trimmedmean
    end function
    module function trimmedmean_i1D(this,alpha) result(res)
      !! Interfaced with trimmedmean()
      integer(i32), intent(in) :: this(:) !! 1D array
      real(r64), intent(in) :: alpha !! Percentage to trim off each end
      real(r64) :: res !! trimmedmean
    end function
    module function trimmedmean_id1D(this,alpha) result(res)
      !! Interfaced with trimmedmean()
      integer(i64), intent(in) :: this(:) !! 1D array
      real(r64), intent(in) :: alpha !! Percentage to trim off each end
      real(r64) :: res !! trimmedmean
    end function
  end interface

  public :: std
  interface std
    !! Compute the standard deviation of an array
    module function std_r1D(this) result(res)
      !! Interfaced with std()
      real(r32), intent(in) :: this(:) !! 1D array
      real(r64) :: res !! standard deviation
    end function
    module function std_d1D(this) result(res)
      !! Interfaced with std()
      real(r64), intent(in) :: this(:) !! 1D array
      real(r64) :: res !! standard deviation
    end function
    module function std_i1D(this) result(res)
      !! Interfaced with std()
      integer(i32), intent(in) :: this(:) !! 1D array
      real(r64) :: res !! standard deviation
    end function
    module function std_id1D(this) result(res)
      !! Interfaced with std()
      integer(i64), intent(in) :: this(:) !! 1D array
      real(r64) :: res !! standard deviation
    end function
  end interface

  public :: variance
  interface variance
    !! Compute the variance of an array
    module function variance_r1D(this) result(res)
      !! Interfaced with variance()
      real(r32), intent(in) :: this(:) !! 1D array
      real(r64) :: res !! variance
    end function
    module function variance_d1D(this) result(res)
      !! Interfaced with variance()
      real(r64), intent(in) :: this(:) !! 1D array
      real(r64) :: res !! variance
    end function
    module function variance_i1D(this) result(res)
      !! Interfaced with variance()
      integer(i32), intent(in) :: this(:) !! 1D array
      real(r64) :: res !! variance
    end function
    module function variance_id1D(this) result(res)
      !! Interfaced with variance()
      integer(i64), intent(in) :: this(:) !! 1D array
      real(r64) :: res !! variance
    end function
  end interface
end module


c     # -----------------------------------------------------
c     # GAUSSIAN_SUM
c     #
c     # Computes the value q at a point (x,y,z), where q
c     # is defined by the sum
c     #
c     #             q = sum_{i=1,n} g(x,y,z;xi,yi,zi,a,hmax)
c     #
c     #          g(x,y,z;xi,yi,zi,a,hmax) = hmax*exp(-a*r2)
c     #
c     #          r2 = (x-xi)**2 + (y-yi)**2 + (z-zi)**2
c     #
c     # Note : 'td' means "time dependent"
c     # -----------------------------------------------------

      double precision function gaussian_sum(xp,yp,zp)
      implicit none

      double precision xp, yp, zp, q

      integer m, get_n_locations, n
      double precision w(3), qv, a, hmax
      double precision gaussian_flat, gaussian_sphere
      logical isflat

      n = get_n_locations()

c     # Get time dependent (td) parameters
      call get_td_gaussian_parms(a,hmax)

      q = 0
      do m = 1,n
         call get_td_gaussian_locations(m,w)
         if (isflat()) then
            qv = gaussian_flat(xp,yp,zp,w,a,hmax)
         else
            qv = gaussian_sphere(xp,yp,zp,w,a,hmax)
         endif
         q  = q  + qv
      enddo

      gaussian_sum = q

      end

      double precision function gaussian_flat(x,y,z,w,a,hmax)
      implicit none

      double precision x,y,z,w(3),q, a, r2, hmax

      r2 = (x-w(1))**2 + (y - w(2))**2 + (z - w(3))**2
      gaussian_flat = hmax*exp(-a*r2)

      end

      double precision function gaussian_sphere(x,y,z,w,a,hmax)
      implicit none

      double precision x,y,z,w(3),a,q, hmax

      double precision get_gc_distance, d

      d = get_gc_distance(x,y,z,w)
      q = hmax*exp(-a*d**2)

      gaussian_sphere = q

      end

      integer function get_n_locations()
      implicit none

      integer n_com
      common /comexp2/ n_com

      get_n_locations = n_com

      end

      subroutine set_n_locations(n)
      implicit none

      integer n

      integer n_com
      common /comexp2/ n_com

      n_com = n

      end

      subroutine set_initial_gaussian_locations(w,n)
      implicit none

      integer i, n, m
      double precision w(3,n)

      double precision wc_init_com(3,100), a_init_com, hmax_init_com
      common /comexpinit1/ wc_init_com, a_init_com, hmax_init_com

c     # Locations of initial exponentials
      if (n .gt. 100) then
         write(6,*) 'set_initial_gaussian_locations : n > 100'
         stop
      endif

      do i = 1,n
         do m = 1,3
            wc_init_com(m,i) = w(m,i)
         enddo
      enddo

      call set_n_locations(n)
      call set_td_gaussian_locations(w,n)

      end

      subroutine get_initial_gaussian_locations(i,w)
      implicit none

      integer i,m
      double precision w(3)

      double precision wc_init_com(3,100), a_init_com, hmax_init_com

      integer n, get_n_locations
      common /comexpinit1/ wc_init_com, a_init_com, hmax_init_com

      n  = get_n_locations()

      if (i .gt. n) then
         write(6,*) 'get_initial_gaussian_locations : i .gt. n'
         stop
      endif

      do m = 1,3
         w(m) = wc_init_com(m,i)
      enddo

      end

c     # ------------------------------------------
c     # Set time dependent Gaussian parms
c     # ------------------------------------------
      subroutine set_td_gaussian_locations(w,n)
      implicit none

      integer i, n, m
      double precision w(3,n)

      double precision wc_td_com(3,100), a_td_com
      double precision hmax_td_com

      common /comexptd1/ wc_td_com, a_td_com, hmax_td_com

      if (n .gt. 100) then
         write(6,*) 'set_td_gaussian_locations : n > 100'
         stop
      endif

c     # Locations of initial exponentials
      do i = 1,n
         do m = 1,3
            wc_td_com(m,i) = w(m,i)
         enddo
      enddo
      end

      subroutine get_td_gaussian_locations(i,w)
      implicit none

      integer i
      double precision w(3)

      integer m, n, get_n_locations

      double precision wc_td_com(3,100), a_td_com
      double precision hmax_td_com
      integer n_com

      common /comexptd1/ wc_td_com, a_td_com, hmax_td_com

      n = get_n_locations()
      if (i .gt. n) then
         write(6,*) 'get_td_gaussian_locations : i .gt. n'
         stop
      endif

      do m = 1,3
         w(m) = wc_td_com(m,i)
      enddo

      end

c     # ----------------------------------------------------
c     # Set a,hmax parameters for Gaussians
c     # ----------------------------------------------------

      subroutine set_initial_gaussian_parms(a,hmax)
      implicit none

      double precision a,hmax

      double precision wc_init_com(3,100), a_init_com, hmax_init_com

      common /comexpinit1/ wc_init_com, a_init_com, hmax_init_com

      a_init_com = a
      hmax_init_com = hmax

      call set_td_gaussian_parms(a,hmax)

      end

      subroutine get_initial_gaussian_parms(a,hmax)
      implicit none

      double precision a,hmax

      double precision wc_init_com(3,100), a_init_com, hmax_init_com

      common /comexpinit1/ wc_init_com, a_init_com, hmax_init_com

      a = a_init_com
      hmax = hmax_init_com

      end

      subroutine set_td_gaussian_parms(a,hmax)
      implicit none

      double precision a,hmax

      double precision wc_td_com(3,100), a_td_com, hmax_td_com

      common /comexpinit1/ wc_td_com, a_td_com, hmax_td_com

      a_td_com = a
      hmax_td_com = hmax

      end

      subroutine get_td_gaussian_parms(a,hmax)
      implicit none

      double precision a,hmax

      double precision wc_td_com(3,100), a_td_com, hmax_td_com

      common /comexpinit1/ wc_td_com, a_td_com, hmax_td_com

      a = a_td_com
      hmax = hmax_td_com

      end

c     # ------------------------------------------------
c     # Great circle distance on sphere
c     # ------------------------------------------------
      double precision function get_gc_distance(x,y,z,w)
      implicit none

      double precision x,y,z,w(3)
      double precision p(3), pn, wn, ca, th
      double precision rsphere, get_scale
      integer m

c      rsphere = get_scale()
      rsphere = 1.0

      p(1) = x
      p(2) = y
      p(3) = z
      pn = sqrt(p(1)*p(1) + p(2)*p(2) + p(3)*p(3))
      if (abs(pn - rsphere) .ge. 1e-3) then
         write(6,*) 'get_gc_distance : Point is not on the sphere; '
         write(6,*) x, y, z, abs(pn-rsphere)
         stop
      endif

      wn = sqrt(w(1)*w(1) + w(2)*w(2) + w(3)*w(3))
      do m = 1,3
         w(m) = w(m)/wn
      enddo
      ca = (w(1)*x + w(2)*y + w(3)*z)/pn
      if (abs(ca) .gt. 1) then
         write(6,*) 'get_gc_distance : abs(ca) > 1; ', ca
         write(6,*) w(1), w(2), w(3), x,y,z
         stop
      endif
      th = acos(ca)
      get_gc_distance = th*rsphere

      end


program main2
    use Matrix

    implicit none

!   Command-line Args
    integer :: argc

    character(len=32) :: matrix_fname, vector_fname

!   Matrices
    integer :: m, n
    double precision, allocatable :: A(:, :)
    double precision, allocatable :: LL(:, :)
    double precision, allocatable :: XX(:, :)

!   Vectors
    integer :: t
    double precision, allocatable :: b(:)
    double precision, allocatable :: x(:)

!   Eigenvalue
    double precision :: l

!   Get Command-Line Args
    matrix_fname = 'matrix2.txt'
    vector_fname = 'vector2.txt'

    argc = iargc()

    if (argc == 1) then
        call getarg(1, matrix_fname)
    elseif(argc == 2) then
        call getarg(1, matrix_fname)
        call getarg(2, vector_fname)
    elseif (argc > 2) then
        goto 92
    end if

    call read_matrix(matrix_fname, A, m, n)
    call read_vector(vector_fname, b, t)

    if (m /= n) then
        goto 90
    elseif (m /= t) then
        goto 91
    end if

!   Print Matrix
!   Print Matrix Name
    write(*, *) 'A:'
    call print_matrix(A, m, n)

!   Print Matrix
!   Print Matrix Name
    write(*, *) 'b:'
    call print_vector(b, t)

!   Eigenvalue Time
!   Power Method
    allocate(x(n))
    call info(':: Método das Potências (Power Method) ::')
    if (.not. power_method(A, n, x, l)) then
        goto 80
    end if

    write(*, *) 'x:'
    call print_vector(x, n)

    write(*, *) 'lambda:'
    write(*, *) l

!   Jacobi Eigenvalues/vectors time
    allocate(LL(n, n))
    allocate(XX(n, n))
    call info(':: Método de autovalores de Jacobi ::')
    if (.not. Jacobi_eigen(A, n, LL, XX)) then
        goto 81
    end if
    write(*, *) 'L:'
    call print_matrix(LL, n, n)
    write(*, *) 'X:'
    call print_matrix(XX, n, n)
    goto 85

80  call error('O Método das potências não convergiu a tempo.')
    write(*, *) 'x:'
    call print_vector(x, n)
    goto 100

81  call error('O Método de autovalores de Jacobi não convergiu a tempo.')
    write(*, *) 'L:'
    call print_matrix(LL, n, n)
    write(*, *) 'X:'
    call print_matrix(XX, n, n)
    goto 100

85  call info('Sucesso!')
    deallocate(A)
    deallocate(b)
    goto 100

90  call error('Essa matriz não é quadrada! Assim o programa não faz sentido.')
    goto 100
91  call error('A matriz `A` e o vetor `b` não possuem a mesma dimensão. Não tem como fazer Ax = b!')
    goto 100
92  call error('Parâmetros em excesso: O programa espera apenas o nome do arquivo da matriz.')
    goto 100

100     stop

end program main2


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! d_rot2_check
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine checks the generators for a real rotation represented
! by 2 real numbers: a real cosine, C, and a real sine, S.
!
! To check that it is valid, a new rotation X, Y is computed. If
! |C-X|, |S-Y|, |NRM-1| < 2*EISCOR_DBL_EPS the generators are
! considered valid. Otherwise they are invalid.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  C               REAL(8)
!                    generators for cosine
!
!  S               REAL(8)
!                    generator for sine
!
! OUTPUT VARIABLES:
!
!  FLAG            LOGICAL
!                    .TRUE. implies valid generators
!                    .FALSE. implies invalid generators
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine d_rot2_check(C,S,FLAG)

  implicit none

  ! input variables
  real(8), intent(in) :: C, S
  logical, intent(inout) :: FLAG

  ! compute variables
  real(8), parameter :: tol = 2d0*EISCOR_DBL_EPS
  real(8) :: X, Y, NRM

  ! initialize FLAG to .FALSE.
  FLAG = .FALSE.

  ! compute new rotation from input one
  call d_rot2_vec2gen(C,S,X,Y,NRM)

  ! check for equality
  if ((abs(C-X)<tol).AND.(abs(S-Y)<tol).AND.(abs(1d0-NRM)<tol)) then
    FLAG = .TRUE.
  end if

end subroutine d_rot2_check


SUBROUTINE choldc_sp(a,p)
  use mo_kind, only: i4, sp
  use mo_nrutil, ONLY : assert_eq,nrerror
  IMPLICIT NONE
  !
  REAL(SP), DIMENSION(:,:), INTENT(INOUT) :: a
  REAL(SP), DIMENSION(:), INTENT(OUT)     :: p
  INTEGER(I4)                             :: i,n
  REAL(SP)                                :: summ
  !
  n=assert_eq(size(a,1),size(a,2),size(p),'choldc_sp')
  do i=1,n
     summ=a(i,i)-dot_product(a(i,1:i-1),a(i,1:i-1))
     if (summ <= 0.0) call nrerror('choldc_sp failed')
     p(i)=sqrt(summ)
     a(i+1:n,i)=(a(i,i+1:n)-matmul(a(i+1:n,1:i-1),a(i,1:i-1)))/p(i)
  end do
END SUBROUTINE choldc_sp

SUBROUTINE choldc_dp(a,p)
  use mo_kind, only: i4, dp
  use mo_nrutil, ONLY : assert_eq,nrerror
  IMPLICIT NONE
  !
  REAL(DP), DIMENSION(:,:), INTENT(INOUT) :: a
  REAL(DP), DIMENSION(:), INTENT(OUT)     :: p
  INTEGER(I4)                             :: i,n
  REAL(DP)                                :: summ
  !
  n=assert_eq(size(a,1),size(a,2),size(p),'choldc_dp')
  do i=1,n
     summ=a(i,i)-dot_product(a(i,1:i-1),a(i,1:i-1))
     if (summ <= 0.0) call nrerror('choldc_dp failed')
     p(i)=sqrt(summ)
     a(i+1:n,i)=(a(i,i+1:n)-matmul(a(i+1:n,1:i-1),a(i,1:i-1)))/p(i)
  end do
END SUBROUTINE choldc_dp


double precision function true_solution(x, y, t)
    implicit none
    double precision, intent(in) :: x, y, t

    double precision :: t0 = .3d0, tau, mass, eta
    parameter(mass = 2.d0)
    integer :: ndim
    parameter(ndim = 2)

    tau = ((ndim + 4) * (t + t0))**(1.d0 / (ndim + 4))
    eta = sqrt(x**2 + y**2) / tau

    if (eta < mass) then
        true_solution = 1.d0/(8 * (ndim + 2) * tau**ndim) * (mass**2 - eta**2)**2
    else
        true_solution = 0.d0
    end if
end function true_solution


program euler_127
   integer, parameter :: int64 = selected_int_kind(10)
   integer(int64),parameter :: zero=0,one=1,two=2,three=3
   integer(int64) :: a,b,c,cmax=120000
   integer(int64) :: total=0

   ! looping this way should ensure that b > a (cond 2) and a+b=c (cond 3)
   do c=1,cmax
      do a=1,c/2
         b = c-a
         ! if this is an abc-hit, then we'll check rad (a*b*c)
         if (abc_hit(a,b,c)) then
            if (rad(a*b*c) < c) total = total + c
         end if
      end do !- a
   end do !- c

   print *,total
contains
   !> returns true if gcd(a,b)=gcd(b,c)=gcd(a,c)=1; false otherwise
   logical function abc_hit(a,b,c) result(bool)
      integer(int64), intent(in) :: a,b,c

      logical :: ab,bc,ac

      ab = gcd(a,b) == one
      bc = gcd(b,c) == one
      ac = gcd(a,c) == one

      bool = ab .and. bc .and. ac
   end function abc_hit

   !> returns the product of the distinct prime factors
   integer(int64) function rad(n)
      integer(int64), intent(in) :: n
      integer(int64), dimension(50) :: dpf     ! distinct prime factors
      integer(int64) :: k

      dpf = prime_factors(n)
      rad = one
      k = one
      do while (dpf(k) > 0)
         rad = rad*dpf(k)
         k = k + 1
      end do
   end function rad

   !> list of prime factors
   function prime_factors(nn) result(pf)
      integer(int64), intent(in) :: nn
      integer(int64), dimension(50) :: pf
      integer(int64) :: k, n, d

      k=zero
      pf = -one        ! initialize all prime factors to -1
      n = nn
      ! remove factors of 2
      do
         if (iand(n,one)==zero .or. n==one) then
            n = n/two
            if (k == zero) then
               pf(k) = two
               k = k + one
            end if
         end if
      end do

      d = three
      do
         if (d > nn) exit
         do
            if (mod(n, d) /= zero .or. n == one) then
               n = n/d
               if (pf(k-1) /= d) then
                  pf(k) = d
                  k = k + one
               end if
            end if
         end do
         d = d + two
      end do
   end function prime_factors

   !> implements binary gcd with some bitshifting for speed
   recursive function gcd(u, v) result(g)
      integer(int64), intent(in) :: u, v
      integer(int64) :: g

      if (u==v .or. u==zero) then
         g = v
         return
      end if

      if (v==zero) then
         g = u
         return
      end if

      ! if a number is even, then the taking bitwise AND with 1 would return 0
      ! ISHFT returns the shift of a number, direction depends on the 2nd argument: pos num = RSHIFT, neg num = LSHIFT
      if (iand(u, one)==zero) then
         if (iand(v,one)==zero) then
            g = gcd(ishft(u,one), v)
         else
            g = gcd(ishft(u,one), ishft(v,one))
            g = ishft(g, -one)
         end if
         return
      end if

      if (iand(v,one)==zero) then
         g = gcd(u, ishft(v,one))
         return
      end if

      g = gcd(ishft(abs(u-v),one),min(v,u))
   end function gcd
end program euler_127


      subroutine ktsol(n,ns,nv,a,b,x,ktilt,maxeq)
c-----------------------------------------------------------------------
c
c Solution of a system of linear equations by gaussian elimination with
c partial pivoting.  Several right hand side matrices and several
c variables are allowed.
c
c
c         NOTE: All input matrices must be in double precision
c
c
c INPUT/OUTPUT VARIABLES:
c
c   n                Number of equations
c   ns               Number of right hand side matrices
c   nv               Number of variables.
c   a(n*n*nv)        left hand side matrices versus columnwise.
c   b(n*ns*nv)       input right hand side matrices.
c   x(n*ns*nv)       solution matrices.
c   ktilt            indicator of singularity
c                      =  0  everything is ok.
c                      = -1 n.le.1
c                      =  k  a null pivot appeared at the kth iteration.
c   tol              used in test for null pivot. depends on machine
c                      precision and can also be set for the tolerance
c                      of an ill-defined kriging system.
c
c
c-----------------------------------------------------------------------
      implicit real*8 (a-h,o-z)
      real*8 x(maxeq),a(maxeq*maxeq),b(maxeq)
c
c Make sure there are equations to solve:
c
      if(n.le.1) then
            ktilt = -1
            return
      endif
c
c Initialization:
c
      tol   = 0.1e-10
      ktilt = 0
      ntn   = n*n
      nm1   = n-1
c
c Triangulation is done variable by variable:
c
      do iv=1,nv
c
c Indices of location in vectors a and b:
c
            nva = ntn*(iv-1)
            nvb = n*ns*(iv-1)
c
c Gaussian elimination with partial pivoting:
c
            do k=1,nm1
                  kp1 = k+1
c
c Indice of the diagonal element in the kth row:
c
                  kdiag = nva+(k-1)*n+k
c
c Find the pivot - interchange diagonal element/pivot:
c
                  npiv = kdiag
                  ipiv = k
                  i1   = kdiag
                  do i=kp1,n
                        i1 = i1+1
                        if(abs(a(i1)).gt.abs(a(npiv))) then
                              npiv = i1
                              ipiv = i
                        endif
                  end do
                  t        = a(npiv)
                  a(npiv)  = a(kdiag)
                  a(kdiag) = t
c
c Test for singularity:
c
                  if(abs(a(kdiag)).lt.tol) then
                        ktilt=k
                        return
                  endif
c
c Compute multipliers:
c
                  i1 = kdiag
                  do i=kp1,n
                        i1    = i1+1
                        a(i1) = -a(i1)/a(kdiag)
                  end do
c
c Interchange and eliminate column per column:
c
                  j1 = kdiag
                  j2 = npiv
                  do j=kp1,n
                        j1    = j1+n
                        j2    = j2+n
                        t     = a(j2)
                        a(j2) = a(j1)
                        a(j1) = t
                        i1    = j1
                        i2    = kdiag
                        do i=kp1,n
                              i1    = i1+1
                              i2    = i2+1
                              a(i1) = a(i1)+a(i2)*a(j1)
                        end do
                  end do
c
c Interchange and modify the ns right hand matrices:
c
                  i1 = nvb+ipiv
                  i2 = nvb+k
                  do i=1,ns
                        t     = b(i1)
                        b(i1) = b(i2)
                        b(i2) = t
                        j1    = i2
                        j2    = kdiag
                        do j=kp1,n
                              j1    = j1+1
                              j2    = j2+1
                              b(j1) = b(j1)+b(i2)*a(j2)
                        end do
                        i1 = i1+n
                        i2 = i2+n
                  end do
            end do
c
c Test for singularity for the last pivot:
c
            kdiag = ntn*iv
            if(abs(a(kdiag)).lt.tol) then
                  ktilt = n
                  return
            endif
      end do
c
c End of triangulation. Now, solve back variable per variable:
c
      do iv=1,nv
c
c Indices of location in vectors a and b:
c
            nva  = ntn*iv
            nvb1 = n*ns*(iv-1)+1
            nvb2 = n*ns*iv
c
c Back substitution with the ns right hand matrices:
c
            do il=1,ns
                  do k=1,nm1
                        nmk = n-k
c
c Indice of the diagonal element of the (n-k+1)th row and of
c the (n-k+1)th element of the left hand side.
c
                        kdiag = nva-(n+1)*(k-1)
                        kb    = nvb2-(il-1)*n-k+1
                        b(kb) = b(kb)/a(kdiag)
                        t     = -b(kb)
                        i1    = kb
                        i2    = kdiag
                        do i=1,nmk
                              i1    = i1-1
                              i2    = i2-1
                              b(i1) = b(i1)+a(i2)*t
                        end do
                  end do
                  kdiag = kdiag-n-1
                  kb    = kb-1
                  b(kb) = b(kb)/a(kdiag)
            end do
c
c End of back substitution:
c
      end do
c
c Restitution of the solution:
c
      itot = n*ns*nv
      do i=1,itot
            x(i) = b(i)
      end do
c
c Finished:
c
      return
      end


module gamma_funcs
  implicit none
  integer, parameter :: int32 = kind(1)
  integer, parameter :: float32 = kind(1.0)
  integer, parameter :: float64 = kind(1.d0)
contains
  elemental function digamma (x)

    !*****************************************************************************80
    !
    !! DIGAMMA calculates DIGAMMA ( X ) = d ( LOG ( GAMMA ( X ) ) ) / dX
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    20 March 2016
    !
    !  Author:
    !
    !    Original FORTRAN77 version by Jose Bernardo.
    !    FORTRAN90 version by John Burkardt.
    !    iso_fortran_env by Simone Marsili.
    !
    !  Reference:
    !
    !    Jose Bernardo,
    !    Algorithm AS 103:
    !    Psi ( Digamma ) Function,
    !    Applied Statistics,
    !    Volume 25, Number 3, 1976, pages 315-317.
    !
    !  Parameters:
    !
    !    Input, real(float64) X, the argument of the digamma function.
    !    0 < X.
    !
    !
    !    Output, real(float64) DIGAMMA, the value of the digamma function at X.
    !
    implicit none

    real(float64)             :: digamma
    real(float64), intent(in) :: x
    real(float64), parameter :: c = 8.5_float64
    real(float64), parameter :: euler_mascheroni = 0.57721566490153286060_float64
    real(float64) r
    real(float64) x2
    !
    !  Check the input.
    !
    if ( x <= 0.0_float64 ) then
       digamma = 0.0_float64
       return
    end if
    !
    !  Approximation for small argument.
    !
    if ( x <= 0.000001_float64 ) then
       digamma = - euler_mascheroni - 1.0_float64 / x + 1.6449340668482264365_float64 * x
       return
    end if
    !
    !  Reduce to DIGAMA(X + N).
    !
    digamma = 0.0_float64
    x2 = x

    do while ( x2 < c )
       digamma = digamma - 1.0_float64 / x2
       x2 = x2 + 1.0_float64
    end do
    !
    !  Use Stirling's (actually de Moivre's) expansion.
    !
    r = 1.0_float64 / x2

    digamma = digamma + log ( x2 ) - 0.5_float64 * r

    r = r * r

    digamma = digamma &
         - r * ( 1.0_float64 / 12.0_float64 &
         - r * ( 1.0_float64 / 120.0_float64 &
         - r * ( 1.0_float64 / 252.0_float64 &
         - r * ( 1.0_float64 / 240.0_float64 &
         - r * ( 1.0_float64 / 132.0_float64 ) ) ) ) )

  end function digamma

  elemental function trigamma (x)

    !*****************************************************************************80
    !
    !! TRIGAMMA calculates trigamma(x) = d^2 log(gamma(x)) / dx^2
    !
    !  Modified:
    !
    !    19 January 2008
    !
    !  Author:
    !
    !    Original FORTRAN77 version by BE Schneider.
    !    FORTRAN90 version by John Burkardt.
    !    iso_fortran_env by Simone Marsili.
    !
    !  Reference:
    !
    !    BE Schneider,
    !    Algorithm AS 121:
    !    Trigamma Function,
    !    Applied Statistics,
    !    Volume 27, Number 1, pages 97-99, 1978.
    !
    !  Parameters:
    !
    !    Input, real(float64) X, the argument of the trigamma function.
    !    0 < X.
    !
    !
    !    Output, real(float64) TRIGAMMA, the value of the trigamma function.
    !
    implicit none

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

    real(float64), parameter :: a = 0.0001_float64
    real(float64), parameter :: b = 5.0_float64
    real(float64), parameter :: b2 =  0.1666666667_float64
    real(float64), parameter :: b4 = -0.03333333333_float64
    real(float64), parameter :: b6 =  0.02380952381_float64
    real(float64), parameter :: b8 = -0.03333333333_float64

    real(float64) y
    real(float64) z
    !
    !  Check the input.
    !
    if ( x <= 0.0_float64 ) then
       trigamma = 0.0_float64
       return
    end if

    z = x
    !
    !  Use small value approximation if X <= A.
    !
    if ( x <= a ) then
       trigamma = 1.0_float64 / x / x
       return
    end if
    !
    !  Increase argument to ( X + I ) >= B.
    !
    trigamma = 0.0_float64

    do while ( z < b )
       trigamma = trigamma + 1.0_float64 / z / z
       z = z + 1.0_float64
    end do
    !
    !  Apply asymptotic formula if argument is B or greater.
    !
    y = 1.0_float64 / z / z

    trigamma = trigamma + 0.5_float64 * &
         y + ( 1.0_float64 &
         + y * ( b2  &
         + y * ( b4  &
         + y * ( b6  &
         + y *   b8 )))) / z

  end function trigamma

  elemental function quadgamma (x)
    ! computes \psi_2(x) = d^3 log(gamma(x)) / dx^3 = d^2 \psi(x) / dx^2
    ! Simone Marsili
    implicit none

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

    real(float64), parameter :: a = 0.0001_float64
    real(float64), parameter :: b = 5.0_float64
    real(float64) z
    !  Check the input.
    if ( x <= 0.0_float64 ) then
       quadgamma = 0.0_float64
       return
    end if

    !  Use small value approximation if X <= A.
    if ( x <= a ) then
       quadgamma = - gamma(3.0_float64) / x**3
       return
    end if

    !  Increase argument to ( X + I ) >= B.
    quadgamma = 0.0_float64
    z = x
    do while ( z < b )
       quadgamma = quadgamma - 2.0_float64 / z**3
       z = z + 1.0_float64
    end do

    !  Apply asymptotic formula if argument is B or greater.
    z = 1/z
    quadgamma = quadgamma - z**2 - z**3 - 0.5*z**4

  end function quadgamma

end module gamma_funcs


program TrapezoidalMethod

    implicit none

    !------------Defining the variables ---------!
    real :: A,sumTotal = 0
    integer :: i,n
    real,allocatable, dimension(:) :: x1
    real :: a1,b1,delX !integral bounds

    !------------End of defining the variables ---------!
    n = 300 !number of steps
    allocate(x1(n))

    ! Solving this type of Integral
    !             a1
    !            ___
    !           /   '
    !           |
    !           |
    !           |  f(x) dx
    !           |
    !        ___/
    !          b1
    !
    !
    a1 = -10
    b1 = 10
    delX = (b1-a1)/n
    call calculateLength(b1,a1,n,x1,delX)

    do i  = 0, (n)

        call calculateArea(A,n,i,x1,delX)
        sumTotal = sumTotal+A
    end do

    print *, "Area of the given integral is :  ", sumTotal

end program

subroutine calculateArea(A,n,i,x1,delX)
    real :: f,A,delX
    integer :: n,i
    real, dimension(n) :: x1

    if((i == 0) .or.(i == (n))) then
        A = f(x1(i))*delX/2
    else

        A = f(x1(i))*delX

    end if

end subroutine

subroutine calculateLength(b1,a1,n,x1,delX)
    integer :: j,n
    real :: a1,b1,delX
    real, dimension(n) :: x1

    do j  = 0,(n)

        if(j==0) then
            x1(j) = a1

        else if (j.NE.0 .or. j.NE.(n) ) then
            x1(j) = x1(j-1)+delX
        else
            x1(j) = b1
        end if

    end do

end subroutine

real function f(x)
    implicit none
    real :: x
    f = exp(-(x**2))

end function


  avg = mean(x)
  sd = pstdev(x)
  n = SIZE(x)
  res = SUM((x(:)-avg)**3) / sd**3  / n


program fibonnacci_goto

implicit none
integer:: n       ! Declaration of iterator
integer:: i=2
integer:: x, y, z
real:: phi_est      ! Approx phi

print*, 'Type the number upto which the fibonnacci sequence is to run'

read*, n

    z = 0
    y = 1
2   x = y + z
    phi_est = x/(real(y))

    print '(2i15 f10.5)', i, x, phi_est

    z = y
    y = x
    i = i + 1
    if (i < n+1) goto 2

end program fibonnacci_goto


!##############################################################################
! PROGRAM polynomials
!
! ## Polynomial interpolation using different kinds of nodes
!
! 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 polynomials

    use toolbox

    implicit none
    integer, parameter :: n = 10, nplot = 1000
    real*8 :: xi(0:n), yi(0:n)
    real*8 :: xplot(0:nplot), yplot(0:nplot), yreal(0:nplot)

    ! get equidistant plot nodes and Runge's function
    call grid_Cons_Equi(xplot, -1d0, 1d0)
    yreal = 1d0/(1d0+25*xplot**2)
    call plot(xplot, yreal, legend='Original')

    ! equidistant polynomial interpolation
    call grid_Cons_Equi(xi, -1d0, 1d0)
    yi = 1d0/(1d0+25*xi**2)
    yplot = poly_interpol(xplot, xi, yi)
    call plot(xplot, yplot, legend='Equidistant')

    ! Chebyshev polynomial interpolation
    call grid_Cons_Cheb(xi, -1d0, 1d0)
    yi = 1d0/(1d0+25*xi**2)
    yplot = poly_interpol(xplot, xi, yi)
    call plot(xplot, yplot, legend='Chebyshev')

    ! execute plot
    call execplot()

end program


!Program to test SPACING intrinsic function.

program test_spacing
  call test_real4(3.0)
  call test_real4(33.0)
  call test_real4(-3.)
  call test_real4(0.0)
  call test_real8(0.0_8)
  call test_real8(3.0_8)
  call test_real8(33.0_8)
  call test_real8(-33._8)
end
subroutine test_real4(orig)
  real x,y,t,orig
  integer p
  x = orig
  p = 24
  y = 2.0 ** (exponent (x) - p)
  t = tiny(x)
  x = spacing(x)
  if ((abs (x - y) .gt. abs(x * 1e-6)) &
    .and. (abs (x - t) .gt. abs(x * 1e-6)))call abort
end

subroutine test_real8(orig)
  real*8 x,y,t,orig
  integer p
  x = orig
  p = 53
  y = 2.0 ** (exponent (x) - p)
  t = tiny (x)
  x = spacing(x)
  if ((abs (x - y) .gt. abs(x * 1e-6)) &
    .and. (abs (x - t) .gt. abs(x * 1e-6)))call abort
end