      program linReg1

      integer, parameter :: rp = SELECTED_REAL_KIND(15)
      integer, parameter :: n = 1000
      real (kind = rp) , dimension(n, 4):: x       ! it's a 1000 row, 4 column matrix
      real (kind = rp) , dimension(n, 1):: y       ! the dv, column vector
      real (kind = rp) , dimension(4, n):: x_T     ! transpose of the 1000 row, 4 column matrix
      real (kind = rp) , dimension(1, n):: y_T     ! the dv, row vector
      real (kind = rp) , dimension(4, 4):: x_Tx    !the product of transpose(x) and x
      real (kind = rp) , dimension(4, 4):: x_Txinv !copy of x_Tx to prevent lapack from mutating it
      real (kind = rp) , dimension(n)   :: work    ! work array for LAPACK
      integer, dimension(n)             :: ipiv    ! pivot indices
      integer :: info
      integer :: readstatus, readstatus2

      ! External procedures defined in LAPACK
      external DGETRF
      external DGETRI

      open(file = "R:/DataSets/Matrix-10-18-18.txt", unit = 50)
      read (50,*) x_T
      x = transpose(x_T)

C       print *, y
      open(file = "R:/DataSets/vector-10-18-18.txt", unit = 52)
      read(52,*) y_T
      y = transpose(y_T)
C http://www.lahey.com/docs/lfprohelp/F95AROPENStmt.htm
C https://stackoverflow.com/questions/17323628/read-data-from-a-csv-file-in-fortran
C https://docs.oracle.com/cd/E19957-01/805-4939/6j4m0vnaf/index.html
C file:///R:/Fortran_WD/FortranCrashCourseSeminar/ReadingArrayData.pdf

      x_Tx = matmul(x_T, x)
      x_Txinv = inv(x_Tx)
C      x_Txinv = matinv4( x_Tx )
C      x_Txinv = inv(x_Txinv)
C      print *, x_Txinv
! DGETRF computes an LU factorization of a general M-by-N matrix A
! using partial pivoting with row interchanges.
C       call DGETRF(n, n, x_Txinv, n, ipiv, info)
C       if (info /= 0) then
C          stop 'Matrix is numerically singular!'
C       end if
C       ! DGETRI computes the inverse of a matrix using the LU factorization
C       ! computed by DGETRF.
C       call DGETRI(n, x_Txinv, n, ipiv, work, n, info)

C       if (info /= 0) then
C          stop 'Matrix inversion failed!'
C       end if

      write (*,*) "program works"
      end program linReg1

      ! Returns the inverse of a matrix calculated by finding the LU
      ! decomposition.  Depends on LAPACK.

         integer, parameter :: rp = SELECTED_REAL_KIND(15)
         real(kind = rp), dimension(:,:), intent(in) :: A
         real(kind = rp), dimension(size(A,1),size(A,2)) :: Ainv

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

        ! External procedures defined in LAPACK
         external DGETRF
         external DGETRI

        ! 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.
         call DGETRF(n, n, Ainv, n, ipiv, info)

         if (info /= 0) then
            stop 'Matrix is numerically singular!'
         end if

        ! DGETRI computes the inverse of a matrix using the LU factorization
        ! computed by DGETRF.
         call DGETRI(n, Ainv, n, ipiv, work, n, info)

         if (info /= 0) then
            stop 'Matrix inversion failed!'
         end if
      end function inv

      pure function matinv4(A) result(B)
         integer, parameter :: rp = SELECTED_REAL_KIND(15)
         !! Performs a direct calculation of the inverse of a 4×4 matrix.
         real (kind = rp) , intent(in)  :: A(4,4)   !! Matrix
         real (kind = rp) , intent(out) :: B(4,4)   !! Inverse matrix
         real (kind = rp)               :: detinv

         ! Calculate the inverse determinant of the matrix
         detinv = &
           1/(A(1,1)*(A(2,2)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(2,4)*(A(3,2)*A(4,3)-A(3,3)*A(4,2)))&
            - A(1,2)*(A(2,1)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,3)-A(3,3)*A(4,1)))&
            + A(1,3)*(A(2,1)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(2,2)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))&
            - A(1,4)*(A(2,1)*(A(3,2)*A(4,3)-A(3,3)*A(4,2))+A(2,2)*(A(3,3)*A(4,1)-A(3,1)*A(4,3))+A(2,3)*(A(3,1)*A(4,2)-A(3,2)*A(4,1))))

         ! Calculate the inverse of the matrix
         B(1,1) = detinv*(A(2,2)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(2,3)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(2,4)*(A(3,2)*A(4,3)-A(3,3)*A(4,2)))
         B(2,1) = detinv*(A(2,1)*(A(3,4)*A(4,3)-A(3,3)*A(4,4))+A(2,3)*(A(3,1)*A(4,4)-A(3,4)*A(4,1))+A(2,4)*(A(3,3)*A(4,1)-A(3,1)*A(4,3)))
         B(3,1) = detinv*(A(2,1)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(2,2)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(2,4)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))
         B(4,1) = detinv*(A(2,1)*(A(3,3)*A(4,2)-A(3,2)*A(4,3))+A(2,2)*(A(3,1)*A(4,3)-A(3,3)*A(4,1))+A(2,3)*(A(3,2)*A(4,1)-A(3,1)*A(4,2)))
         B(1,2) = detinv*(A(1,2)*(A(3,4)*A(4,3)-A(3,3)*A(4,4))+A(1,3)*(A(3,2)*A(4,4)-A(3,4)*A(4,2))+A(1,4)*(A(3,3)*A(4,2)-A(3,2)*A(4,3)))
         B(2,2) = detinv*(A(1,1)*(A(3,3)*A(4,4)-A(3,4)*A(4,3))+A(1,3)*(A(3,4)*A(4,1)-A(3,1)*A(4,4))+A(1,4)*(A(3,1)*A(4,3)-A(3,3)*A(4,1)))
         B(3,2) = detinv*(A(1,1)*(A(3,4)*A(4,2)-A(3,2)*A(4,4))+A(1,2)*(A(3,1)*A(4,4)-A(3,4)*A(4,1))+A(1,4)*(A(3,2)*A(4,1)-A(3,1)*A(4,2)))
         B(4,2) = detinv*(A(1,1)*(A(3,2)*A(4,3)-A(3,3)*A(4,2))+A(1,2)*(A(3,3)*A(4,1)-A(3,1)*A(4,3))+A(1,3)*(A(3,1)*A(4,2)-A(3,2)*A(4,1)))
         B(1,3) = detinv*(A(1,2)*(A(2,3)*A(4,4)-A(2,4)*A(4,3))+A(1,3)*(A(2,4)*A(4,2)-A(2,2)*A(4,4))+A(1,4)*(A(2,2)*A(4,3)-A(2,3)*A(4,2)))
         B(2,3) = detinv*(A(1,1)*(A(2,4)*A(4,3)-A(2,3)*A(4,4))+A(1,3)*(A(2,1)*A(4,4)-A(2,4)*A(4,1))+A(1,4)*(A(2,3)*A(4,1)-A(2,1)*A(4,3)))
         B(3,3) = detinv*(A(1,1)*(A(2,2)*A(4,4)-A(2,4)*A(4,2))+A(1,2)*(A(2,4)*A(4,1)-A(2,1)*A(4,4))+A(1,4)*(A(2,1)*A(4,2)-A(2,2)*A(4,1)))
         B(4,3) = detinv*(A(1,1)*(A(2,3)*A(4,2)-A(2,2)*A(4,3))+A(1,2)*(A(2,1)*A(4,3)-A(2,3)*A(4,1))+A(1,3)*(A(2,2)*A(4,1)-A(2,1)*A(4,2)))
         B(1,4) = detinv*(A(1,2)*(A(2,4)*A(3,3)-A(2,3)*A(3,4))+A(1,3)*(A(2,2)*A(3,4)-A(2,4)*A(3,2))+A(1,4)*(A(2,3)*A(3,2)-A(2,2)*A(3,3)))
         B(2,4) = detinv*(A(1,1)*(A(2,3)*A(3,4)-A(2,4)*A(3,3))+A(1,3)*(A(2,4)*A(3,1)-A(2,1)*A(3,4))+A(1,4)*(A(2,1)*A(3,3)-A(2,3)*A(3,1)))
         B(3,4) = detinv*(A(1,1)*(A(2,4)*A(3,2)-A(2,2)*A(3,4))+A(1,2)*(A(2,1)*A(3,4)-A(2,4)*A(3,1))+A(1,4)*(A(2,2)*A(3,1)-A(2,1)*A(3,2)))
         B(4,4) = detinv*(A(1,1)*(A(2,2)*A(3,3)-A(2,3)*A(3,2))+A(1,2)*(A(2,3)*A(3,1)-A(2,1)*A(3,3))+A(1,3)*(A(2,1)*A(3,2)-A(2,2)*A(3,1)))
       end function

C  , recl = 10, iostat = readstatus
C  access='sequential',form="formatted", are defaults
C       do i = 1,n
C          read(50,*) X
C       end do
C       open(file = "R:/DataSets/vector-10-18-18.csv", unit = 52)
C  , recl = 100, iostat = res
C  defaults: access='sequential',form="formatted",
C       do i = 1,n
C          read(52,*) y
C       end do

C $ gfortran R:/Fortran_WD/linRegPracticeOct2018.f -o R:/Fortran_WD/linRegPracticeOct2018.exe -L/R:/Cygwin/http%3a%2f%2fmirror.cs.vt.edu%2fpub%2fcygwin%2fcygwin%2f/x86_64/release/lapack/liblapack0/usr/lib/lapack -llapack
C https://stackoverflow.com/questions/35007006/error-in-linking-gfortran-to-lapack-and-blas
C https://stackoverflow.com/questions/23130045/fortran-90-segmentation-fault-invalid-memory-reference-with-scalable-3d-ar
C https://stackoverflow.com/questions/20453315/segmentation-fault-core-dumped-error-in-fortran-gfortran-linux

gfortran R:/Fortran_WD/lapackPractice1.f -o R:/Fortran_WD/lapackPractice1.exe -L/R:/Fortran_WD/invA.f    -L/R:/Cygwin/http%3a%2f%2fmirror.cs.vt.edu%2fpub%2fcygwin%2fcygwin%2f/x86_64/release/lapack/liblapack0/usr/lib/lapack -llapack


Module mo_model

  use mo_kind   , only: dp, i4

  IMPLICIT NONE

  PRIVATE

  PUBLIC :: GetRange
  PUBLIC :: model

  ! module variables
  integer(i4) :: npara = 4

contains

  function GetRange()
    implicit none

    real(dp), dimension(npara,2)  :: GetRange   ! min value and max value of parameter

    GetRange(1,:)  = (/  -1.00_dp,  1.00_dp /) ! min & max parameter 1
    GetRange(2,:)  = (/  -1.00_dp,  1.00_dp /) ! min & max parameter 2
    GetRange(3,:)  = (/  -1.00_dp,  1.00_dp /) ! min & max parameter 3
    GetRange(4,:)  = (/  -1.00_dp,  1.00_dp /) ! min & max parameter 4

  end function GetRange

  function model(paraset,x)
    implicit none

    real(dp), dimension(npara),   intent(in)  :: paraset   ! parameter set
    real(dp), dimension(:),       intent(in)  :: x         ! variables
    real(dp), dimension(size(x))              :: model     ! modeled output

    model(:) = paraset(1) * x(:)**3 + paraset(2) * x(:)**2 + paraset(3) * x(:) + paraset(4)
  end function model

end Module mo_model


!##############################################################################
! PROGRAM NewtonCotes
!
! ## Numerical integration with Newton-Cotes formulas
!
! 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 NewtonCotes

    implicit none
    integer, parameter :: n = 10
    real*8, parameter :: a = 0d0, b = 2d0
    real*8 :: h, x(0:n), w(0:n), f(0:n)
    integer :: i

    ! calculate quadrature nodes
    h = (b-a)/dble(n)
    x = (/(a + dble(i)*h, i=0,n)/)

    ! get weights
    w(0) = h/2d0
    w(n) = h/2d0
    w(1:n-1) = h

    ! calculate function values at nodes
    f = cos(x)

    ! Output numerical and analytical solution
    write(*,'(a,f10.6)')' Numerical:  ',sum(w*f, 1)
    write(*,'(a,f10.6)')' Analytical: ',sin(2d0)-sin(0d0)

end program


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      double precision function distance(asep,eccn,Tanom)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      implicit none
      double precision asep,eccn,Tanom

      distance=asep*(1.0d0-eccn*eccn)/(1+eccn*cos(Tanom))

      return
      end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      double precision function trueanomaly(eccn,Eanom)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      implicit none
      double precision eccn,Eanom,temp(2)

      temp(1)=sqrt((1.0d0+eccn)/(1.0d0-eccn))
      temp(2)=tan(Eanom/2.)
      trueanomaly=2.0d0*atan(temp(1)*temp(2))

      return
      end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      subroutine kepler(Manom,Eanom,eccn)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      implicit none
      integer i,itmax
      parameter(itmax=100)
      double precision Manom,Eanom,Eold,eccn,diff,thres
      thres=1.0d-8

      Eold=Eanom
      Eanom=Manom+eccn*sin(Eanom)
      diff=abs(1.0d0-Eanom/Eold)
      Eold=Eanom
      i=0
      do while ((diff.gt.thres).and.(i.lt.itmax))
        Eanom=Manom+eccn*sin(Eanom)
        diff=abs(1.0d0-Eanom/Eold)
        Eold=Eanom
        i=i+1
      enddo

      return
      end

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      subroutine invkepler(Eanom,Manom,eccn)
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
      implicit none
      integer i,itmax
      parameter(itmax=100)
      double precision Manom,Eanom,Mold,eccn,diff,thres
      thres=1.0d-6

      Mold=Manom
      Manom=Eanom-eccn*sin(Manom)
      diff=abs(1.0d0-Manom/Mold)
      Mold=Manom
      i=0
      do while ((diff.gt.thres).and.(i.lt.itmax))
        Manom=Eanom-eccn*sin(Manom)
        diff=abs(1.0d0-Manom/Mold)
        Mold=Manom
        i=i+1
      enddo
c      if(i.ge.itmax) write(0,*) "invkepler itmax"

      return
      end


module orbital_constants
  implicit none

  ! Earth: orbital period 1.0 Earth years, 365.25 Earth days, or 31557600 seconds
  double precision, parameter, public :: earth_year_seconds = 31557600.d0

  ! A planet's orbit as measured in Earth years
  double precision, parameter, public :: mercury_earth_years = 0.2408467d0
  double precision, parameter, public :: venus_earth_years = 0.61519726d0
  double precision, parameter, public :: mars_earth_years = 1.8808158d0
  double precision, parameter, public :: jupiter_earth_years = 11.862615d0
  double precision, parameter, public :: saturn_earth_years = 29.447498d0
  double precision, parameter, public :: uranus_earth_years = 84.016846d0
  double precision, parameter, public :: neptune_earth_years = 164.79132d0

end module orbital_constants

module space_age
  use orbital_constants
  implicit none
contains

  double precision function age_in_years(planet, seconds)
    character(len=*), intent(in) :: planet
    double precision, intent(in) :: seconds

    ! A multiplier for a number of Earth years for the given planet
    double precision :: n_earth_years = 1.d0

    age_in_years = 0.d0

    select case (planet)
    case ("Mercury")
      n_earth_years = mercury_earth_years
    case ("Venus")
      n_earth_years = venus_earth_years
    case ("Earth")
      n_earth_years = 1.d0
    case ("Mars")
      n_earth_years = mars_earth_years
    case ("Jupiter")
      n_earth_years = jupiter_earth_years
    case ("Saturn")
      n_earth_years = saturn_earth_years
    case ("Uranus")
      n_earth_years = uranus_earth_years
    case ("Neptune")
      n_earth_years = neptune_earth_years
    case default
      write(*,*) 'ERROR: unknown planet: '//trim(planet)
    end select

    age_in_years = seconds / earth_year_seconds / n_earth_years

  end function

end module


 implicit none

 integer :: f,n
 real(8) :: p,x1,x2,s
 real(8), external :: power,exponential

 1 print*,'Function (1=power, 2=exponential):'; read*,f;
 if (f/=1.and.f/=2) goto 1
 print*,'Give power p (in x**p or exp(p*x)):'; read*,p
 print*,'Integrate between values (x1,x2):'; read*,x1,x2
 print*,'Number n of integration intervals:'; read*,n
 if (mod(n,2)/=0) then
   n=n+1; print*,'Using n = ',n
 end if
 if (f==1) then
    call simpson(x1,x2,n,power,p,s)
 else
    call simpson(x1,x2,n,exponential,p,s)
 endif
 print*,'The Simpson integral is: ',s

 end

!------------------------------------!
 subroutine simpson(x1,x2,n,func,p,s)

 implicit none

 integer :: i,n
 real(8) :: x1,x2,dx,p,s
 real(8), external :: func

 dx=(x2-x1)/dble(n)
 s=func(x1,p)
 do i=1,n-1,2
   s=s+func(x1+dx*i,p)*4.d0+func(x1+dx*(i+1),p)*2.d0
 end do
 s=(s-func(x2,p))/(3.d0*n)

 end subroutine simpson

!-------------------!
 function power(x,p)
 implicit none
 real(8) :: power,x,p
 power=x**p
 end function power

!-------------------------!
 function exponential(x,p)
 implicit none
 real(8) :: exponential,x,p
 exponential=exp(p*x)
 end function exponential


program main
    implicit none

    integer, parameter :: dp = 8
    real(dp), dimension(1:3) :: x
    integer, parameter :: nstep = 20000000
    real(dp) :: t = 0.0_dp
    real(dp) :: h = 1.0e-10_dp
    integer, parameter :: nb_loops = 21
    integer, parameter :: n = 3
    integer :: k
    integer :: time_begin
    integer :: time_end
    integer :: count_rate
    real(dp) :: time
    real(dp) :: min_time = 100.0

    do k = 1, nb_loops
        x = [ 8.5_dp, 3.1_dp, 1.2_dp ]
        call system_clock(time_begin, count_rate)
        call rk4sys(n, t, x, h, nstep)
        call system_clock(time_end, count_rate)
        time = real(time_end - time_begin, dp) / real(count_rate, dp)
        min_time = min(time, min_time)
        write (*,*) time, x(1)
    end do
    write (*,*) "Minimal Runtime:", min_time
contains
    subroutine xpsys(x,f)
        real(dp), dimension(1:3), intent(in) :: x
        real(dp), dimension(1:3), intent(out) :: f
        f(1) = 10.0_dp * ( x(2) - x(1) )
        f(2) = 28.0_dp * x(1) - x(2) - x(1) * x(3)
        f(3) = x(1) * x(2) - (8.0_dp / 3.0_dp) * x(3)
    end subroutine xpsys

    subroutine rk4sys(n, t, x, h, nstep)
        integer, intent(in) :: n
        real(dp), intent(in) :: t
        real(dp), dimension(1:n), intent(inout) :: x
        real(dp), intent(in) :: h
        integer, intent(in) :: nstep
        ! Local variables
        real(dp) :: h2
        real(dp), dimension(1:n) :: y, f1, f2, f3, f4
        integer :: i, k

        h2 = 0.5_dp * h
        do k = 1, nstep
            call xpsys(x, f1)
            y = x + h2 * f1
            call xpsys(y, f2)
            y = x + h2 * f2
            call xpsys(y, f3)
            y = x + h * f3
            call xpsys(y, f4)
            x = x + h * (f1 + 2.0_dp * (f2 + f3) + f4) / 6.0_dp
        end do
    end subroutine rk4sys
end program main


C+PGCT01    -- function defining standard colour table

      REAL FUNCTION PGCT01 (RGB, CI, CIMIN, CIMAX)
      INTEGER RGB,CI,CIMIN,CIMAX
C-----------------------------------------------------------------------
C Function defining standard colour table 01.  This function can be used
C as an argument to routine PGSCT.
C
C Returns:
C  PGCT01   : The red, green or blue intensity for a given colour index,
C             as a real number in the range 0.0 to 1.0, for the colour
C             table defined by:
C
C                red   = sin(3x)**2,
C                green = sin(5x)**2,
C                blue  = sin(7x)**2,   x = (ci-cimin)/(cimax-cimin)
C
C Arguments:
C  RGB (input, integer) : colour (red=1, green=2, blue=3)
C  CI (input, integer) : colour index in the range [CIMIN,CIMAX]
C  CIMIN (input, integer) : minimum colour index
C  CIMAX (input, integer) : maximum colour index
C
C 29-May-1989 - [DJT].
C-----------------------------------------------------------------------
      REAL X
      INTEGER R,G,B
      PARAMETER (R=1,G=2,B=3)
C
      X = FLOAT(CI-CIMIN)/FLOAT(CIMAX-CIMIN)
      IF (RGB.EQ.R) THEN
        PGCT01 = SIN(X*3.)**2
      ELSEIF (RGB.EQ.G) THEN
        PGCT01 = SIN(X*5.)**2
      ELSEIF (RGB.EQ.B) THEN
        PGCT01 = SIN(X*7.)**2
      ENDIF
C
      END


      MODULE FinGrnExtSubs

      IMPLICIT NONE

      ! ..... Public Subroutines ...................................................................................................

      PUBLIC :: ERROR
      PUBLIC :: ENXA
      PUBLIC :: E1XA
      PUBLIC :: EIX
      PUBLIC :: LGAMA
      PUBLIC :: Limes
      PUBLIC :: IK01A
      PUBLIC :: JY01B
      PUBLIC :: JY01BJ
      PUBLIC :: JY01BY0
      PUBLIC :: JY01BY1

      CONTAINS
!!---------------------------------------------------------------------------!!
!           Belows are third-party Level-3 (low level) subroutines           !
!!---------------------------------------------------------------------------!!
!
!  ============================================================================
!        Purpose: This program computes the error function
!                 erf(x) using subroutine ERROR
!   Licensing:
!
!     This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,
!     they give permission to incorporate this routine into a user program
!     provided that the copyright is acknowledged.
!
!   Author:
!
!     Shanjie Zhang, Jianming Jin
!
!   Reference:
!
!     Shanjie Zhang, Jianming Jin,
!     Computation of Special Functions,
!     Wiley, 1996,
!     ISBN: 0-471-11963-6,
!     LC: QA351.C45.
!
!   Modified on:
!     25 July 2017, by Yingyi Liu
!
!   Parameters:
!        Input:   x   --- Argument of erf(x)
!        Output:  ERR --- erf(x)
!        Example:
!                   x         erf(x)
!                 ---------------------
!                  1.0       .84270079
!                  2.0       .99532227
!                  3.0       .99997791
!                  4.0       .99999998
!                  5.0      1.00000000
!   ============================================================================

        SUBROUTINE ERROR(X,ERR)

        IMPLICIT NONE
        INTEGER K
        REAL*8 EPS,PI,X,X2,ER,R,C0,ERR

        EPS=1.0D-15
        PI=3.141592653589793D0
        X2=X*X
        IF (DABS(X).LT.3.5D0) THEN
           ER=1.0D0
           R=1.0D0
           DO K=1,50
              R=R*X2/(K+0.5D0)
              ER=ER+R
              IF (DABS(R).LE.DABS(ER)*EPS) EXIT
           ENDDO
           C0=2.0D0/DSQRT(PI)*X*DEXP(-X2)
           ERR=C0*ER
        ELSE
           ER=1.0D0
           R=1.0D0
           DO K=1,12
              R=-R*(K-0.5D0)/X2
              ER=ER+R
           ENDDO
           C0=DEXP(-X2)/(DABS(X)*DSQRT(PI))
           ERR=1.0D0-C0*ER
           IF (X.LT.0.0) ERR=-ERR
        ENDIF
        RETURN
        END SUBROUTINE ERROR

!
!  ============================================================================
!        Purpose: This program computes the exponential integral
!                 En(x) using subroutine ENXB
!   Licensing:
!
!     This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,
!     they give permission to incorporate this routine into a user program
!     provided that the copyright is acknowledged.
!
!   Author:
!
!     Shanjie Zhang, Jianming Jin
!
!   Reference:
!
!     Shanjie Zhang, Jianming Jin,
!     Computation of Special Functions,
!     Wiley, 1996,
!     ISBN: 0-471-11963-6,
!     LC: QA351.C45.
!
!   Modified on:
!     25 July 2017, by Yingyi Liu
!
!   Parameters:
!        Input :  x --- Argument of En(x)
!                 n --- Order of En(x)  (n = 0,1,2,...)
!        Output:  EN --- En(x)
!        Example: x = 10.0
!                    n         En(x)
!                  ----------------------
!                    0     .45399930D-05
!                    1     .41569689D-05
!                    2     .38302405D-05
!                    3     .35487626D-05
!                    4     .33041014D-05
!                    5     .30897289D-05
!  ============================================================================
!
        SUBROUTINE ENXA(N,X,EN)

        IMPLICIT NONE
        INTEGER N,K
        REAL*8 X,E0,E1,EN

        E0=DEXP(-X)/X

        CALL E1XA(X,E1)

        IF (N.EQ.0) THEN
          EN=E0
        ELSEIF (N.EQ.1) THEN
          EN=E1
        ELSE
          DO K=2,N
             EN=(DEXP(-X)-X*E1)/(K-1.0D0)
             E1=EN
          ENDDO
        ENDIF

        RETURN
        END SUBROUTINE ENXA

!
!  ============================================================================
!        Purpose: This program computes the exponential integral
!                 E1(x) using subroutine E1XA
!   Licensing:
!
!     This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,
!     they give permission to incorporate this routine into a user program
!     provided that the copyright is acknowledged.
!
!   Author:
!
!     Shanjie Zhang, Jianming Jin
!
!   Reference:
!
!     Shanjie Zhang, Jianming Jin,
!     Computation of Special Functions,
!     Wiley, 1996,
!     ISBN: 0-471-11963-6,
!     LC: QA351.C45.
!
!   Modified on:
!     25 July 2017, by Yingyi Liu
!
!   Parameters:
!        Input :  x  --- Argument of E1(x)  ( x > 0 )
!        Output:  E1 --- E1(x)
!        Example:
!                   x        E1(x)
!                 ----------------------
!                  0.0     .1000000+301
!                  1.0     .2193839E+00
!                  2.0     .4890051E-01
!                  3.0     .1304838E-01
!                  4.0     .3779352E-02
!                  5.0     .1148296E-02
!  ============================================================================
!
        SUBROUTINE E1XA(X,E1)

        IMPLICIT NONE
        REAL*8 X,E1,ES1,ES2

        IF (X.EQ.0.0) THEN
           E1=1.0D+300
        ELSE IF (X.LE.1.0) THEN
           E1=-DLOG(X)+((((1.07857D-3*X-9.76004D-3)*X+5.519968D-2)*X-0.24991055D0)*X+0.99999193D0)*X-0.57721566D0
        ELSE
           ES1=(((X+8.5733287401D0)*X+18.059016973D0)*X+8.6347608925D0)*X+0.2677737343D0
           ES2=(((X+9.5733223454D0)*X+25.6329561486D0)*X+21.0996530827D0)*X+3.9584969228D0
           E1=DEXP(-X)/X*ES1/ES2
        ENDIF
        RETURN
        END SUBROUTINE E1XA

!
!  ============================================================================
!        Purpose: This program computes the exponential integral
!                 Ei(x) using subroutine EIX
!   Licensing:
!
!     This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,
!     they give permission to incorporate this routine into a user program
!     provided that the copyright is acknowledged.
!
!   Author:
!
!     Shanjie Zhang, Jianming Jin
!
!   Reference:
!
!     Shanjie Zhang, Jianming Jin,
!     Computation of Special Functions,
!     Wiley, 1996,
!     ISBN: 0-471-11963-6,
!     LC: QA351.C45.
!
!   Modified on:
!     25 July 2017, by Yingyi Liu
!
!   Parameters:
!        Input :  x  --- Argument of Ei(x)
!        Output:  EI --- Ei(x) ( x > 0 )
!        Example:
!                   x        Ei(x)
!                 -----------------------
!                   0    -.10000000+301
!                   1     .18951178E+01
!                   2     .49542344E+01
!                   3     .99338326E+01
!                   4     .19630874E+02
!                   5     .40185275E+02
!  ============================================================================

        SUBROUTINE EIX(X,EI)

        IMPLICIT NONE
        INTEGER K
        REAL*8 X,EI,R,GA

        IF (X.EQ.0.0) THEN
           EI=-1.0D+300
        ELSE IF (X.LE.40.0) THEN
           EI=1.0D0
           R=1.0D0
           DO K=1,100
              R=R*K*X/(K+1.0D0)**2
              EI=EI+R
              IF (DABS(R/EI).LE.1.0D-15) EXIT
           ENDDO
           GA=0.5772156649015328D0
           EI=GA+DLOG(X)+X*EI
        ELSE
           EI=1.0D0
           R=1.0D0
           DO K=1,20
              R=R*K/X
              EI=EI+R
           ENDDO
           EI=DEXP(X)/X*EI
        ENDIF
        RETURN
        END SUBROUTINE EIX

!
!  ============================================================================
!        Purpose: This program computes the gamma function
!                 GAMMA(x) for x > 0 or its logarithm using
!                 subroutine LGAMA
!   Licensing:
!
!     This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,
!     they give permission to incorporate this routine into a user program
!     provided that the copyright is acknowledged.
!
!   Author:
!
!     Shanjie Zhang, Jianming Jin
!
!   Reference:
!
!     Shanjie Zhang, Jianming Jin,
!     Computation of Special Functions,
!     Wiley, 1996,
!     ISBN: 0-471-11963-6,
!     LC: QA351.C45.
!
!   Modified on:
!     25 July 2017, by Yingyi Liu
!
!   Parameters:
!        Purpose: Compute gamma function GAMMA(x) or ln[GAMMA(x)]
!        Input:   x  --- Argument of GAMMA(x) ( x > 0 )
!                 KF --- Function code
!                        KF=1 for GAMMA(x); KF=0 for ln[GAMMA(x)]
!        Output:  GL --- GAMMA(x) or ln[GAMMA(x)]
!        Examples:
!                   x           GAMMA(x)
!                 -------------------------
!                  0.5     .1772453851D+01
!                  2.5     .1329340388D+01
!                  5.0     .2400000000D+02
!                  7.5     .1871254306D+04
!                 10.0     .3628800000D+06
!  ============================================================================

        SUBROUTINE LGAMA(KF,X,GL)

        IMPLICIT NONE
        INTEGER K,KF,N
        REAL*8 X,X0,GL,X2,XP,GL0

        REAL*8 A(10)
        DATA A/8.333333333333333D-02,-2.777777777777778D-03,     &
               7.936507936507937D-04,-5.952380952380952D-04,     &
               8.417508417508418D-04,-1.917526917526918D-03,     &
               6.410256410256410D-03,-2.955065359477124D-02,     &
               1.796443723688307D-01,-1.39243221690590D+00/

        X0=X
        IF (X.EQ.1.0.OR.X.EQ.2.0) THEN
           GL=0.0D0
           IF (KF.EQ.1) GL=DEXP(GL)
        ELSE IF (X.LE.7.0) THEN
           N=INT(7-X)
           X0=X+N
           X2=1.0D0/(X0*X0)
           XP=6.283185307179586477D0
           GL0=A(10)
           DO K=9,1,-1
            GL0=GL0*X2+A(K)
           ENDDO
           GL=GL0/X0+0.5D0*DLOG(XP)+(X0-.5D0)*DLOG(X0)-X0
           IF (X.LE.7.0) THEN
              DO K=1,N
                 GL=GL-DLOG(X0-1.0D0)
                 X0=X0-1.0D0
              ENDDO
           ENDIF
           IF (KF.EQ.1) GL=DEXP(GL)
        ENDIF

        RETURN
        END SUBROUTINE LGAMA

!-----------------------------------------------------------------------------
!+ Finds the limit of a series
      SUBROUTINE Limes      &
      (   N,        &      ! in
          S,        &      ! inout
          rLimes,      &      ! out
          i_Pade,      &      ! out
          k_Pade,     &       ! out
          err  )             ! out

! Description:
!   Finds the limit of a series in the case where only
!   the first N+1 terms are known.
!
! Method:
!   The subroutine operates by applying the epsilon-algorithm
!   to the sequence of partial sums of a seris supplied on input.
!   For desciption of the algorithm, please see:
!
!   [1] T. Mishonov and E. Penev, Int. J. Mod. Phys. B 14, 3831 (2000)
!
! Owners: Todor Mishonov & Evgeni Penev
!
! History:
! Version   Date         Comment
! =======   ====         =======
! 1.0       01/04/2000   Original code. T. Mishonov & E. Penev
!
! Code Description:
!   Language:           Fortran 90.
!   Software Standards: "European Standards for Writing and
!                        Documenting Exchangeable Fortran 90 Code".
!
! Declarations:
       IMPLICIT NONE

!* Subroutine arguments
!  Scalar arguments with intent(in):
       INTEGER,   INTENT (IN)    :: N       ! width of the epsilon-table

!  Array arguments with intent(inout):
       REAL*8, INTENT (INOUT) :: S(0:N)   ! sequential row of the epsilon-table

!  Scalar arguments with intent(out)
       REAL*8, INTENT (OUT)   :: rLimes  ! value of the series limes
       INTEGER,   INTENT (OUT)   :: i_Pade  ! power of the numerator
       INTEGER,   INTENT (OUT)   :: k_Pade  ! power of the denominator
       REAL*8, INTENT (OUT)   :: err     ! empirical error

!* End of Subroutine arguments

!  Local parameters                    ! these two need no description ;-)
       REAL*8,    PARAMETER   :: zero = 0.0
       REAL*8,    PARAMETER   :: one  = 1.0

!  Local scalars
       REAL*8                 :: A_max   ! maximum element of A
       INTEGER                   :: i       ! index variable for columns
       INTEGER                   :: k       ! index variable for rows

!  Local arrays
       REAL*8                 :: A(0:N)  ! auxiliary row of the epsilon-table

!- End of header --------------------------------------------------------------

!  Parse input: the algorithm cannot employ more elements than supplied on
!               input, i.e. N <= size(S)
!
      IF ( N > SIZE (S(:)) ) THEN
      WRITE (*, '(A)') '*** Illegal input to Limes: N > size(S)'
       STOP 1
      END IF

!  Algorithm not applicable for N < 2
!
      IF ( N < 2 ) THEN
      WRITE (*, '(A)') '*** Illegal input to Limes: N < 2'
       STOP 2
      END IF

!-----------------------------------------------------------------------------
!  I. Initialize with natural assignments
!-----------------------------------------------------------------------------

      rLimes = S(N)                    ! the N-th partial sum
      err    = ABS ( S(N) - S(N-1) )   ! error -> |S(N) - S(N-1)|
      i_Pade = N                       ! Pade approximant [N/0]
      k_Pade = 0                       !
      A(:)   = zero                ! auxiliary row initially set to zero
      A_max  = zero                ! max. element set to zero
      k      = 1                   ! algorithm starts from the first row

!-----------------------------------------------------------------------------
! II. Main loop: fill in the epsilon table, check for convergence ...
!     (provision against devision by zero employs pseudo-inverse numbers)
!-----------------------------------------------------------------------------
      DO
       IF ( N - 2 * k + 1 < 0 ) EXIT

! Update the auxiliary row A(i) of the epsilon-table
! by applying the "cross rule".
!
      DO i=0, N - 2 * k + 1
       IF ( S(i+1) /= S(i) ) THEN
        A(i) = A(i+1) + one/(S(i+1) - S(i))
       ELSE
        A(i) = A(i+1)
       END IF
      END DO
      IF ( N - 2 * k < 0 ) EXIT

!  Update the sequential row S(i) of the epsilon-table
!  by applying the "cross rule".
!
      DO i=0, N - 2 * k
       IF ( A(i+1) /= A(i) ) THEN
        S(i) = S(i+1) + one/(A(i+1) - A(i))
       ELSE
        S(i) = S(i+1)
       END IF

!  Check for convergence, based on A_max; see Ref. [1]
!
       IF ( ABS ( A(i) ) > A_max ) THEN
        A_max  = ABS ( A(i) )
        rLimes = S(i)
        k_Pade = k
        i_Pade = i + k_Pade
        err    = one/A_max
        IF ( S(i+1) == S(i) ) RETURN
       END IF
      END DO
       k = k + 1      ! increment row index
      END DO

      END SUBROUTINE Limes

!
!  ============================================================================
!        Purpose: Compute modified Bessel functions I0(x), I1(1),
!                 K0(x) and K1(x), and their derivatives
!   Licensing:
!
!     This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,
!     they give permission to incorporate this routine into a user program
!     provided that the copyright is acknowledged.
!
!   Author:
!
!     Shanjie Zhang, Jianming Jin
!
!   Reference:
!
!     Shanjie Zhang, Jianming Jin,
!     Computation of Special Functions,
!     Wiley, 1996,
!     ISBN: 0-471-11963-6,
!     LC: QA351.C45.
!
!   Modified on:
!     25 July 2017, by Yingyi Liu
!
!   Parameters:
!        Input :  x   --- Argument ( x � 0 )
!        Output:  BK0 --- K0(x)
!                 BK1 --- K1(x)
!  ============================================================================
!

        SUBROUTINE IK01A(X,BK0,BK1)

        IMPLICIT NONE
        INTEGER K,K0
        REAL*8 PI,EL,X,X2,BI0,BI1,BK0,BK1,R,XR,CA,CT,W0,WW,CB,XR2
        REAL*8 A(12),B(12),A1(8)

        PI=3.141592653589793D0
        EL=0.5772156649015329D0
        X2=X*X
        IF (X.EQ.0.0D0) THEN
           BI0=1.0D0
           BI1=0.0D0
           BK0=1.0D+300
           BK1=1.0D+300
           RETURN
        ELSE IF (X.LE.18.0D0) THEN
           BI0=1.0D0
           R=1.0D0
           DO K=1,50
              R=0.25D0*R*X2/(K*K)
              BI0=BI0+R
              IF (DABS(R/BI0).LT.1.0D-15) EXIT
           ENDDO
           BI1=1.0D0
           R=1.0D0
           DO K=1,50
              R=0.25D0*R*X2/(K*(K+1))
              BI1=BI1+R
              IF (DABS(R/BI1).LT.1.0D-15) EXIT
           ENDDO
           BI1=0.5D0*X*BI1
        ELSE
           DATA A/0.125D0,7.03125D-2,                 &
                  7.32421875D-2,1.1215209960938D-1,     &
                  2.2710800170898D-1,5.7250142097473D-1,     &
                  1.7277275025845D0,6.0740420012735D0,     &
                  2.4380529699556D01,1.1001714026925D02,     &
                  5.5133589612202D02,3.0380905109224D03/
           DATA B/-0.375D0,-1.171875D-1,               &
                  -1.025390625D-1,-1.4419555664063D-1,     &
                  -2.7757644653320D-1,-6.7659258842468D-1,     &
                  -1.9935317337513D0,-6.8839142681099D0,     &
                  -2.7248827311269D01,-1.2159789187654D02,     &
                  -6.0384407670507D02,-3.3022722944809D03/
           K0=12
           IF (X.GE.35.0) K0=9
           IF (X.GE.50.0) K0=7
           CA=DEXP(X)/DSQRT(2.0D0*PI*X)
           BI0=1.0D0
           XR=1.0D0/X
           DO K=1,K0
              BI0=BI0+A(K)*XR**K
           ENDDO
           BI0=CA*BI0
           BI1=1.0D0
           DO K=1,K0
              BI1=BI1+B(K)*XR**K
           ENDDO
           BI1=CA*BI1
        ENDIF
        IF (X.LE.9.0D0) THEN
           CT=-(DLOG(X/2.0D0)+EL)
           BK0=0.0D0
           W0=0.0D0
           R=1.0D0
           DO K=1,50
              W0=W0+1.0D0/K
              R=0.25D0*R/(K*K)*X2
              BK0=BK0+R*(W0+CT)
              IF (DABS((BK0-WW)/BK0).LT.1.0D-15) EXIT
              WW=BK0
           ENDDO
           BK0=BK0+CT
        ELSE
           DATA A1/0.125D0,0.2109375D0,                &
                   1.0986328125D0,1.1775970458984D01,     &
                   2.1461706161499D02,5.9511522710323D03,     &
                   2.3347645606175D05,1.2312234987631D07/
           CB=0.5D0/X
           XR2=1.0D0/X2
           BK0=1.0D0
           DO K=1,8
            BK0=BK0+A1(K)*XR2**K
           ENDDO
           BK0=CB*BK0/BI0
        ENDIF
        BK1=(1.0D0/X-BI1*BK0)/BI0

        RETURN
        END SUBROUTINE IK01A

!
!  ============================================================================
!        Purpose: Compute Bessel functions J0(x), J1(x), Y0(x),
!                 Y1(x), and their derivatives
!   Licensing:
!
!     This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,
!     they give permission to incorporate this routine into a user program
!     provided that the copyright is acknowledged.
!
!   Author:
!
!     Shanjie Zhang, Jianming Jin
!
!   Reference:
!
!     Shanjie Zhang, Jianming Jin,
!     Computation of Special Functions,
!     Wiley, 1996,
!     ISBN: 0-471-11963-6,
!     LC: QA351.C45.
!
!   Modified on:
!     25 July 2017, by Yingyi Liu
!
!   Parameters:
!        Input :  x   --- Argument of Jn(x) & Yn(x) ( x � 0 )
!        Output:  BJ0 --- J0(x)
!                 BJ1 --- J1(x)
!                 BY0 --- Y0(x)
!                 BY1 --- Y1(x)
!  ============================================================================
!
        SUBROUTINE JY01B(X,BJ0,BJ1,BY0,BY1)

        IMPLICIT NONE
        REAL*8 PI,X,BJ0,BY0,T,T2,A0,P0,Q0,TA0,BJ1,BY1,P1,Q1,TA1

        PI=3.141592653589793D0
        IF (X.EQ.0.0D0) THEN
           BJ0=1.0D0
           BJ1=0.0D0
           BY0=-1.0D+300
           BY1=-1.0D+300
           RETURN
        ELSE IF (X.LE.4.0D0) THEN
           T=X/4.0D0
           T2=T*T
           BJ0=((((((-.5014415D-3*T2+.76771853D-2)*T2-.0709253492D0)*T2+.4443584263D0)    &
                *T2-1.7777560599D0)*T2+3.9999973021D0)*T2-3.9999998721D0)*T2+1.0D0
           BJ1=T*(((((((-.1289769D-3*T2+.22069155D-2)*T2-.0236616773D0)*T2+.1777582922D0)  &
                *T2-.8888839649D0)*T2+2.6666660544D0)*T2-3.9999999710D0)*T2+1.9999999998D0)
           BY0=(((((((-.567433D-4*T2+.859977D-3)*T2-.94855882D-2)*T2+.0772975809D0)*T2-.4261737419D0)  &
               *T2+1.4216421221D0)*T2-2.3498519931D0)*T2+1.0766115157)*T2+.3674669052D0
           BY0=2.0D0/PI*DLOG(X/2.0D0)*BJ0+BY0
           BY1=((((((((.6535773D-3*T2-.0108175626D0)*T2+.107657606D0)*T2-.7268945577D0)*T2+3.1261399273D0)  &
               *T2-7.3980241381D0)*T2+6.8529236342D0)*T2+.3932562018D0)*T2-.6366197726D0)/X
           BY1=2.0D0/PI*DLOG(X/2.0D0)*BJ1+BY1
        ELSE
           T=4.0D0/X
           T2=T*T
           A0=DSQRT(2.0D0/(PI*X))
           P0=((((-.9285D-5*T2+.43506D-4)*T2-.122226D-3)*T2+.434725D-3)*T2-.4394275D-2)*T2+.999999997D0
           Q0=T*(((((.8099D-5*T2-.35614D-4)*T2+.85844D-4)*T2-.218024D-3)*T2+.1144106D-2)*T2-.031249995D0)
           TA0=X-.25D0*PI
           BJ0=A0*(P0*DCOS(TA0)-Q0*DSIN(TA0))
           BY0=A0*(P0*DSIN(TA0)+Q0*DCOS(TA0))
           P1=((((.10632D-4*T2-.50363D-4)*T2+.145575D-3)*T2-.559487D-3)*T2+.7323931D-2)*T2+1.000000004D0
           Q1=T*(((((-.9173D-5*T2+.40658D-4)*T2-.99941D-4)*T2+.266891D-3)*T2-.1601836D-2)*T2+.093749994D0)
           TA1=X-.75D0*PI
           BJ1=A0*(P1*DCOS(TA1)-Q1*DSIN(TA1))
           BY1=A0*(P1*DSIN(TA1)+Q1*DCOS(TA1))
        ENDIF

        RETURN
        END SUBROUTINE JY01B

!
!  ============================================================================
!        Purpose: Compute Bessel functions J0(x), J1(x), Y0(x),
!                 Y1(x), and their derivatives
!   Licensing:
!
!     This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,
!     they give permission to incorporate this routine into a user program
!     provided that the copyright is acknowledged.
!
!   Author:
!
!     Shanjie Zhang, Jianming Jin
!
!   Reference:
!
!     Shanjie Zhang, Jianming Jin,
!     Computation of Special Functions,
!     Wiley, 1996,
!     ISBN: 0-471-11963-6,
!     LC: QA351.C45.
!
!   Modified on:
!     25 July 2017, by Yingyi Liu
!
!   Description:
!     This is a derived version from the subroutine JY01B.
!
!   Parameters:
!        Input :  x   --- Argument of Jn(x) & Yn(x) ( x � 0 )
!        Output:  BJ0 --- J0(x)
!                 BJ1 --- J1(x)
!  ============================================================================
!
        SUBROUTINE JY01BJ(X,BJ0,BJ1)

        IMPLICIT NONE
        REAL*8 PI,X,BJ0,BJ1,T,T2,A0,P0,Q0,TA0,P1,Q1,TA1

        PI=3.141592653589793D0
        IF (X.EQ.0.0D0) THEN
           BJ0=1.0D0
           BJ1=0.0D0
           RETURN
        ELSE IF (X.LE.4.0D0) THEN
           T=X/4.0D0
           T2=T*T
           BJ0=((((((-.5014415D-3*T2+.76771853D-2)*T2-.0709253492D0)*T2+.4443584263D0)    &
               *T2-1.7777560599D0)*T2+3.9999973021D0)*T2-3.9999998721D0)*T2+1.0D0
           BJ1=T*(((((((-.1289769D-3*T2+.22069155D-2)*T2-.0236616773D0)*T2+.1777582922D0)   &
               *T2-.8888839649D0)*T2+2.6666660544D0)*T2-3.9999999710D0)*T2+1.9999999998D0)
        ELSE
           T=4.0D0/X
           T2=T*T
           A0=DSQRT(2.0D0/(PI*X))
           P0=((((-.9285D-5*T2+.43506D-4)*T2-.122226D-3)*T2+.434725D-3)*T2-.4394275D-2)*T2+.999999997D0
           Q0=T*(((((.8099D-5*T2-.35614D-4)*T2+.85844D-4)*T2-.218024D-3)*T2+.1144106D-2)*T2-.031249995D0)
           TA0=X-.25D0*PI
           BJ0=A0*(P0*DCOS(TA0)-Q0*DSIN(TA0))
           P1=((((.10632D-4*T2-.50363D-4)*T2+.145575D-3)*T2-.559487D-3)*T2+.7323931D-2)*T2+1.000000004D0
           Q1=T*(((((-.9173D-5*T2+.40658D-4)*T2-.99941D-4)*T2+.266891D-3)*T2-.1601836D-2)*T2+.093749994D0)
           TA1=X-.75D0*PI
           BJ1=A0*(P1*DCOS(TA1)-Q1*DSIN(TA1))
        ENDIF

        RETURN
        END SUBROUTINE JY01BJ

!
!  ============================================================================
!        Purpose: Compute Bessel functions J0(x), J1(x), Y0(x),
!                 Y1(x), and their derivatives
!   Licensing:
!
!     This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,
!     they give permission to incorporate this routine into a user program
!     provided that the copyright is acknowledged.
!
!   Author:
!
!     Shanjie Zhang, Jianming Jin
!
!   Reference:
!
!     Shanjie Zhang, Jianming Jin,
!     Computation of Special Functions,
!     Wiley, 1996,
!     ISBN: 0-471-11963-6,
!     LC: QA351.C45.
!
!   Modified on:
!     25 July 2017, by Yingyi Liu
!
!   Description:
!     This is a derived version from the subroutine JY01B.
!
!   Parameters:
!        Input :  x   --- Argument of Jn(x) & Yn(x) ( x � 0 )
!        Output:  BJ0 --- J0(x)
!                 BJ1 --- J1(x)
!                 BY0 --- Y0(x)
!                 BY1 --- Y1(x)
!  ============================================================================
!
        SUBROUTINE JY01BY0(X,BY0)

        IMPLICIT NONE
        REAL*8 PI,X,BJ0,BY0,T,T2,A0,P0,Q0,TA0

        PI=3.141592653589793D0
        IF (X.EQ.0.0D0) THEN
           BJ0=1.0D0
           BY0=-1.0D+300
           RETURN
        ELSE IF (X.LE.4.0D0) THEN
           T=X/4.0D0
           T2=T*T
           BJ0=((((((-.5014415D-3*T2+.76771853D-2)*T2-.0709253492D0)*T2+.4443584263D0)   &
               *T2-1.7777560599D0)*T2+3.9999973021D0)*T2-3.9999998721D0)*T2+1.0D0
           BY0=(((((((-.567433D-4*T2+.859977D-3)*T2-.94855882D-2)*T2+.0772975809D0)*T2    &
                -.4261737419D0)*T2+1.4216421221D0)*T2-2.3498519931D0)*T2+1.0766115157)*T2+.3674669052D0
           BY0=2.0D0/PI*DLOG(X/2.0D0)*BJ0+BY0
        ELSE
           T=4.0D0/X
           T2=T*T
           A0=DSQRT(2.0D0/(PI*X))
           P0=((((-.9285D-5*T2+.43506D-4)*T2-.122226D-3)*T2+.434725D-3)*T2-.4394275D-2)*T2+.999999997D0
           Q0=T*(((((.8099D-5*T2-.35614D-4)*T2+.85844D-4)*T2-.218024D-3)*T2+.1144106D-2)*T2-.031249995D0)
           TA0=X-.25D0*PI
           BY0=A0*(P0*DSIN(TA0)+Q0*DCOS(TA0))
        ENDIF

        RETURN
        END SUBROUTINE JY01BY0

!
!  ============================================================================
!        Purpose: Compute Bessel functions J0(x), J1(x), Y0(x),
!                 Y1(x), and their derivatives
!   Licensing:
!
!     This routine is copyrighted by Shanjie Zhang and Jianming Jin.  However,
!     they give permission to incorporate this routine into a user program
!     provided that the copyright is acknowledged.
!
!   Author:
!
!     Shanjie Zhang, Jianming Jin
!
!   Reference:
!
!     Shanjie Zhang, Jianming Jin,
!     Computation of Special Functions,
!     Wiley, 1996,
!     ISBN: 0-471-11963-6,
!     LC: QA351.C45.
!
!   Modified on:
!     25 July 2017, by Yingyi Liu
!
!   Description:
!     This is a derived version from the subroutine JY01B.
!
!   Parameters:
!        Input :  x   --- Argument of Jn(x) & Yn(x) ( x � 0 )
!        Output:  BY1 --- Y1(x)
!  ============================================================================
!
        SUBROUTINE JY01BY1(X,BY1)

        IMPLICIT NONE
        REAL*8 PI,X,BJ1,BY1,T,T2,A0,P1,Q1,TA1

        PI=3.141592653589793D0
        IF (X.EQ.0.0D0) THEN
           BJ1=0.0D0
           BY1=-1.0D+300
           RETURN
        ELSE IF (X.LE.4.0D0) THEN
           T=X/4.0D0
           T2=T*T
           BJ1=T*(((((((-.1289769D-3*T2+.22069155D-2)*T2-.0236616773D0)*T2+.1777582922D0)   &
               *T2-.8888839649D0)*T2+2.6666660544D0)*T2-3.9999999710D0)*T2+1.9999999998D0)
           BY1=((((((((.6535773D-3*T2-.0108175626D0)*T2+.107657606D0)*T2-.7268945577D0)*T2+3.1261399273D0)    &
                *T2-7.3980241381D0)*T2+6.8529236342D0)*T2+.3932562018D0)*T2-.6366197726D0)/X
           BY1=2.0D0/PI*DLOG(X/2.0D0)*BJ1+BY1
        ELSE
           T=4.0D0/X
           T2=T*T
           A0=DSQRT(2.0D0/(PI*X))
           P1=((((.10632D-4*T2-.50363D-4)*T2+.145575D-3)*T2-.559487D-3)*T2+.7323931D-2)*T2+1.000000004D0
           Q1=T*(((((-.9173D-5*T2+.40658D-4)*T2-.99941D-4)*T2+.266891D-3)*T2-.1601836D-2)*T2+.093749994D0)
           TA1=X-.75D0*PI
           BY1=A0*(P1*DSIN(TA1)+Q1*DCOS(TA1))
        ENDIF

        RETURN
        END SUBROUTINE JY01BY1
!-------------------------------------------------------------------------------
      END MODULE FinGrnExtSubs
!*******************************************************************************


! The program defines arrays in different ways

program arrayProg

implicit none

real :: numbers(5)              ! one dimensional integer array
integer :: matrix(3,3), i, j    ! two dimensional real 3x3 array

! assiging values to the array

do i = 1,5
    numbers(i) = i * 2.0
end do

! display the values

do i = 1,5
    print*, numbers(i)
end do

! assigning values to the array matrix

do i = 1,3
    do j = 1,3
        matrix(i, j) = i + j
    end do
end do

! display the values

do i=1,3
    do j = 1, 3
        Print *, matrix(i,j)
    end do
end do

!short hand assignment
numbers = (/1.5, 3.2,4.5,0.9,7.2 /)

!display the values

do i = 1, 5
    Print *, numbers(i)
end do

end program arrayProg


module continued_fractions
  implicit none

  integer, parameter :: long = selected_real_kind(7,99)

  type continued_fraction
    integer                            :: a0, b1
    procedure(series), pointer, nopass :: a, b
  end type

  interface
    pure function series (n)
      integer, intent(in) :: n
      integer             :: series
    end function
  end interface

contains

  pure function define_cf (a0,a,b1,b) result(x)
    integer, intent(in)           :: a0
    procedure(series)             :: a
    integer, intent(in), optional :: b1
    procedure(series),   optional :: b
    type(continued_fraction)      :: x
    x%a0 = a0
    x%a => a
    if ( present(b1) ) then
       x%b1 = b1
    else
       x%b1 = 1
    end if
    if ( present(b) ) then
       x%b => b
    else
       x%b => const_1
    end if
  end function define_cf

  pure integer function const_1(n)
    integer,intent(in) :: n
    const_1 = 1
  end function

  pure real(kind=long) function output(x,iterations)
    type(continued_fraction), intent(in) :: x
    integer,                  intent(in) :: iterations
    integer                              :: i
    output = x%a(iterations)
    do i = iterations-1,1,-1
      output = x%a(i) + (x%b(i+1) / output)
    end do
    output = x%a0 + (x%b1 / output)
  end function output

end module continued_fractions

program examples
  use continued_fractions

  type(continued_fraction) :: sqr2,napier,pi

  sqr2   = define_cf(1,a_sqr2)
  napier = define_cf(2,a_napier,1,b_napier)
  pi     = define_cf(3,a=a_pi,b=b_pi)

  write (*,*) output(sqr2,10000)
  write (*,*) output(napier,10000)
  write (*,*) output(pi,10000)

contains

  pure integer function a_sqr2(n)
    integer,intent(in) :: n
    a_sqr2 = 2
  end function

  pure integer function a_napier(n)
    integer,intent(in) :: n
    a_napier = n
  end function

  pure integer function b_napier(n)
    integer,intent(in) :: n
    b_napier = n-1
  end function

  pure integer function a_pi(n)
    integer,intent(in) :: n
    a_pi = 6
  end function

  pure integer function b_pi(n)
    integer,intent(in) :: n
    b_pi = (2*n-1)*(2*n-1)
  end function

end program examples


      PROGRAM xratint
C     driver for routine ratint
      INTEGER NPT
      REAL EPSSQ
      PARAMETER(NPT=6,EPSSQ=1.0)
      INTEGER i
      REAL dyy,f,xx,yexp,yy,z,x(NPT),y(NPT)
      f(z)=z*exp(-z)/((z-1.0)**2+EPSSQ)
      do 11 i=1,NPT
        x(i)=i*2.0/NPT
        y(i)=f(x(i))
11    continue
      write(*,'(/1x,a/)') 'Diagonal rational function interpolation'
      write(*,'(1x,t6,a,t13,a,t26,a,t40,a)')
     *     'x','interp.','accuracy','actual'
      do 12 i=1,10
        xx=0.2*i
        call ratint(x,y,NPT,xx,yy,dyy)
        yexp=f(xx)
        write(*,'(1x,f6.2,f12.6,e15.4,f12.6)') xx,yy,dyy,yexp
12    continue
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xratint.for


module gauss
  use utils
  implicit none

  contains
  subroutine eliminate(A, X, n)
    integer(kind=8), intent(in) :: n
    real(kind = iKIND), intent(inout) :: A(0:N, 0:N), X(0:N)
    real(kind = iKIND) :: ratio
    integer(kind=8) :: i, j

    do i = 0, N
      ! scale row i to have 1 on the diagonal
      X(i) = X(i) / A(i, i)
      A(:, i) = A(:, i) / A(i, i)
      do j = 0, N
        IF ((i .NE. j) .AND. (A(i, i) .NE. 0)) THEN
          ratio = A(i, j) / A(i, i)
          A(:,j) = A(:,j) - ratio * A(:, i)
          X(j) = X(j) - ratio * x(i)
        END IF
      END DO
    END DO
  end subroutine eliminate
end module gauss


module mod_diff

  use iso_fortran_env, only: int32, real32
  implicit none

  private
  public :: diff_upwind, diff_centered, diff_centered_periodic

contains

  pure function diff_centered(x) result(dx)
    ! Returns a 2nd order centered difference of a 1-d array,
    ! with periodic boundary condition.
    real(real32), intent(in) :: x(:)
    real(real32) :: dx(size(x))
    integer(int32) :: im
    im = size(x)
    dx = 0
    dx(2:im-1) = x(3:im) - x(1:im-2)
    dx = 0.5 * dx
  end function diff_centered

  pure function diff_centered_periodic(x) result(dx)
    ! Returns a 2nd order centered difference of a 1-d array,
    ! with periodic boundary condition.
    real(real32), intent(in) :: x(:)
    real(real32) :: dx(size(x))
    integer(int32) :: im
    im = size(x)
    dx(1) = x(2) - x(im)
    dx(im) = x(1) - x(im-1)
    dx(2:im-1) = x(3:im) - x(1:im-2)
    dx = 0.5 * dx
  end function diff_centered_periodic

  pure function diff_upwind(x) result(dx)
    ! Returns a 1st-order upstream finite difference of a 1-d array,
    ! with periodic boundary condition.
    real(real32), intent(in) :: x(:)
    real(real32) :: dx(size(x))
    integer(int32) :: im
    im = size(x)
    dx(1) = x(1) - x(im)
    dx(2:im) = x(2:im) - x(1:im-1)
  end function diff_upwind

end module mod_diff


module main

implicit none

contains

        function mult_3_5 (i) result (res)

                integer :: i
                logical :: res

                res = ((mod(i, 3) == 0) .OR. (mod(i, 5) == 0))

        end function mult_3_5

end module main

program euler

use main

implicit none

        integer :: top, sumx, i

        top = 1000
        sumx = 0

        do i = 1, TOP - 1, 1
                if (mult_3_5(i)) then
                        sumx = sumx + i
                end if
        end do

        print *, "", sumx

end program euler