*deck aratio_tri
      subroutine aratio_tri(xl1,yl1,zl1,
     *                      xl2,yl2,zl2,
     *                      xl3,yl3,zl3,
     *                      arattri)
C
C
C #####################################################################
C
C     PURPOSE -
C
C        Finds the aspect ratio of a tri.
C
C     INPUT ARGUMENTS -
C
C        (x1,y1,z1),...,(x3,y3,z3) - The coordinates of the tri.
C
C     OUTPUT ARGUMENTS -
C
C        arattri : The aspect ratio of the tri.
C
C     CHANGE HISTORY -
C
C $Log: aratio_tri.f,v $
C Revision 2.00  2007/11/05 19:45:46  spchu
C Import to CVS
C
CPVCS
CPVCS       Rev 1.1   Fri Jan 08 16:58:28 1999   kuprat
CPVCS    We now prevent zero divides using SAFE.
CPVCS
CPVCS       Rev 1.0   Fri Aug 29 14:11:34 1997   dcg
CPVCS    Initial revision.
C
C ######################################################################
C
C
      implicit none
C
      include "consts.h"
      include "local_element.h"
C
      real*8 xl1,yl1,zl1,xl2,yl2,zl2,xl3,yl3,zl3
      real*8 arattri
      real*8 rcir
      real*8 rinsc
      real*8 ax4,ay4,az4,farea
      real*8 ds1,ds2,ds3

      include "statementfunctions.h"
C
C ######################################################################
C
      ax4 = (yl3 - yl1)*(zl2 - zl1)-(zl3-zl1)*(yl2-yl1)
      ay4 = -((xl3 - xl1)*(zl2 - zl1)-(zl3 - zl1)*
     *        (xl2 - xl1))
      az4 = (xl3 - xl1)*(yl2 - yl1)-(yl3 - yl1)*
     *      (xl2 - xl1)
C  radius of inscribed circle is 2*area of triangle/perimeter
C  radius of circumscribed circle is l1*l2*l3/4*area where l1,l2,l3 are edge
C  lengths
C
      farea=.5*sqrt(ax4**2+ay4**2+az4**2)
      ds1 = sqrt((xl3 - xl2)**2+(yl3 - yl2)**2+
     *           (zl3 - zl2)**2)
      ds2 = sqrt((xl1 - xl3)**2+(yl1 - yl3)**2+
     *           (zl1 - zl3)**2)
      ds3 = sqrt((xl2 - xl1)**2+(yl2 - yl1)**2 +
     *           (zl2 - zl1)**2)
      rinsc = 2.*farea/safe(ds1+ds2+ds3)
      rcir= ds1*ds2*ds3/safe(4.*farea)

      arattri= 2.*rinsc/safe(rcir)

      return
      end


SUBROUTINE R3x3 (R1, R2, R3)

! ----------------------------------------------------------------------
! SUBROUTINE: matrixRxR (matrix_RxR.f90)
! ----------------------------------------------------------------------
! Purpose:
!  Multiply 2 matrices 3x3
! ----------------------------------------------------------------------
! Input arguments:
! - R1 : Matrix 1 with dimensions 3x3
! - R1 : Matrix 2 with dimensions 3x3
!
! Output arguments:
! - R3 : Matrix 3x3 obtained from multiplication R1*R2
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou
!			Cooperative Research Centre for Spatial Information, Australia
! Created:	7 March 2018
! ----------------------------------------------------------------------

      USE mdl_precision
      IMPLICIT NONE

! ---------------------------------------------------------------------------
! Dummy arguments declaration
! ---------------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(3,3) :: R1, R2
! OUT
      REAL (KIND = prec_d), INTENT(OUT), DIMENSION(3,3) :: R3
! ---------------------------------------------------------------------------

! ----------------------------------------------------------------------
! Local variables declaration
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int8) :: R1_i, R1_j, R2_i, R2_j
      INTEGER (KIND = prec_int8) :: i, j, n, m
      REAL (KIND = prec_q) :: R3_ij
! ----------------------------------------------------------------------

      R1_i = size(R1, dim = 1)
      R1_j = size(R1, dim = 2)

      R2_i = size(R2, dim = 1)
      R2_j = size(R2, dim = 2)

      DO i = 1 , R1_i
        DO m = 1 , R2_j
        ! R3(i,m)
          R3_ij = 0.0D0
          DO j = 1 , R1_j
            n = j
			R3_ij = R1(i,j) * R2(n,m) + R3_ij
          End Do
          R3(i,m) = R3_ij
        End Do
      End Do

END SUBROUTINE


function logsum(N,X) result(Xsum)
    ! calculate log(sum exp(x))
    implicit none
    integer, intent(in) :: N ! length of X
    real(8), intent(in) :: X(N) ! data
    real(8) :: Xsum, maxv
    integer :: i
    maxv = maxval(X)
    Xsum = 0.0d0
    do i = 1, N
        Xsum = Xsum + exp(X(i) - maxv)
    enddo
    Xsum = log(Xsum) + maxv
end function

subroutine forward_F(T,N,lnpi,lnA,lnf,lnalpha)
    implicit none
    integer, intent(in) :: T,N
    real(8), intent(in) :: lnpi(N), lnA(N,N), lnf(T,N)
    real(8), intent(out) :: lnalpha(T,N)
    integer :: tt,i,j
    real(8) :: temp(N)
    real(8), external :: logsum

    lnalpha(1,:) = lnpi(:) + lnf(1,:)

    do tt = 2, T
        do j = 1, N
            temp(:) = lnalpha(tt-1,:) + lnA(:,j)
            lnalpha(tt,j) = logsum(N,temp) + lnf(tt,j)
        enddo
    enddo
end subroutine

subroutine backward_F(T,N,lnpi,lnA,lnf,lnbeta)
    implicit none
    integer, intent(in) :: T,N
    real(8), intent(in) :: lnpi(N), lnA(N,N), lnf(T,N)
    real(8), intent(out) :: lnbeta(T,N)
    integer :: tt,i,j
    real(8) :: temp(N)
    real(8), external :: logsum

    lnbeta(T,:) = 0.0d0

    do tt = T-1,1,-1
        do i = 1, N
            temp(:) = lnA(i,:) + lnf(tt+1,:) + lnbeta(tt+1,:)
            lnbeta(tt,i) = logsum(N,temp)
        enddo
    enddo
end subroutine

subroutine compute_lnEta_F(T,N,lnalpha,lnA,lnbeta,lnf,lnP_f,lneta)
    implicit none
    integer, intent(in) :: T,N
    real(8), intent(in) :: lnA(N,N), lnf(T,N), lnalpha(T,N), lnbeta(T,N), lnP_f
    real(8), intent(out) :: lneta(T-1,N,N)
    integer :: i,j,tt

    do tt = 1, T-1
        do i = 1, N
            do j = 1, N
                lneta(tt,i,j) = lnalpha(tt,i) + lnA(i,j) &
                    + lnf(tt+1,j) + lnbeta(tt+1,j) - lnP_f
            enddo
        enddo
    enddo
end subroutine

subroutine viterbi_F(T,N,lnpi,lnA,lnf,z,lnP)
    implicit none
    integer, intent(in) :: T,N
    real(8), intent(in) :: lnpi(N), lnA(N,N), lnf(T,N)
    integer(8), intent(out) :: z(T)
    real(8), intent(out) :: lnP
    integer :: tt,i,j,imax(1)
    real(8) :: lndelta(T,N)
    real(8) :: temp(N)

    ! Initialization
    lndelta(1,:) = lnpi + lnf(1,:)

    ! Induction
    do tt = 2, T
        do j = 1, N
            temp(:) = lndelta(tt-1,:) + lnA(:,j)
            lndelta(tt,j) = maxval(temp(:)) + lnf(tt,j)
        enddo
    enddo

    lnP = maxval(lndelta(T,:))

    ! Traceback
    imax = maxloc(lndelta(T,:))
    z(T) = imax(1)

    do tt = T-1, 1, -1
        imax = maxloc(lndelta(tt,:) + lnA(:,z(tt+1)))
        z(tt) = imax(1)
    enddo

    ! make numbering consistent to that of python
    z(:) = z(:) - 1

end subroutine


! Generic math subroutines
module math_mod

    implicit none
    real,parameter :: pi = 3.1415926535897932
    real,parameter :: infinity = huge(0.)

contains

function isinf(x) result(is)

  implicit none

  real,intent(in) :: x

  logical :: is

  ! Check for infinity
  if (x >= infinity) then
    is = .true.
  else
    is = .false.
  end if

end function isinf

subroutine math_plane_normal(p1,p2,p3,ans)
    implicit none
    real,dimension(3) :: p1,p2,p3,a,b,ans

    a = p2 - p1
    b = p3 - p1
    ans = cross(a,b)
end subroutine math_plane_normal

real function math_max(dim,vec)
    implicit none
    integer :: dim,i
    real :: vec(dim)
    math_max = vec(1)
    do i=1,dim
        if(vec(i) > math_max) math_max = vec(i)
    end do
end function math_max

real function math_length(dim,p1,p2)
    implicit none
    integer :: dim,i
    real,dimension(dim) :: p1,p2
    math_length = 0.0
    do i=1,dim
        math_length = math_length + (p2(i)-p1(i))**2
    end do
    math_length = sqrt(math_length)
end function math_length

subroutine math_reflect_point(A,B,C,D,P,ans)
    implicit none
    real :: A,B,C,D,P(3),ans(3),mult
    mult = 2.0*(A*P(1) + B*P(2) + C*P(3) + D)/(A**2 + B**2 + C**2)
    ans(1) = P(1) - mult*A
    ans(2) = P(2) - mult*B
    ans(3) = P(3) - mult*C
end subroutine math_reflect_point

real function math_mag(n,vec)
    implicit none
    integer :: n
    real :: vec(n)
    math_mag = sqrt(dot_product(vec,vec))
end function math_mag

function dist(a, b) result(c)
  ! Calculates the cartesian distance between 2 points

    implicit none

    real,dimension(3),intent(in) :: a, b
    real :: c

    c = sqrt(sum((a-b)**2))

end function dist

function cross(a, b) result(c)
  ! Calculates the cross-product of two 3-element vectors

    implicit none

    real :: a(3), b(3), c(3)

    c(1) = a(2)*b(3) - a(3)*b(2)
    c(2) = a(3)*b(1) - a(1)*b(3)
    c(3) = a(1)*b(2) - a(2)*b(1)

end function cross

function inner(a, b) result(c)
  ! Calculates the 3D Euclidean inner product

  implicit none
  real, dimension(3) :: a, b
  real :: c

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

end function inner

function inner2(a, b) result(c)
  ! Calculates the 2D Euclidean inner product

  implicit none
  real, dimension(2) :: a, b
  real :: c

  c = a(1)*b(1)+a(2)*b(2)

end function inner2

function outer(a, b) result(c)
  ! Calculates the outer product of two vectors

  implicit none

  real,dimension(3) :: a, b
  real,dimension(3,3) :: c

  integer :: i

  c = 0.

  do i=1,3
    c(i,:) = a(i)*b(:)
  end do

end function

function norm(a) result(c)
  ! Calculates the norm of the vector

  implicit none
  real, dimension(3) :: a
  real :: c

  c = sqrt(inner(a, a))

end function norm

function det3(a) result(c)
  ! Calculates the determinant of a 3x3 matrix

  implicit none

  real,dimension(3,3) :: a
  real :: c

  c = a(1,1)*(a(2,2)*a(3,3)-a(2,3)*a(3,2))
  c = c - a(1,2)*(a(2,1)*a(3,3)-a(2,3)*a(3,1))
  c = c + a(1,3)*(a(2,1)*a(3,2)-a(3,1)*a(2,2))

end function det3

subroutine math_rot_x(vec,th)
    implicit none
    real :: vec(3),th,rm(3,3),ans(3)

    rm(1,1) = 1.0;
    rm(1,2) = 0.0;
    rm(1,3) = 0.0;
    rm(2,1) = 0.0;
    rm(2,2) = cos(th);
    rm(2,3) = -sin(th);
    rm(3,1) = 0.0;
    rm(3,2) = sin(th);
    rm(3,3) = cos(th);
    ans = matmul(rm,vec)
    vec = ans
end subroutine math_rot_x

subroutine math_rot_y(vec,th)
    implicit none
    real :: vec(3),th,rm(3,3),ans(3)

    rm(1,1) = cos(th);
    rm(1,2) = 0.0;
    rm(1,3) = sin(th);
    rm(2,1) = 0.0;
    rm(2,2) = 1.0;
    rm(2,3) = 0.0;
    rm(3,1) = -sin(th);
    rm(3,2) = 0.0;
    rm(3,3) = cos(th);
        ans = matmul(rm,vec)
        vec = ans
end subroutine math_rot_y

subroutine math_rot_z(vec,th)
    implicit none
    real :: vec(3),th,rm(3,3),ans(3)

    rm(1,1) = cos(th);
    rm(1,2) = -sin(th);
    rm(1,3) = 0.0;
    rm(2,1) = sin(th);
    rm(2,2) = cos(th);
    rm(2,3) = 0.0;
    rm(3,1) = 0.0;
    rm(3,2) = 0.0;
    rm(3,3) = 1.0;
        ans = matmul(rm,vec)
        vec = ans
end subroutine math_rot_z

subroutine matinv(n, a, ai)
      ! This sobroutine inverts a matrix "a" and returns the inverse in "ai"
      ! n  - Input by user, an integer specifying the size of the matrix to be inverted.
      ! a  - Input by user, an n by n real array containing the matrix to be inverted.
      ! ai - Returned by subroutine, an n by n real array containing the inverted matrix.
      ! d  - Work array, an n by 2n real array used by the subroutine.
      ! io - Work array, a 1-dimensional integer array of length n used by the subroutine.
      ! THIS FUNCTION SHOULD NEVER BE callED! NEVER INVERT A MARTIX EXPLICITLY!
      ! Unless you know what you're doing. Odds are you may not, so be careful.

      implicit none

      integer :: n,i,j,k,m,itmp
      real :: a(n,n),ai(n,n),tmp,r
      real,allocatable,dimension(:,:) :: d
      integer,allocatable,dimension(:) :: io

      allocate(d(n,2*n))
      allocate(io(n))

      d(:,:) = 0.0
      io(:) = 0

!     Fill in the "io" and "d" matrix.
!     ********************************
      do i=1,n
         io(i)=i
      end do
      do i=1,n
         do j=1,n
            d(i,j)=a(i,j)
            if(i.eq.j)then
               d(i,n+j)=1.
            else
               d(i,n+j)=0.
            endif
         end do
      end do

!     Scaling
!     *******
      do i=1,n
         m=1
         do k=2,n
            if(abs(d(i,k)).gt.abs(d(i,m))) m=k
         end do
         tmp=d(i,m)
         do k=1,2*n
            d(i,k)=d(i,k)/tmp
         end do
      end do

!     Lower Elimination
!     *****************
      do i=1,n-1
!        Pivoting
!        ********
         m=i
         do j=i+1,n
            if(abs(d(io(j),i)).gt.abs(d(io(m),i))) m=j
         end do
         itmp=io(m)
         io(m)=io(i)
         io(i)=itmp
!        Scale the Pivot element to unity
!        ********************************
         r=d(io(i),i)
         do k=1,2*n
            d(io(i),k)=d(io(i),k)/r
         end do
!        ********************************
         do j=i+1,n
            r=d(io(j),i)
            do k=1,2*n
               d(io(j),k)=d(io(j),k)-r*d(io(i),k)
            end do
         end do
      end do

!     Upper Elimination
!     *****************
      r=d(io(n),n)
      do k=1,2*n
         d(io(n),k)=d(io(n),k)/r
      end do
      do i=n-1,1,-1
         do j=i+1,n
            r=d(io(i),j)
            do k=1,2*n
               d(io(i),k)=d(io(i),k)-r*d(io(j),k)
            end do
         end do
      end do

!     Fill Out "ai" matrix
      do i=1,n
         do j=1,n
            ai(i,j)=d(io(i),n+j)
         end do
      end do

      ! Cleanup
      deallocate(d)
      deallocate(io)

end subroutine matinv

function matmul_lu(n, A, x) result(b)
  ! Gives the matrix product [L][U]x = b where A = [L\U] (Doolittle LU decomposition)
  ! NOT TESTED

  implicit none

  integer,intent(in) :: n
  real,dimension(n,n),intent(in) :: A
  real,dimension(n),intent(in) :: x

  real,dimension(n) :: b, d
  integer :: i, j

  d = 0.

  ! [U]x = d
  do i=1,n
    do j=i,n
      d(i) = d(i) + A(i,j)*x(j)
    end do
  end do

  ! [L]x = b
  do i=1,n
    do j=1,i-1
      b(i) = b(i) + A(i,j)*d(j)
    end do
    b(i) = b(i) + d(i) ! L(i,i) = 1.
  end do

end function matmul_lu

subroutine lu_solve(n, A, b, x)
  ! Solves a general [A]x=b on an nxn matrix
  ! This replaces A (in place) with its LU decomposition (permuted row-wise)

    implicit none

    integer,intent(in) :: n
    real,dimension(n),intent(in) :: b
    real,dimension(:),allocatable,intent(out) :: x
    real,dimension(n,n),intent(inout) :: A

    integer,allocatable,dimension(:) :: indx
    integer :: D, info

    allocate(indx(n))

    ! Compute decomposition
    call lu_decomp(A, n, indx, D, info)

    ! if the matrix is nonsingular, then backsolve to find X
    if (info == 1) then
        write(*,*) 'Subroutine lu_solve() failed. The given matrix is singular (i.e. no solution). Quitting...'
        stop
    else
        call lu_back_sub(A, n, indx, b, x)
    end if

    ! Cleanup
    deallocate(indx)

end subroutine lu_solve

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

subroutine lu_decomp(A, N, indx, D, code)
  ! Given an N x N matrix A, this routine replaces it by the LU
  ! decomposition of a rowwise permutation of itself. A and N
  ! are input. indx is an output vector which records the row
  ! permutation effected by the partial pivoting; D is output
  ! as -1 or 1, depending on whether the number of row inter-
  ! changes was even or odd, respectively. This routine is used
  ! in combination with LUBKSB to solve linear equations or to
  ! invert a matrix. Return code is 1 if matrix is singular.

  implicit none

  real,dimension(N,N),intent(inout) :: A
  integer,intent(in) :: N
  integer,dimension(N),intent(out) :: indx
  integer,intent(out) :: code, D

  real,dimension(N) :: VV
  real,parameter :: tiny=1.5e-20
  integer :: i, j, k, imax
  real :: amax, dum, sum

  ! Initialize
  D = 1
  code = 0
  imax = 0

  ! Loop over rows to get implicit scaling information
  do i=1,N

    ! Get largest element in this row
    amax=0.0
    do j=1,N
      if (abs(A(i,j)) > amax) then
        amax = abs(A(i,j))
      end if
    end do

    ! Check the largest element in this row is nonzero
    if (amax <= tiny) then
      code = 1 ! Singular matrix
      return
    end if

    ! Store implicit scaling
    vv(i) = 1.0 / amax

  end do

  ! Loop over columns of Crout's method
  do j=1,N
    do i=1,J-1
      sum = A(i,j)
      do k=1,i-1
        sum = sum - A(i,k)*A(k,j)
      end do
      A(i,j) = sum
    end do

    ! Initialize search for largest pivot element
    amax = 0.0
    do i=j,N

      sum = A(i,j)
      do k=1,j-1
        sum = sum - A(i,k)*A(k,j)
      end do
      A(i,j) = sum

      ! Determine figure of merit for the pivot
      dum = vv(i)*abs(sum)
      if (dum >= amax) then
        imax = i
        amax = dum
      end if

    end do

    ! Figure out if we need to interchange rows
    if (j /= imax) then

      ! Perform interchange
      do k=1,N
        dum = A(imax,k)
        A(imax,k) = A(j,k)
        A(j,k) = dum
      end do

      ! Update the sign of D since a row interchange has occurred
      D = -D

      ! Interchange the implicit scaling factor
      vv(imax) = vv(j)

    end if

    ! Store pivoting
    indx(j) = imax

    ! Replace zero pivot element with small parameter
    if (abs(A(j,j)) < tiny) then
      A(j,j) = tiny
    end if

    ! Divide by pivot element
    if (j /= N) then
      dum = 1.0 / A(j,j)
      do i=j+1,N
        A(i,j) = A(i,j)*dum
      end do
    end if

  end do

end subroutine lu_decomp

subroutine lu_back_sub(A, N, indx, b, x)
  ! Solves the set of N linear equations Ax = b.  Here A is
  ! input, not as the matrix A but rather as its LU decomposition,
  ! determined by the routine LUDCMP. indx is input as the permuta-
  ! tion vector returned by LUDCMP. b is input as the right-hand
  ! side vector b. The solution vector is x. A, N, b and
  ! indx are not modified by this routine and can be used for suc-
  ! cessive calls with different right-hand sides. This routine is
  ! also efficient for plain matrix inversion.

  implicit none

  integer,intent(in) :: N
  real,dimension(N,N),intent(in) :: A
  real,dimension(N),intent(in) :: b
  integer,dimension(N),intent(in) :: indx
  real,dimension(:),allocatable,intent(out) :: x

  real :: sum
  integer :: ii,i,j,ll

  ! Initialize solution
  allocate(x, source=b)

  ! Set tracker to ignore leading zeros in b
  ii = 0

  ! Forward substitution
  do i=1,N

    ! Untangle pivoting
    ll = indx(i)
    sum = x(ll)
    x(ll) = x(i)

    ! If a nonzero element of b has already been encountered
    if (ii /= 0) then
      do J=ii,i-1
        sum = sum - A(i,J)*x(J)
      end do

    ! Check for first nonzero element of b
    else if(sum /= 0.0) then
      ii = i
    end if

    x(i) = sum

  end do

  ! Back substitution
  do i=N,1,-1
    sum = x(i)
    do j=i+1,N
      sum = sum - A(i,j)*x(j)
    end do
    x(i) = sum / A(i,i)
  end do

end subroutine lu_back_sub

subroutine math_snyder_ludcmp(a,n)
  ! Computes the LU decomposition for a diagonally dominant matrix (no pivoting is done).
  !   Inputs:  n = number of equations/unknowns
  !            a = nxn coefficient matrix
  !   Outputs: a = nxn matrix containing the LU matrices
  !
  ! Deryl Snyder, 10-16-98
  implicit none
  integer :: n,i,j,k
  real a(n,n),z

  do k=1,n-1
    do i=k+1,n
      z=a(i,k)/a(k,k)                     !compute gauss factor
      a(i,k)=z                            !store gauss factor in matrix
      do j=k+1,n
        a(i,j)=a(i,j)-z*a(k,j)            !apply row operation
      end do
    end do
  end do
end subroutine math_snyder_ludcmp

subroutine math_snyder_lusolv(a,b,x,n)
  ! Solves for the unknowns (x) given the LU matrix and the right hand side.                                    C
  !   Inputs:  n = number of equations/unknowns
  !            a = nxn matrix containing the L and U values
  !            b = n vector containing right hand side values
  !   Outputs: x = n vector containing solution
  !
  ! Deryl Snyder, 10-16-98

  implicit none

  integer :: n,i,j,k
  real a(n,n),b(n),x(n)

  do i=1,n
     x(i)=b(i)
  end do

  ! Forward substitution
  do k=1,n-1
    do i=k+1,n
      x(i)=x(i)-a(i,k)*x(k)
    enddo
  enddo

  ! Back substitution
  do i=n,1,-1
    do j=i+1,n
      x(i)=x(i)-a(i,j)*x(j)
    end do
    x(i)=x(i)/a(i,i)
  end do

end subroutine math_snyder_lusolv

subroutine quadratic_fit(pts, a, b, c)
  ! Fits a parabola through three specified
  ! points and returns the coefficients a, b, c defining this parabola
  ! according to the equation y = a * x**2 + b * x + c
  !            pts = list of three (x, y) points
  !   Outputs: a, b, c = quadratic coefficients

  implicit none

  real, dimension(3, 2), intent(in) :: pts
  real, intent(out) :: a, b, c

  integer :: i
  real, dimension(3, 3) :: m, m_inv
  real, dimension(3) :: v, coeff

  do i = 1, 3
    m(i, 1) = pts(i, 1)**2
    m(i, 2) = pts(i, 1)
    m(i, 3) = 1.0
  end do

  call matinv(3, m, m_inv)

  v(:) = pts(:, 2)
  coeff = matmul(m_inv, v)

  a = coeff(1)
  b = coeff(2)
  c = coeff(3)

end subroutine quadratic_fit

end module math_mod


program main

!*****************************************************************************80
!
!! MAIN is the main program for HEATED_PLATE_OPENMP.
!
!  Discussion:
!
!    This code solves the steady state heat equation on a rectangular region.
!
!    The sequential version of this program needs approximately
!    18/eps iterations to complete.
!
!
!    The physical region, and the boundary conditions, are suggested
!    by this diagram;
!
!                   W = 0
!             +------------------+
!             |                  |
!    W = 100  |                  | W = 100
!             |                  |
!             +------------------+
!                   W = 100
!
!    The region is covered with a grid of M by N nodes, and an N by N
!    array W is used to record the temperature.  The correspondence between
!    array indices and locations in the region is suggested by giving the
!    indices of the four corners:
!
!                  I = 0
!          [0][0]-------------[0][N-1]
!             |                  |
!      J = 0  |                  |  J = N-1
!             |                  |
!        [M-1][0]-----------[M-1][N-1]
!                  I = M-1
!
!    The steady state solution to the discrete heat equation satisfies the
!    following condition at an interior grid point:
!
!      W[Central] = (1/4) * ( W[North] + W[South] + W[East] + W[West] )
!
!    where "Central" is the index of the grid point, "North" is the index
!    of its immediate neighbor to the "north", and so on.
!
!    Given an approximate solution of the steady state heat equation, a
!    "better" solution is given by replacing each interior point by the
!    average of its 4 neighbors - in other words, by using the condition
!    as an ASSIGNMENT statement:
!
!      W[Central]  <=  (1/4) * ( W[North] + W[South] + W[East] + W[West] )
!
!    If this process is repeated often enough, the difference between
!    successive estimates of the solution will go to zero.
!
!    This program carries out such an iteration, using a tolerance specified by
!    the user, and writes the final estimate of the solution to a file that can
!    be used for graphic processing.
!
!  Licensing:
!
!    This code is distributed under the GNU LGPL license.
!
!  Modified:
!
!    18 October 2011
!
!  Author:
!
!    Original FORTRAN90 version by Michael Quinn.
!    This version by John Burkardt.
!
!  Reference:
!
!    Michael Quinn,
!    Parallel Programming in C with MPI and OpenMP,
!    McGraw-Hill, 2004,
!    ISBN13: 978-0071232654,
!    LC: QA76.73.C15.Q55.
!
!  Local parameters:
!
!    Local, real ( kind = 8 ) DIFF, the norm of the change in the solution from
!    one iteration to the next.
!
!    Local, real ( kind = 8 ) MEAN, the average of the boundary values, used
!    to initialize the values of the solution in the interior.
!
!    Local, real ( kind = 8 ) U(M,N), the solution at the previous iteration.
!
!    Local, real ( kind = 8 ) W(M,N), the solution computed at the latest
!    iteration.
!
  use omp_lib

  implicit none

  integer ( kind = 4 ), parameter :: m = 500
  integer ( kind = 4 ), parameter :: n = 500

  real ( kind = 8 ) diff
  real ( kind = 8 ) :: eps = 0.001D+00
  integer ( kind = 4 ) i
  integer ( kind = 4 ) iterations
  integer ( kind = 4 ) iterations_print
  integer ( kind = 4 ) j
  real ( kind = 8 ) mean
  real ( kind = 8 ) u(m,n)
  real ( kind = 8 ) w(m,n)
  real ( kind = 8 ) wtime

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'HEATED_PLATE_OPENMP'
  write ( *, '(a)' ) '  FORTRAN90 version'
  write ( *, '(a)' ) &
    '  A program to solve for the steady state temperature distribution'
  write ( *, '(a)' ) '  over a rectangular plate.'
  write ( *, '(a)' ) ' '
  write ( *, '(a,i8,a,i8,a)' ) '  Spatial grid of ', m, ' by ', n, ' points.'
  write ( *, '(a,g14.6)' ) &
    '  The iteration will repeat until the change is <= ', eps
  write ( *, '(a,i8)' ) &
    '  The number of processors available = ', omp_get_num_procs ( )
  write ( *, '(a,i8)' ) &
    '  The number of threads available    = ', omp_get_max_threads ( )
!
!  Set the boundary values, which don't change.
!
!  OpenMP Note:
!  You CANNOT set MEAN to zero inside the parallel region.
!
  mean = 0.0D+00
!
!$omp parallel shared ( w ) private ( i, j )

  !$omp do
  do i = 2, m - 1
    w(i,1) = 100.0D+00
    w(i,n) = 100.0D+00
  end do
  !$omp end do

  !$omp do
  do j = 1, n
    w(m,j) = 100.0D+00
    w(1,j) =   0.0D+00
  end do
  !$omp end do
!
!  Average the boundary values, to come up with a reasonable
!  initial value for the interior.
!
  !$omp do reduction ( + : mean )
  do i = 2, m - 1
    mean = mean + w(i,1) + w(i,n)
  end do
  !$omp end do

  !$omp do reduction ( + : mean )
  do j = 1, n
    mean = mean + w(1,j) + w(m,j)
  end do
  !$omp end do

!$omp end parallel
!
!  OpenMP note:
!  You cannot normalize MEAN inside the parallel region.  It
!  only gets its correct value once you leave the parallel region.
!  So we interrupt the parallel region, set MEAN, and go back in.
!
  mean = mean / dble ( 2 * m + 2 * n - 4 )
  write ( *, '(a)' ) ' '
  write ( *, '(a,g14.6)' ) '  MEAN = ', mean
!
!  Initialize the interior solution to the mean value.
!
!$omp parallel shared ( mean, w ) private ( i, j )

  !$omp do
  do j = 2, n - 1
    do i = 2, m - 1
      w(i,j) = mean
    end do
  end do
  !$omp end do

!$omp end parallel
!
!  Iterate until the  new solution W differs from the old solution U
!  by no more than EPS.
!
  iterations = 0
  iterations_print = 1

  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) ' Iteration  Change'
  write ( *, '(a)' ) ' '

  wtime = omp_get_wtime ( )

  diff = eps

  do while ( eps <= diff )
!
!  OpenMP node: You CANNOT set DIFF to 0.0 inside the parallel region.
!
    diff = 0.0D+00

!$omp parallel shared ( u, w ) private ( i, j )

    !$omp do
    do j = 1, n
      do i = 1, m
        u(i,j) = w(i,j)
      end do
    end do
    !$omp end do

    !$omp do
    do j = 2, n - 1
      do i = 2, m - 1
        w(i,j) = 0.25D+00 * ( u(i-1,j) + u(i+1,j) + u(i,j-1) + u(i,j+1) )
      end do
    end do
    !$omp end do

    !$omp do reduction ( max : diff )
    do j = 1, n
      do i = 1, m
        diff = max ( diff, abs ( u(i,j) - w(i,j) ) )
      end do
    end do
    !$omp end do

!$omp end parallel

    iterations = iterations + 1

    if ( iterations == iterations_print ) then
      write ( *, '(2x,i8,2x,g14.6)' ) iterations, diff
      iterations_print = 2 * iterations_print
    end if

  end do

  wtime = omp_get_wtime ( ) - wtime

  write ( *, '(a)' ) ' '
  write ( *, '(2x,i8,2x,g14.6)' ) iterations, diff
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) '  Error tolerance achieved.'
  write ( *, '(a,g14.6)' ) '  Wall clock time = ', wtime
!
!  Terminate.
!
  write ( *, '(a)' ) ' '
  write ( *, '(a)' ) 'HEATED_PLATE_OPENMP:'
  write ( *, '(a)' ) '  Normal end of execution.'

  stop
end


! Objetivo: Usar pares ordenados a partir de um gerador aleatorio do
!           tipo rapido e "sujo" para obter coordenadas de pontos em
!	    	um espaço bidimensional.

PROGRAM aleatorio_sujo_xy
	IMPLICIT none
	INTEGER, PARAMETER :: im = 6075, ia = 106, ic = 1283
	REAL, PARAMETER :: im_real = REAL(im)
	REAL :: ran_x, ran_y
	INTEGER, PARAMETER :: dados_aleatorio_xy = 7
	INTEGER :: num_repeticoes, jran = 1
! Abrir arquivo.dat de saida de dados
	OPEN(dados_aleatorio_xy,FILE="dados_aleatorio_xy.dat")
! Essas constantes dao um periodo de comprimento máximo im. Por isso im eh a
! quantidade de numeros aleatorios gerados diferentes. O gerador produz 2*im numeros
! aleatorios pois im eh impar. O primeiro numero a repetir sera na coordenada y, pois
! im eh impar e estamos distribuindo aos pares. O primeiro numero a se repetir na
! coordenada x sera apos 2im numeros gerados.
	DO num_repeticoes = 1, im
		jran = MOD(jran*ia+ic,im)
		ran_x = REAL(jran)/im_real

		jran = MOD(jran*ia+ic,im)
		ran_y = REAL(jran)/im_real
! Escrever as coordenadas no arquivo de dados
		WRITE(dados_aleatorio_xy,*) ran_x,ran_y
	END DO
! Fechar arquivo.dat de saida de dados
	CLOSE(dados_aleatorio_xy)
END PROGRAM aleatorio_sujo_xy


program main
    use RandomClass
    use MathClass
    use IOClass
    implicit none

    integer(int32),parameter :: sample = 2**11
    real(real64),parameter :: dt = 0.0010d0
    type(Random_) :: random
    type(IO_) :: f,z
    type(Math_) :: Math
    integer(int32) :: i, n, nn,count
    real(real64) :: g_n, g_nn, period, period_list(sample)
    complex(kind(0d0) ),allocatable :: wave(:)
    real(real64) :: spectre(sample),t
    real(real64),allocatable :: histogram(:,:)

    ! get random wave & zero crossing
    call f%open("random_wave.csv")

    g_n = -1.0d0
    g_nn= 0.0d0
    n = 0
    nn = 0
    period = 0.0d0
    count=0
    period_list(:) = 0.0d0
    wave = period_list
    do i=1,sample
        ! generate wave

        ! Gaussian process
        !g_nn = random%Gauss(mu=0.0d0, sigma=1.0d0)

        ! wave
        !g_nn = sin(dble(i)*2*Math%PI)+10.0d0*sin(dble(i)/2.0d0*Math%PI)
        t = dble(i)*dt

        ! wave
        g_nn =    1.0d0*sin( 2.0d0*Math%PI*10.0d0*t )&
                + 0.5d0*sin( 2.0d0*Math%PI*20.0d0*t )&
                + 0.8d0*sin( 2.0d0*Math%PI*40.0d0*t )

        wave(i) = g_nn
        !g_nn = random%ChiSquared(k=1.0d0)

        if( g_n*g_nn < 0.0d0 )then
            count=count+1
            nn = i
            period = dble(nn) - dble(n)
            period_list(count) = period
            n = nn
            g_n = g_nn
        endif

        call f%write( trim(str(dble(i))) //", "//str(g_nn) )

    enddo
    call f%close()

    ! get histogram
    histogram =  random%histogram(list=period_list,division=20)
    call z%open("zero_cross.csv")

    do i=1,size(histogram,1)
        write(z%fh,*) histogram(i,1),histogram(i,2)
    enddo
    call z%close()

    call z%open("wave.txt")
    do i=1,sample
        call z%write(str(dble(i)*dt )//" "//str(dble(wave(i) )) )
    enddo
    call z%close()

    spectre =  FFT(wave)
    call z%open("spectre.txt")
    do i=1,sample
        call z%write( str( dble(i)*2.0d0/dble(sample) )//" "//str(dble( abs(spectre(i)) )) )
    enddo
    call z%close()

end program main


program Hailstone
  implicit none

  integer :: i, maxn
  integer :: maxseqlen = 0, seqlen
  integer, allocatable :: seq(:)

  call hs(27, seqlen)
  allocate(seq(seqlen))
  call hs(27, seqlen, seq)
  write(*,"(a,i0,a)") "Hailstone sequence for 27 has ", seqlen, " elements"
  write(*,"(a,4(i0,a),3(i0,a),i0)") "Sequence = ", seq(1), ", ", seq(2), ", ", seq(3), ", ", seq(4), " ...., ",  &
                                     seq(seqlen-3), ", ", seq(seqlen-2), ", ", seq(seqlen-1), ", ", seq(seqlen)

  do i = 1, 99999
    call hs(i, seqlen)
    if (seqlen > maxseqlen) then
      maxseqlen = seqlen
      maxn = i
    end if
  end do
  write(*,*)
  write(*,"(a,i0,a,i0,a)") "Longest sequence under 100000 is for ", maxn, " with ", maxseqlen, " elements"

  deallocate(seq)

contains

subroutine hs(number, length, seqArray)
  integer, intent(in)  :: number
  integer, intent(out) :: length
  integer, optional, intent(inout) :: seqArray(:)
  integer :: n

  n = number
  length = 1
  if(present(seqArray)) seqArray(1) = n
  do while(n /= 1)
    if(mod(n,2) == 0) then
      n = n / 2
    else
      n = n * 3 + 1
    end if
    length = length + 1
    if(present(seqArray)) seqArray(length) = n
  end do
end subroutine

end program


C++*************************************************
C Program POLAR_DIST to compute distance
C of two points given by their polar coordinates (angle and separation)
C from the Cartesian coordinates of two points
C--*************************************************
        PROGRAM POLAR_DIST
        REAL*4 R1,A1,R2,A2,DIST,A,B,PI
        PI=ACOS(-1.)

        WRITE(6,20)
20      FORMAT('Program POLAR_DIST to compute the distance',
     1         ' of two points given by their polar coordinates')
        WRITE(6,21)
21      FORMAT(' Enter the rho,theta(deg) coordinates of the first point (origin):')
        READ(5,*) R1,A1
        A1=A1*PI/180.
        WRITE(6,22)
22      FORMAT(' Enter the rho,theta(deg) coordinates of the second point:')
        READ(5,*) R2,A2
        A2=A2*PI/180.
        A=R1*COS(A1)-R2*COS(A2)
        B=R1*SIN(A1)-R2*SIN(A2)
        DIST=SQRT(A*A+B*B)

        WRITE(6,30) DIST
30      FORMAT(' Distance: ',G12.5)

        STOP
        END


! Example illustrating how subtracting the minimum in a log-sum-exp
! routine can result in overflow, while subtracting the maximum
!
! Jason R. Blevins <jrblevin@sdf.org>
! Columbus, February 5, 2013
program log_sum_exp_test
  implicit none

  real, dimension(3) :: v = (/ -100.0, -200.0, -300.0 /)
  real :: max, min

  max = maxval(v)
  min = minval(v)

  print *, 'No centering:'
  print *, 'v =                            ', v
  print *, 'exp(v) =                       ', exp(v)
  print *, 'sum(exp(v)) =                  ', sum(exp(v))
  print *, 'log(sum(exp(v))) =             ', log(sum(exp(v)))
  print *, ''
  print *, 'Subtracting the maximum:'
  print *, 'v - max =                      ', v - max
  print *, 'exp(v - max) =                 ', exp(v - max)
  print *, 'sum(exp(v - max)) =            ', sum(exp(v - max))
  print *, 'log(sum(exp(v - max))) + max = ', log(sum(exp(v - max))) + max
  print *, ''
  print *, 'Subtracting the minimum:'
  print *, 'v - min =                      ', v - min
  print *, 'exp(v - min) =                 ', exp(v - min)
  print *, 'sum(exp(v - min)) =            ', sum(exp(v - min))
  print *, 'log(sum(exp(v - min))) + min = ', log(sum(exp(v - min))) + min
end program log_sum_exp_test


! This will be a subroutine since it does not
! return any values.
subroutine fssor(U, m, n, omega, tol, maxiters, info)

!   Here we declare the types for the inputs.
!   This is where we use the c_double and c_int types.
!   The 'dimension' statement tells the compiler that
!   the argument is an array of the given shape.
    integer, intent(in) :: m, n, maxiters
    double precision, intent(out) :: info
    double precision, dimension(m,n), intent(inout) :: U
    double precision, intent(in) :: omega, tol

!   Temporary variables:
!   'maxerr' is a temporary value.
!   It is used to determine when to stop iteration.
!   'i', 'j', and 'k' are indices for the loops.
!   lcf and rcf will be precomputed values
!   used on the inside of the loops.
    double precision :: maxerr, temp, lcf, rcf
    integer i, j, k

    lcf = 1.0D0 - omega
    rcf = 0.25D0 * omega
    do k = 1, maxiters
        maxerr = 0.0D0
        do j = 2, n-1
            do i = 2, m-1
                temp = U(i,j)
                U(i,j) = lcf * U(i,j) + rcf * (U(i,j-1) + U(i,j+1) + U(i-1,j) + U(i+1,j))
                maxerr = max(abs(U(i,j) - temp), maxerr)
            enddo
        enddo
!       Break the outer loop if within
!       the desired tolerance.
        if (maxerr < tol) exit
    enddo
!   Here we have it set status to 0 if
!   the desired tolerance was attained
!   within the the given maximum
!   number of iterations.
    if (maxerr < tol) then
        info = 0
    else
        info = 1
    end if
end subroutine fssor


MODULE generic_procedure_module
IMPLICIT NONE
! Declare type vector
TYPE :: vector
  REAL :: x
  REAL :: y
CONTAINS
  GENERIC :: add => vector_plus_vector, vector_plus_scalar
  PROCEDURE, PASS :: vector_plus_scalar
  PROCEDURE, PASS :: vector_plus_vector
END TYPE vector

CONTAINS
  TYPE (vector) FUNCTION vector_plus_vector(this, v2)
  IMPLICIT NONE
  CLASS(vector), INTENT(IN) :: this
  CLASS(vector), INTENT(IN) :: v2
  vector_plus_vector%x = this%x + v2%x
  vector_plus_vector%y = this%y + v2%y
  END FUNCTION vector_plus_vector

  TYPE (vector) FUNCTION vector_plus_scalar(this, scalar)
  IMPLICIT NONE
  CLASS(vector), INTENT(IN) :: this
  REAL, INTENT(IN) :: scalar
  vector_plus_scalar%x = this%x + scalar
  vector_plus_scalar%y = this%y + scalar
  END FUNCTION vector_plus_scalar
END MODULE generic_procedure_module

PROGRAM test_generic_procedures
USE generic_procedure_module
IMPLICIT NONE
TYPE(vector) :: v1
TYPE(vector) :: v2
REAL :: s

WRITE(*, *) 'ENTER FIRST VECTOR (X, Y):'
READ(*, *) v1%x, v1%y
WRITE(*, *) 'ENTER SECOND VECTOR (X, Y):'
READ(*, *) v2%x, v2%y
WRITE(*, *) 'ENTER A SCALAR:'
READ(*, *) s
WRITE(*, 1000) v1%add(v2)
1000 FORMAT ('The sum of the vectors is (',F8.2,',',F8.2,')')
WRITE(*, 1010) v1%add(s)
1010 FORMAT ('The sum of the vector and the scalar is (',F8.2,',',F8.2,')')
END PROGRAM test_generic_procedures


      program linearAlgebra01
!
!     This program fills two matrices with random numbers and forms their sum.
!     The matrices are square and their size is determined by a user-provided
!     command line argument.
!
!
!     Hrant P. Hratchian, 2021.
!
!
      USE OMP_LIB
      implicit none
      integer,parameter::iOut=6
      integer::nDim,nOMP,i,j,k
      real::tStart,tEnd,tmp
      real,dimension(:,:),allocatable::matrixA,matrixB,matrixC
      character(len=256)::commandLineArg
      logical::fail=.false.
!
!     Format statements.
!
 1000 Format('My Matrix Multiplication: nDim = ',I10,'  Job Time: ',F10.3,' s.')
 8999 format(1x,'The program and completed normally.')
 9000 format(1x,'Wrong number of command line arguments found.')
 9999 Format(1x,'The program FAILED!')
!
!     Begin by loading nDim and nOMP from the command line arguments. Then,
!     allocating memory for matrixA, matrixB, and matrixC and start up OpenMP.
!
      if(COMMAND_ARGUMENT_COUNT().ne.2) then
        write(iOut,9000)
        fail = .true.
        goto 999
      endIf
      call GET_COMMAND_ARGUMENT(1,commandLineArg)
      read(commandLineArg,*) nDim
      call GET_COMMAND_ARGUMENT(2,commandLineArg)
      read(commandLineArg,*) nOMP
      Allocate(matrixA(nDim,nDim),matrixB(nDim,nDim),matrixC(nDim,nDim))
      call random_number(matrixA)
      call random_number(matrixB)
      call omp_set_num_threads(nOMP)
!
!     Carry out matrix multiplication using explicit nested loops.
!
      call CPU_TIME(tStart)
!$OMP PARALLEL DO Shared(matrixA,matrixB,matrixC,nDim,tmp) Reduction(+: tmp)
      do i = 1,nDim
        do j = 1,nDim
          tmp = float(0)
          do k = 1,nDim
            tmp = tmp + matrixA(i,k)*matrixB(k,j)
          endDo
          matrixC(i,j) = tmp
        endDo
      endDo
!$OMP END PARALLEL DO
      call CPU_TIME(tEnd)
      write(iOut,1000) nDim,tEnd-tStart
!
!     Wrap up the program. First, check to see if we have hit a failure and
!     print an appropriate message. Then, deallocate memory for allocatable
!     arrays.
!
  999 if(fail) then
        write(iOut,9999)
      else
        write(iOut,8999)
      endIf
      DeAllocate(matrixA,matrixB,matrixC)
      end program linearAlgebra01


      Program Ex0202

      Implicit None

*   Guess Number
      Integer           N
      Parameter         (N = 30)
*   Guess Minimum
      Double Precision  xMin
      Parameter         (xMin = 0.0D0)
*   Guess Maximum
      Double Precision  xMax
      Parameter         (xMax = 3.0D0)
*   Y Value of Guess Minimum
      Double Precision  yMin
      Parameter         (yMin = 1.0D0)
*   X Interval
      Double Precision  H
      Parameter         (H = (xMax - xMin) / Dble(N))
*   Data Storage
      Double Precision  y(N), x(N), yExt(N), yDif(N), yRat(N)
      Double Precision  y0, xTmp, yTmp
*   Dummy
      Integer           I
*   Diff Func
      Double Precision  Func
      External          Func

      Open(11, File = '02-02.txt')
 1000 Format(5F14.7)
 1010 Format(5A14)
 1020 Format(A50)

*   Initial Value
      Do 10 I = 1, N
        x(I) = Dble(I)/Dble(N) * xMax +
     $         (Dble(1.0D0) - Dble(I) / Dble(N)) * xMin
        yExt(I) = DExp(-x(I)*x(I)/2.0D0)
  10  Continue

*-- Euler's Method

      y0 = yMiN
      y(1) = y0 + H * Func(xMin,y0)
      yDif(1) = y(1) - yExt(1)
      yRat(1) = yDif(1) / yExt(1)

      Do 20 I = 2, N
        y(I) = y(I-1) + H * Func(x(I-1), y(I-1))
        yDif(I) = y(I) - yExt(I)
        yRat(I) = yDif(I) / yExt(I)
  20  Continue

      Write(11,*)
      Write(11,1020) 'Euler Method         '
      Write(11,*)
      Write(11,1010) '--------------','--------------','--------------',
     $               '--------------','--------------'
      Write(11,1010) 'x', 'Exact y', 'Calc y', 'Error Value',
     $               'Error Ratio'
      Write(11,1010) '--------------','--------------','--------------',
     $               '--------------','--------------'
      Do 30 I = 1, N
        Write(11,1000) x(I), yExt(I), y(I), yDif(I), yRat(I)
  30  Continue
      Write(11,1010) '--------------','--------------','--------------',
     $               '--------------','--------------'
      Write(11,*)

      yTmp = y(N)
      Do 40 I = 1, N
        xTmp = Dble(I)/Dble(N) * xMin + H +
     $         (Dble(1.0D0) - Dble(I) / Dble(N)) * xMax
        yTmp = yTmp - H * Func(xTmp, yTmp)
  40  Continue
      Write(11,'(A18,F14.7)') 'Recursion Value: ', yTmp
      Write(11,'(A18,F14.7)') 'Recursion Error: ', yMin - yTmp
      Write(11,*)

*-- Adams-Bashforth's Method (1th extrapolate)

      Do 110 I = 1, N
        x(I) = Dble(I)/Dble(N) * xMax +
     $         (Dble(1.0D0) - Dble(I) / Dble(N)) * xMin
        yExt(I) = DExp(-x(I)*x(I)/2.0D0)
  110 Continue

      y0 = yMiN
      y(1) = y0 + H * Func(xMin,y0)
      yDif(1) = y(1) - yExt(1)
      yRat(1) = yDif(1) / yExt(1)

      Do 120 I = 2, 2
        y(I) = y(I-1) + H * Func(x(I-1), y(I-1))
        yDif(I) = y(I) - yExt(I)
        yRat(I) = yDif(I) / yExt(I)
  120 Continue

      Do 130 I = 3, N
        y(I) = y(I-1) + H * (1.5D0 * Func(x(I-1), y(I-1)) -
     $         0.5D0 * Func(x(I-2), y(I-2)))
        yDif(I) = y(I) - yExt(I)
        yRat(I) = yDif(I) / yExt(I)
  130 Continue

      Write(11,*)
      Write(11,1020) '1th Adams-Bashforth Method  '
      Write(11,*)
      Write(11,1010) '--------------','--------------','--------------',
     $               '--------------','--------------'
      Write(11,1010) 'x', 'Exact y', 'Calc y', 'Error Value',
     $               'Error Ratio'
      Write(11,1010) '--------------','--------------','--------------',
     $               '--------------','--------------'
      Do 140 I = 1, N
        Write(11,1000) x(I), yExt(I), y(I), yDif(I), yRat(I)
  140 Continue
      Write(11,1010) '--------------','--------------','--------------',
     $               '--------------','--------------'
      Write(11,*)

      Do 150 I = 1, N
        x(I) = Dble(I)/Dble(N) * xMin +
     $         (Dble(1.0D0) - Dble(I) / Dble(N)) * xMax
        yExt(I) = DExp(-x(I)*x(I)/2.0D0)
  150 Continue

      y0 = y(N)
      y(1) = y0 - H * Func(xMax,y0)
      yDif(1) = y(1) - yExt(1)
      yRat(1) = yDif(1) / yExt(1)

      Do 160 I = 2, 2
        y(I) = y(I-1) - H * Func(x(I-1), y(I-1))
        yDif(I) = y(I) - yExt(I)
        yRat(I) = yDif(I) / yExt(I)
  160 Continue

      Do 170 I = 3, N
        y(I) = y(I-1) - H * (1.5D0 * Func(x(I-1), y(I-1)) -
     $         0.5D0 * Func(x(I-2), y(I-2)))
        yDif(I) = y(I) - yExt(I)
        yRat(I) = yDif(I) / yExt(I)
  170 Continue

      Write(11,'(A18,F14.7)') 'Recursion Value: ', y(N)
      Write(11,'(A18,F14.7)') 'Recursion Error: ', yMin - y(N)
      Write(11,*)

*-- Adams-Bashforth's Method (3th extrapolate)

      Do 210 I = 1, N
        x(I) = Dble(I)/Dble(N) * xMax +
     $         (Dble(1.0D0) - Dble(I) / Dble(N)) * xMin
        yExt(I) = DExp(-x(I)*x(I)/2.0D0)
  210 Continue

      y0 = yMiN
      y(1) = y0 + H * Func(xMin,y0)
      yDif(1) = y(1) - yExt(1)
      yRat(1) = yDif(1) / yExt(1)

      Do 220 I = 2, 4
        y(I) = y(I-1) + H * Func(x(I-1), y(I-1))
        yDif(I) = y(I) - yExt(I)
        yRat(I) = yDif(I) / yExt(I)
  220 Continue

      Do 230 I = 5, N
        y(I) = y(I-1) + H / 24.0D0 * ( 55.0D0 * Func(x(I-1),y(I-1)) -
     $  59.0D0 * Func(x(I-2),y(I-2)) + 37.0D0 * Func(x(I-3),y(I-3)) -
     $   9.0D0 * Func(x(I-4),y(I-4)) )
        yDif(I) = y(I) - yExt(I)
        yRat(I) = yDif(I) / yExt(I)
  230 Continue

      Write(11,*)
      Write(11,1020) '3th Adams-Bashforth Method  '
      Write(11,*)
      Write(11,1010) '--------------','--------------','--------------',
     $               '--------------','--------------'
      Write(11,1010) 'x', 'Exact y', 'Calc y', 'Error Value',
     $               'Error Ratio'
      Write(11,1010) '--------------','--------------','--------------',
     $               '--------------','--------------'
      Do 240 I = 1, N
        Write(11,1000) x(I), yExt(I), y(I), yDif(I), yRat(I)
  240 Continue
      Write(11,1010) '--------------','--------------','--------------',
     $               '--------------','--------------'
      Write(11,*)

      Do 250 I = 1, N
        x(I) = Dble(I)/Dble(N) * xMin +
     $         (Dble(1.0D0) - Dble(I) / Dble(N)) * xMax
        yExt(I) = DExp(-x(I)*x(I)/2.0D0)
  250 Continue

      y0 = y(N)
      y(1) = y0 - H * Func(xMax,y0)
      yDif(1) = y(1) - yExt(1)
      yRat(1) = yDif(1) / yExt(1)

      Do 260 I = 2, 4
        y(I) = y(I-1) - H * Func(x(I-1), y(I-1))
        yDif(I) = y(I) - yExt(I)
        yRat(I) = yDif(I) / yExt(I)
  260 Continue

      Do 270 I = 5, N
        y(I) = y(I-1) - H / 24.0D0 * ( 55.0D0 * Func(x(I-1),y(I-1)) -
     $  59.0D0 * Func(x(I-2),y(I-2)) + 37.0D0 * Func(x(I-3),y(I-3)) -
     $   9.0D0 * Func(x(I-4),y(I-4)) )
        yDif(I) = y(I) - yExt(I)
        yRat(I) = yDif(I) / yExt(I)
  270 Continue

      Write(11,'(A18,F14.7)') 'Recursion Value: ', y(N)
      Write(11,'(A18,F14.7)') 'Recursion Error: ', yMin - y(N)
      Write(11,*)

      End Program Ex0202

*-----------------------------------------------------------------------
*
      Function Func(x,y)

      Implicit None

      Double Precision  Func, x, y

      Func = -x*y

      Return
      End Function Func


program insertion
implicit none

!-----------------------------------------------------------------
! This programme sorts a series of values in increasing order,
! using insertion sort, implemented with two working arrays.
!
! It works like this:
! unsorted: A = [5, 3, 4, 1, 2, 6]
! sorting:
! pass 1: B = [5, 0, 0, 0, 0, 0]
! pass 2: B = [3, 5, 0, 0, 0, 0]
! pass 3: B = [3, 4, 5, 0, 0, 0]
! pass 4: B = [1, 3, 4, 5, 0, 0]
! pass 5: B = [1, 2, 3, 4, 5, 0]
! pass 6: B = [1, 2, 3, 4, 5, 6]
!------------------------------------------------------

real(kind=8), allocatable, dimension(:) :: A, B
integer :: i, j, k, n
logical :: sorted

!------------------------------------------------------------
! Make some random array:
!------------------------------------------------------------

write(*,*) 'size od array?'
read(*,*) n
allocate (A(n), B(n))

call random_seed()
do i = 1, n
   call random_number(A(i))
   A(i) = (A(i) * 100.0)
   A(i) = real(nint(A(i)*1000)) / 1000.0 !rounding off to 3 decimal places
   B(i) = 0.0
end do

!------------------------------------------------------------
! Prepare output file:
!------------------------------------------------------------

open(unit=1, file='insert', status='replace', action='write')
write(1,*) 'here you can see the details of how the loops and conditionals'
write(1,*) 'really work'

write(1,*)
write(1,*) '(using two arrays)'
write(1,*)
write(1,'(A3,10F10.5)') ' A ', A
write(*,'(A3,10F10.5)') ' A ', A
write(1,*)

!------------------------------------------------------------
! The actual sorting:
!------------------------------------------------------------

do i = 1, n
   write (1,*) 'i', i
   sorted = .false.
   do j = 1, i-1 !Because B can only have elements up to i-1 diff. from 0
      write(1,*) '   j', j
      if (B(j) .ge. A(i)) then
         write(1,*) 'found it'
         do k = i-1, j, -1 !from the last value different from 0, to the
!                       first one greater than i
            B(k+1) = B(k) !move every element by one
            write(1,*) '      k', k
         end do
         B(j) = A(i)
         sorted = .true.
         exit
      end if
   end do
   if (.not. sorted) B(i) = A(i)
   write(1,'(I4)')
   write(1,'(I4,A3,20F7.3)') i, ' B ', B
   write(*,'(I4,A3,20F7.3)') i, ' B ', B
end do

end program insertion


SUBROUTINE verlet(pos, acc, dt, time)
    IMPLICIT NONE
    REAL(8), INTENT(INOUT) :: pos, acc, dt, time
    REAL(8)                :: prev_pos, next_pos

    prev_pos = pos
    time     = 0d0

    DO
        IF (pos > 0d0) THEN
            time     = time + dt
            next_pos = pos * 2d0 - prev_pos + acc * dt ** 2
            prev_pos = pos
            pos      = next_pos
        ELSE
            EXIT
        END IF
    END DO
END SUBROUTINE verlet

SUBROUTINE stormer_verlet(pos, acc, dt, time, vel)
    IMPLICIT NONE
    REAL(8), INTENT(INOUT) :: pos, acc, dt, time, vel
    REAL(8)                :: prev_pos, next_pos

    prev_pos = pos
    time     = 0d0
    vel      = 0d0

    DO
        IF (pos > 0d0) THEN
            time     = time + dt
            next_pos = pos * 2 - prev_pos + acc * dt ** 2
            prev_pos = pos
            pos      = next_pos
            vel      = vel + acc * dt
        ELSE
            EXIT
        END IF
    END DO
END SUBROUTINE stormer_verlet

SUBROUTINE velocity_verlet(pos, acc, dt, time, vel)
    IMPLICIT NONE
    REAL(8), INTENT(INOUT) :: pos, acc, dt, time, vel

    time     = 0d0
    vel      = 0d0

    DO
        IF (pos > 0d0) THEN
            time = time + dt
            pos  = pos + vel * dt + 0.5d0 * acc * dt ** 2
            vel  = vel + acc * dt
        ELSE
            EXIT
        END IF
    END DO
END SUBROUTINE velocity_verlet

PROGRAM verlet_integration

    IMPLICIT NONE
    REAL(8) :: pos,acc, dt, time, vel

    INTERFACE
        SUBROUTINE verlet(pos, acc, dt, time)
        REAL(8), INTENT(INOUT) :: pos, acc, dt, time
        REAL(8)                :: prev_pos, next_pos
        END SUBROUTINE
    END INTERFACE

    INTERFACE
        SUBROUTINE stormer_verlet(pos, acc, dt, time, vel)
            REAL(8), INTENT(INOUT) :: pos, acc, dt, time, vel
            REAL(8)                :: prev_pos, next_pos
        END SUBROUTINE
    END INTERFACE

    INTERFACE
        SUBROUTINE velocity_verlet(pos, acc, dt, time, vel)
            REAL(8), INTENT(INOUT) :: pos, acc, dt, time, vel
            REAL(8)                :: prev_pos, next_pos
        END SUBROUTINE
    END INTERFACE

    pos = 5d0
    acc = -10d0
    dt  = 0.01d0
    ! Verlet
    CALL verlet(pos, acc, dt, time)

    WRITE(*,*) '[#]'
    WRITE(*,*) 'Time for Verlet integration:'
    WRITE(*,*) time

    ! stormer Verlet
    pos = 5d0
    CALL stormer_verlet(pos, acc, dt, time, vel)

    WRITE(*,*) '[#]'
    WRITE(*,*) 'Time for Stormer Verlet integration:'
    WRITE(*,*) time
    WRITE(*,*) '[#]'
    WRITE(*,*) 'Velocity for Stormer Verlet integration:'
    WRITE(*,*) vel

    ! Velocity Verlet
    pos = 5d0
    CALL velocity_verlet(pos, acc, dt, time, vel)

    WRITE(*,*) '[#]'
    WRITE(*,*) 'Time for velocity Verlet integration:'
    WRITE(*,*) time
    WRITE(*,*) '[#]'
    WRITE(*,*) 'Velocity for velocity Verlet integration:'
    WRITE(*,*) vel

END PROGRAM verlet_integration


program VectorProducts

  real, dimension(3)  :: a, b, c

  a = (/ 3, 4, 5 /)
  b = (/ 4, 3, 5 /)
  c = (/ -5, -12, -13 /)

  print *, dot_product(a, b)
  print *, cross_product(a, b)
  print *, s3_product(a, b, c)
  print *, v3_product(a, b, c)

contains

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

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

  function s3_product(a, b, c)
    real :: s3_product
    real, dimension(3), intent(in) :: a, b, c

    s3_product = dot_product(a, cross_product(b, c))
  end function s3_product

  function v3_product(a, b, c)
    real, dimension(3) :: v3_product
    real, dimension(3), intent(in) :: a, b, c

    v3_product = cross_product(a, cross_product(b, c))
  end function v3_product

end program VectorProducts


      subroutine polfit(aamatr,cof,gmmatr,ier,ipivot,npfmax,npft,
     $ noutpt,nttyo,xvec,yvec)
c
c     This subroutine fits an exact polynomial through npft points.
c     Each point is an x,y pair, where the values of x are in the
c     xvec array, those of y in the yvec array. The method is to solve
c     the matrix equation (A)(c) = (y) where:
c
c               | 1  x(1)  x(1)**2  ... |
c               | 1  x(2)  x(2)**2  ... |
c       A =     | 1  x(3)  x(3)**2  ... |
c               | ...                   |
c               | 1  x(n)  x(n)**2  ... |
c
c      and solve for the coefficients (c), which give the
c      representation:
c
c        y = c(1) + c(2)*x + c(3)*x**2 + ... + c(n)*x**n-1
c
c     It is assumed that the xvec array contains distinct values
c     (i.e., there are no duplicates). The matrix A is the
c     array aamatr, the matrix dimension n is npft, and the
c     vector c is the array cof.
c
c     If the xvec array was scaled using EQLIBU/scalx1.f, the resulting
c     yvec array should be rescaled using EQLIBU/rscaly.f.
c
c     This subroutine is called by:
c
c       EQPT/intrp.f
c       Any
c
c-----------------------------------------------------------------------
c
c     Input:
c
c       xvec   = the x vector
c       yvec   = the y vector
c       npft   = number of x,y points
c
c     Output:
c
c       cof    = the array of coefficients fo the fitted polynomial
c       ier    = error flag (returned by EQLIBU/msolvr.f):
c                  =  0  Okay
c                  =  1  Encountered a zero matrix
c                  =  2  Encountered a non-zero, computationally
c                          singular matrix
c
c-----------------------------------------------------------------------
c
      implicit none
c
c-----------------------------------------------------------------------
c
c     Calling sequence variable declarations.
c
      integer npfmax
c
      integer ipivot(npfmax)
      integer ier,noutpt,npft,nttyo
c
      real*8 aamatr(npfmax,npfmax),gmmatr(npfmax,npfmax)
      real*8 cof(npfmax),xvec(npfmax),yvec(npfmax)
c
c-----------------------------------------------------------------------
c
c     Local variable declarations.
c
      integer i,j
c
      logical qpr
c
      real*8 aax
c
c-----------------------------------------------------------------------
c
      data qpr    /.false./
c
c-----------------------------------------------------------------------
c
c     Initialize error flag.
c
      ier = 0
c
c     Set up a matrix equation.
c
      do j = 1,npft
        cof(j) = 0.
        aax = 1.
        aamatr(j,1) = 1.
        do i = 2,npft
          aax = aax*xvec(j)
          aamatr(j,i) = aax
        enddo
      enddo
c
c* * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c     Solve the matrix equation.
c
c     Calling sequence substitutions:
c       cof for delvec
c       npft for kdim
c       npfmax for kmax
c       yvec for rhsvec
c
      call msolvr(aamatr,cof,gmmatr,ier,ipivot,npft,npfmax,
     $ noutpt,nttyo,qpr,yvec)
c
      end


!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief This module provides data for gauss quadrature
module gauss_integration
  use hecmw
  implicit none
  real(kind=kreal) :: XG(3, 3) !< abscissa of gauss points
  real(kind=kreal) :: WGT(3, 3) !< wieght of gauss points
  !****************************
  !* Gauss Integration Table **
  !****************************
  !** 1st ***
  data XG (1,1)/0.0/
  data WGT(1,1)/2.0/
  !** 2nd ***
  data XG(2,1),XG(2,2)/-0.577350269189626,0.577350269189626/
  data WGT(2,1),WGT(2,2)/1.0,1.0/
  !** 3rd ***
  data XG(3,1),XG(3,2),XG(3,3)/  &
    -0.7745966692,               &
    0.0,                         &
    0.7745966692/
  data WGT(3,1),WGT(3,2),WGT(3,3)/ &
    0.5555555555,                  &
    0.8888888888,                  &
    0.5555555555/
  ! end of this module
end module gauss_integration


!--------------------------------------------------
!..Homework 1
!..Team 31
!..AE305 - Numerical Methods
!
!..This program calculates the take-off time of an airplane
!..at a provided altitude using either Euler's Metod
!..or RK2 method for a provided time step size and
!..outputs results to a file.
!--------------------------------------------------
Module data
   implicit none
   real,parameter:: WParea=29.24, takeoffweight=88250, TmaxSL=16256, nrofengines=2, friccoeff=0.02, grav=9.81
   real,parameter :: CL=1.792 ! CL is assumed constant
   real,parameter :: CD=0.2150 ! as CL is assumed constant, CD also became constant
!  Density obtained from the standart atmosphere table.
   real,parameter :: airdensitySL=1.225, airdensity1000m=1.112, airdensity2000m=1.007

   real :: rho, thrust ! These variables will be set when altitude is selected

   contains

     Function Liftf(vel) ! Calculate Lift
      real :: vel, Liftf
      Liftf = CL*(1./2)*rho*(vel**2)*WParea
      return
      End Function Liftf

     Function Dragf(vel) ! Calculate Drag
      real :: vel, Dragf
      Dragf = CD*(1./2)*rho*(vel**2)*WParea
      return
      End Function Dragf

     Function Thrustf(dens) ! Calculate Thrust
      real :: dens, Thrustf
      Thrustf = TmaxSL*(dens/airdensitySL)
      return
      End Function Thrustf

      Function ODE(vel) ! Slope function for velocity
         real:: vel
         real :: ODE
         ODE  = (thrust-Dragf(vel)-friccoeff*(takeoffweight-Liftf(vel)))*(grav/takeoffweight)
         return
       End
End module

PROGRAM HOMEWORK1
   use data

   implicit none

   character*40 :: fname
   real :: stepsize, k1, k2, velocity, velocityx, lift, time
   real, parameter:: a1 =1./4 , a2=3./4, p1=2./3 ! a1 and a2 are weights for RK2 Method
   integer :: method, selectedaltitude ! Inputs stored in these variables

!  Initial values
   time=0.
   velocity=0.
   lift=0.

!  Select numerical Method
   write(*,'(a)')'Select Method:'
   write(*,'(a)')' [1] Eulers Method'
   write(*,'(a)')' [2] RK Method'
   write(*,'(a)',advance='no')'Input :> '
   read(*,*) method

!  Check if selection is valid
   if(.not.(method .eq. 1 .or. method .eq. 2)) then
      write(*,*) 'Unidentified input, stopping program...'
      stop
   endif

!  Select altitude
   write(*,'(/,a)')'Select one of the available altitudes:'
   write(*,'(a)')' [1] 0 m (Sea Level)'
   write(*,'(a)')' [2] 1000 m '
   write(*,'(a)')' [3] 2000 m '
   write(*,'(a)',advance='no')'Input :> '
   read(*,*) selectedaltitude

!  Set proper variables for selected altitude
   Select case(selectedaltitude)
      case(1)
         write(*,*) 'Selected Sea Level'
         ! Set density and thrust for sea level
         rho = airdensitySL
         thrust = TmaxSL*nrofengines
      case(2)
         write(*,*) 'Selected 1000 m'
         ! Set density and thrust for 1000 m
         rho = airdensity1000m
         thrust = Thrustf(rho)*nrofengines
      case(3)
         ! Set density and thrust for 2000 m
         write(*,*) 'Selected 2000 m'
         rho = airdensity2000m
         thrust = Thrustf(rho)*nrofengines
      case default
         ! Validation check
         write(*,*) 'Unidentified input, stopping program...'
         stop
   end Select

!  Select time step
   write(*,'(/,(a))',advance='no')'Enter Time Step :> '
   read(*,*) stepsize

!  Open the output file
   write(*,'(/,a)',advance='no')'Enter the output file name [velocity.dat] :> '
   read(*,"(a)") fname
   if( fname .eq. " ") fname = "velocity.dat"
   open(1,file=fname,form="formatted")

!  Write the inital values to the output file
   write(1,"(3f12.3)") time, velocity

!  Use selected method
   Select case(method)
   case(1) ! EULER METHOD
      write(*,*) 'Using Eulers Method'
      do while ( lift .lt. takeoffweight )                      ! Check if lift off occured
         time  = time + stepsize                                ! New time is defined
         velocity = velocity + ODE(velocity)*stepsize           ! New velocity is defined
         lift = Liftf(velocity)                                 ! Calculate the lift to check if lift off occured
         write(1,"(2f12.3)") time, velocity
      enddo
      write(*,'(a,f6.3)') 'Minimum time needed to take off:', time ! Write result to terminal
   case(2) ! RK2 METHOD
      write(*,*) 'Using RK Method'
      do while ( lift .lt. takeoffweight )                      ! Check if lift off occured
         time = time + stepsize                                 ! New time is defined
         k1 = ODE(velocity)                                     ! k1 is calculated which is the slope at previous velocity
         velocityx = velocity + k1*p1*stepsize                  ! velocityx is calculated
         k2 = ODE(velocityx)                                    ! k2 is calculated which is the slope at velocityx
         velocity = velocity + ( a1*k1 + a2*k2 )* stepsize      ! New velocity is defined
         lift = Liftf(velocity)                                 ! Calculate the lift to check if lift off occured
         write(1,"(2f12.3)") time, velocity
      enddo
      write(*,'(a,f6.3)') 'Minimum time needed to take off:', time  ! Write result to terminal
   End select

!..Close the output file
   close(1)

   stop
END PROGRAM HOMEWORK1


module nfSpecialFunctions
  use nfConstants
  implicit none

  public :: legendrePoly

  interface legendrePoly
    module procedure legendrePoly_i, legendrePoly_r, legendrePoly_d
  end interface

contains

  recursive function legendrePolyFunc(n,x) result(res)
    integer :: i, n
    real(dp), allocatable :: poly(:)
    real(dp) :: x, res

    allocate(poly(n+1))
    poly(1) = 1.d0
    poly(2) = x
    if(n.eq.0) then
      res = 1
    elseif(n.eq.1) then
      res = x
    else
      do i=2,n
        res = 0.d0
        res = (2*(i-1)+1)*x*poly(i)
        res = res - (i-1)*poly(i-1)
        res = res/(i)
        poly(i+1) = res
      end do
      res = poly(n+1)
    end if
    deallocate(poly)
  end function

  real(dp) function legendrePoly_i(n,x)
    integer :: n, x
    legendrePoly_i = legendrePolyFunc(n,dble(x))
  end function

  real(dp) function legendrePoly_r(n,x)
    integer :: n
    real :: x
    legendrePoly_r = legendrePolyFunc(n,dble(x))
  end function

  real(dp) function legendrePoly_d(n,x)
    integer :: n
    real(dp) :: x
    legendrePoly_d = legendrePolyFunc(n,dble(x))
  end function

  end module nfSpecialFunctions


program epstest

use, intrinsic :: iso_fortran_env, only : real32, real64
use, intrinsic :: ieee_arithmetic, only : ieee_next_after

implicit none (type, external)

real(real32) :: one32_eps, eps32
real(real64) :: one64_eps, eps64

eps32 = epsilon(0._real32)
eps64 = epsilon(0._real64)

print *, "epsilon real32", eps32
print *, "epsilon real64", eps64

one32_eps = ieee_next_after(1._real32, 2.)
one64_eps = ieee_next_after(1._real64, 2.)

!> this test should be bit exact true
if (one32_eps - eps32 /= 1) error stop "real32 epsilon not meeting specification"
if (one64_eps - eps64 /= 1) error stop "real64 epsilon not meeting specification"

end program


subroutine cell_area (nlat, nlon, numlon, lon_w, lat_s, re, area)

  use precision

  implicit none
! ------------------------ code history ---------------------------
! source file:       cell_area.F
! purpose:           area of grid cells
! date last revised: March 1996
! author:            Gordon Bonan
! standardized:
! reviewed:
! -----------------------------------------------------------------

! ------------------- input variables -----------------------------
  integer nlat            !number of latitude points
  integer nlon            !maximum number of longitude points
  integer numlon(nlat)    !number of longitude points for each latitude
  real(r8) lon_w(nlon+1,nlat) !grid cell longitude, western edge (degrees)
  real(r8) lat_s(nlat+1)      !grid cell latitude, southern edge (degrees)
! -----------------------------------------------------------------

! ------------------- output variables ----------------------------
  real(r8) re              !radius of earth (km)
  real(r8) area(nlon,nlat) !cell area (km**2)
! -----------------------------------------------------------------

! ------------------- local variables -----------------------------
  integer i            !longitude index
  integer j            !latitude index

  real(r8) dx            !cell width
  real(r8) dy            !cell length
  real(r8) deg2rad       !pi/180
  real(r8) one
  parameter (one=1.)   ! Argument to atan
! -----------------------------------------------------------------

  deg2rad = (4.*atan(one)) / 180.
  re = 6371.227709

  do j = 1, nlat
    do i = 1, numlon(j)
      dx = (lon_w(i+1,j)-lon_w(i,j)) * deg2rad
      dy = sin(lat_s(j+1)*deg2rad) - sin(lat_s(j)*deg2rad)
      area(i,j) = dx*dy*re*re
    end do
  end do

  return
end subroutine cell_area


SUBROUTINE productdot(r1,r2 , dp)

! ----------------------------------------------------------------------
! SUBROUTINE: productdot.f90
! ----------------------------------------------------------------------
! Purpose:
!  Dot product between two vectors (scalar product)
! ----------------------------------------------------------------------
! Input arguments:
! - r1 : first vector   [x1 y1 z1]'
! - r2 : second vector  [x2 y2 z2]'
!
! Output arguments:
! - dp : Dot product of r1,r2 vectors (scalar)
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia         24 November 2015
! ----------------------------------------------------------------------

      USE mdl_precision
      IMPLICIT NONE

! ---------------------------------------------------------------------------
! Dummy arguments declaration
! ---------------------------------------------------------------------------
! IN
      REAL (KIND = prec_q), INTENT(IN), DIMENSION(3) :: r1, r2
! OUT
      REAL (KIND = prec_q), INTENT(OUT) :: dp
! ---------------------------------------------------------------------------

      dp = r1(1) * r2(1) + r1(2) * r2(2) + r1(3) * r2(3)

END


!     Crude Monte-Carlo integration

PROGRAM crude_mc_integration
  USE constants
  USE f90library
  IMPLICIT NONE
  INTEGER :: i, idum, samples
  REAL(DP) :: x, sumf, sum2f, fx, sigma

  INTERFACE
     DOUBLE PRECISION FUNCTION  func(x)
       IMPLICIT NONE
       DOUBLE PRECISION , INTENT(IN) :: x

     END FUNCTION func
  END INTERFACE
  WRITE(*,*) ' Enter number of MC sampling points'
  READ(*,*) samples
  !     initialise the total sum, standard deviation and seed idum
  sumf=0. ; sum2f=0. ; idum=-1
  DO i=1, samples
     x=ran1(idum)
     fx=func(x)
     sumf=sumf+fx
     sum2f=sum2f+fx*fx
  ENDDO
  sumf=sumf/FLOAT(samples)
  sum2f=sum2f/FLOAT(samples)
  sigma=SQRT((sum2f-sumf*sumf)/FLOAT(samples))
  WRITE(*,*) samples, sumf, sigma

END PROGRAM crude_mc_integration

!    The explicit function to be evaluated

REAL(DP)  FUNCTION  func(x)
  USE constants
  IMPLICIT NONE
  REAL(DP), INTENT(IN) :: x
  func=4/(1.+x*x)

END FUNCTION func


!*********************************************************
!>
! Spline Functions:
!
!  * Natural Cubic Spline

module cubicSpline
  use matrixSolver
  implicit none

  private :: dp
  integer, parameter :: dp = kind(0.d0)

contains

  subroutine naturalCubicSpline(xi, yi, splineA, splineB, splineC, splineD)
    implicit none
    integer :: n
    real(dp) :: xi(:), yi(:), splineA(:), splineB(:), splineC(:), splineD(:)
    real(dp), dimension(:), allocatable :: a,b,c,f,h

    n = size(xi,1)
    allocate(a(n), b(n), c(n), f(n), h(n))
    a(1) = 0.d0
    b(1) = 1.d0
    c(1) = 0.d0
    f(1) = 0.d0
    splineA(1:n) = yi(1:n)
    splineB(1:n) = 0.d0
    splineC(1:n) = 0.d0
    splineD(1:n) = 0.d0
    h(1:n) = abs(xi(2:n+1)-xi(1:n))
    a(2:n) = h(1:n-1)
    b(2:n) = 2.d0*(h(1:n-1)+h(2:n))
    c(2:n) = h(2:n)
    f(2:n) = abs(3.d0*(yi(3:n+1)-yi(2:n))/h(2:n) - 3.d0*(yi(2:n)-yi(1:n-1))/h(1:n-1))
    a(n) = 0.d0
    b(n) = 1.d0
    c(n) = 0.d0
    f(n) = 0.d0
    call tridiagonalSolver(a,b,c,f,splineC)
    splineD(1:n-1) = (splineC(2:n) - splineC(1:n-1))/(3.d0*h(1:n-1))
    splineB(1:n-1) = (yi(2:n) - yi(1:n-1))/h(1:n-1) - splineC(1:n-1)*h(1:n-1) -&
                      splineD(1:n-1)*h(1:n-1)*h(1:n-1)
    deallocate(a,b,c,f,h)
  end subroutine naturalCubicSpline

  real(dp) function computeNaturalCubicSpline(xi, x, splineA, splineB, splineC, splineD)
    implicit none
    integer :: i, n
    real(dp) :: xi(:), x, splineA(:), splineB(:), splineC(:), splineD(:), output, dx

    n = size(xi,1)
    do i=n-1,1,-1
      if(x.ge.xi(i)) then
        exit
      end if
    end do
    dx = x - xi(i)
    output = splineA(i) + dx*(splineB(i) + dx*(splineC(i) + splineD(i)*dx))
    computeNaturalCubicSpline = output
  end function computeNaturalCubicSpline

end module


program compute_factorial
    implicit none
    integer :: i
    integer, dimension(5) :: values = [ (i, i=1,5) ]

    print *, values
    print *, factorial(values)

contains

    elemental integer function factorial(n)
        implicit none
        integer, value :: n
        integer :: i

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

end program compute_factorial


subroutine cal_sd(n,x,sd)
  implicit none
  integer,intent(in) :: n
  double precision, intent(in) :: x(n)
  double precision, intent(out) :: sd
  integer :: i
  double precision :: mean, mean2
  mean = 0.d0
  mean2 = 0.d0
  do i = 1, n
    mean = mean + x(i)
    mean2 = mean2 + x(i)**2
  end do
  mean = mean/n
  mean2 = mean2/n
  sd = sqrt(mean2 - mean**2)
end subroutine cal_sd


program main
  ! Default
  implicit none

  ! Parameters
  integer(4), parameter :: max_divisor = 20

  ! Variables
  integer(4) :: i

  ! Do work
  i = max_divisor + 1
  do
     if (is_divisible(i)) then
        exit
     else
        i = i + 1
     endif
  enddo

  ! Write out result
  write(*,*) "Smallest number divisible by all numbers less than ",max_divisor,&
       ": ",i

contains

  pure function is_divisible(targ)
    ! Default
    implicit none

    ! Function arguments
    integer(4), intent(in) :: targ
    logical                :: is_divisible

    ! Local variables
    integer(4) :: i

    ! Check if the number is divisible by all factors
    do i=2,max_divisor
       if (mod(targ,i)/=0) then
          is_divisible = .false.
          return
       endif
    enddo

    is_divisible = .true.
    return
  end function is_divisible

end program main


program main
    implicit none
    integer, parameter :: dp = selected_real_kind(8)

    integer, allocatable :: seed(:)
    integer :: n
    real(dp) :: t_begin, t_end
    integer :: i, num_pt = 1000

    interface
        function Random_pt_annulus_general(r_1_, r_2_)
            ! 变换抽样一般方法产生圆环上均匀分布的随机点
            implicit none
            integer, parameter :: dp = selected_real_kind(8)

            real(dp), intent(in), optional :: r_1_, r_2_
            real(dp) :: Random_pt_annulus_general(2) ! (r, theta)
        end function Random_pt_annulus_general

        function Random_pt_annulus(r_1_, r_2_)
            ! 抽样法产生圆环上均匀分布的随机点
            implicit none
            integer, parameter :: dp = selected_real_kind(8)

            real(dp), intent(in), optional :: r_1_, r_2_
            real(dp) :: Random_pt_annulus(2)
        end function Random_pt_annulus

        function Gaussian_Box_Muller_improved(x_bar_, sigma_square_)
            ! Box-Muller 法产生服从正态分布的随机数，其中随机数的三角函数通过抽样得到
            implicit none
            integer, parameter :: dp = selected_real_kind(8)

            real(dp), intent(in), optional :: x_bar_, sigma_square_ ! 均值和方差
            real(dp) :: Gaussian_Box_Muller_improved
        end function Gaussian_Box_Muller_improved

        function Marsaglia_3d_sphere()
            ! 三维球面上的 Marsaglia 方法
            implicit none
            integer, parameter :: dp = selected_real_kind(8)

            real(dp) :: Marsaglia_3d_sphere(3) ! (x, y, z)
        end function Marsaglia_3d_sphere
    end interface

    call random_seed(size=n)
    allocate(seed(n))
    seed = 1
    call random_seed(put=seed)
    call cpu_time(t_begin)
    open(unit=11, file='1.2.2.3-Random-Points-on-Annulus-Transform-Sampling-General-Method.txt', status='replace')
    do i = 1, num_pt
        write(11, '(2f16.8)') Random_pt_annulus_general(1.d0, 2.d0)
    end do
    close(11)
    call cpu_time(t_end)
    write(*,*)&
    'Generate random points uniformly distributed on annulus by transform sampling general method. Time consumed = ',&
    t_end - t_begin

    call cpu_time(t_begin)
    open(unit=11, file='1.2.2.3-Random-Points-on-Annulus-Sampling.txt', status='replace')
    do i = 1, num_pt
        write(11, '(2f16.8)') Random_pt_annulus(1.d0, 2.d0)
    end do
    close(11)
    call cpu_time(t_end)
    write(*,*)&
    'Generate random points uniformly distributed on annulus by sampling. Time consumed = ',&
    t_end - t_begin

    open(unit=11, file='1.2.2.3-Gaussian-Random-Variable.txt', status='replace')
    do i = 1, num_pt
        write(11, '(f16.8)') Gaussian_Box_Muller_improved(1.d0, 1.d0)
    end do
    close(11)

    open(unit=11, file='1.2.2.3-Random-Points-on-3d-Sphere.txt')
    do i = 1, num_pt
        write(11, '(3f16.8)') Marsaglia_3d_sphere()
    end do
    close(11)
end program main

function Random_pt_annulus_general(r_1_, r_2_)
    ! 变换抽样一般方法产生圆环上均匀分布的随机点
    implicit none
    integer, parameter :: dp = selected_real_kind(8)
    real(dp), parameter :: pi = acos(-1.d0)

    real(dp), intent(in), optional :: r_1_, r_2_
    real(dp) :: Random_pt_annulus_general(2) ! (x, y)

    real(dp) :: r_inner, r_outer ! 内径和外径
    real(dp) :: xi
    real(dp) :: r, theta

    if ((present(r_1_)) .and. (present(r_2_))) then
        if (r_1_ < r_2_) then
            r_inner = r_1_
            r_outer = r_2_
        else if (r_1_ > r_2_) then
            r_inner = r_2_
            r_outer = r_1_
        else
            write(*,*) 'Inner radius equals outer radius, cannot generate random points.'
            Random_pt_annulus_general = 0.d0
            return
        end if
    else
        r_inner = 0.d0
        r_outer = 1.d0
    end if

    call random_number(xi)
    r = sqrt((r_outer**2.d0 - r_inner**2.d0) * xi + r_inner**2.d0)
    call random_number(xi)
    theta = 2.d0 * pi * xi
    Random_pt_annulus_general(1) = r * cos(theta)
    Random_pt_annulus_general(2) = r * sin(theta)
end function Random_pt_annulus_general

function Random_pt_annulus(r_1_, r_2_)
    ! hit-or-miss 法产生圆环上均匀分布的随机点
    implicit none
    integer, parameter :: dp = selected_real_kind(8)

    real(dp), intent(in), optional :: r_1_, r_2_
    real(dp) :: Random_pt_annulus(2) ! (x, y)

    real(dp) :: r_inner, r_outer ! 内径和外径

    if ((present(r_1_)) .and. (present(r_2_))) then
        if (r_1_ < r_2_) then
            r_inner = r_1_
            r_outer = r_2_
        else if (r_1_ > r_2_) then
            r_inner = r_2_
            r_outer = r_1_
        else
            write(*,*) 'Inner radius equals outer radius, cannot generate random points.'
            Random_pt_annulus = 0.d0
            return
        end if
    else
        r_inner = 0.d0
        r_outer = 1.d0
    end if

    do while (.true.)
        call random_number(Random_pt_annulus(1))
        call random_number(Random_pt_annulus(2))
        Random_pt_annulus = (2 * Random_pt_annulus - 1) * r_outer
        if ((r_inner**2 <= sum(Random_pt_annulus**2)) .and. (sum(Random_pt_annulus**2) < r_outer**2)) then
            return
        end if
    end do
end function

function Gaussian_Box_Muller_improved(x_bar_, sigma_square_)
    ! Box-Muller 法产生服从正态分布的随机数，其中随机数的三角函数通过 hit-or-miss 法得到
    implicit none
    integer, parameter :: dp = selected_real_kind(8)

    real(dp), intent(in), optional :: x_bar_, sigma_square_ ! 均值和方差
    real(dp) :: Gaussian_Box_Muller_improved

    real(dp) :: x_bar, sigma_square
    real(dp) :: u, v, xi

    if (present(x_bar_)) then
        x_bar = x_bar_
    else
        x_bar = 0.d0
    end if
    if (present(sigma_square_)) then
        sigma_square = sigma_square_
    else
        sigma_square = 1.d0
    end if

    do while (.true.)
        call random_number(u)
        call random_number(v)
        u = 2.d0 * u - 1.d0
        v = 2.d0 * v - 1.d0
        if (u**2.d0 + v**2.d0 < 1.d0) then
            exit
        end if
    end do
    call random_number(xi)
    Gaussian_Box_Muller_improved = u * sqrt(-2.d0 * log(xi))
    ! Gaussian_Box_Muller_improved = v * sqrt(-2.d0 * log(xi))
    Gaussian_Box_Muller_improved = Gaussian_Box_Muller_improved * sqrt(sigma_square) + x_bar
end function Gaussian_Box_Muller_improved

function Marsaglia_3d_sphere()
    ! 三维球面上的 Marsaglia 方法
    implicit none
    integer, parameter :: dp = selected_real_kind(8)

    real(dp) :: Marsaglia_3d_sphere(3) ! (x, y, z)

    real(dp) :: u, v, r_square

    do while (.true.)
        call random_number(u)
        call random_number(v)
        u = 2.d0 * u - 1.d0
        v = 2.d0 * v - 1.d0
        r_square = u**2.d0 + v**2.d0
        if (r_square <= 1) then
            exit
        end if
    end do

    Marsaglia_3d_sphere(1) = 2.d0 * u * sqrt(1 - r_square)
    Marsaglia_3d_sphere(2) = 2.d0 * v * sqrt(1 - r_square)
    Marsaglia_3d_sphere(3) = 1 - 2.d0 * r_square
end function Marsaglia_3d_sphere


!-------------------------------------------------------------------------------------------------
! Fortran source code for module ctef2py.getgauss
!-------------------------------------------------------------------------------------------------
! Remarks:
!   . Enter Python documentation for this module in ``./getgauss.rst``.
!     You might want to check the f2py output for the interfaces of the C-wrapper functions.
!     It will be autmatically included in the ctef2py documentation.
!   . Documument the Fortran routines in this file. This documentation will not be included
!     in the ctef2py documentation (because there is no recent sphinx
!     extension for modern fortran.

! ---------------------------------------------------------------------------------------------------------------
! ORIGINAL AUTHORS : MIKE BLASKIEWISC, RODERIK BRUCE, MICHAELA SCHAUMANN, TOM MERTENS
! ---------------------------------------------------------------------------------------------------------------
! VERSION 2.0 : UPDATE TO TRACK MULTIPLE BUNCHES AND HAVE DIFFERENT PARTICLE TYPES (P-PB)
!   AUTHOR    : TOM MERTENS
!   DATE      : 19/12/2016
!   COPYRIGHT : CERN
!
!   DESCRIPTION :
!       FUNCTION TO GET DOUBLE GAUSSIAN
!       RETURNS TWO GAUSSIAN DISTRIBUTED RANDOM NUMBERS WITH SIGMA SQRT 3
! ---------------------------------------------------------------------------------------------------------------

subroutine getgaussrv(iseed,grv1,grv2)
  double precision, intent(inout) :: iseed
  double precision, intent(out):: grv1,grv2
  double precision :: r1,r2,facc,amp

  44 continue
     call random_number(iseed)
     r1 = 2*iseed-1
     r2 = 2*iseed-1
     amp = r1**2 + r2**2

     if ((amp.ge.1).or.(amp.lt. 1.e-8)) go to 44
     facc = sqrt(-2.*log(amp)/amp)
     grv1 = r1*facc/sqrt(3.)
     grv2 = r2*facc/sqrt(3.)
     return
end subroutine getgaussrv


      FUNCTION expint(n,x)
      INTEGER n,MAXIT
      REAL expint,x,EPS,FPMIN,EULER
      PARAMETER (MAXIT=100,EPS=1.e-7,FPMIN=1.e-30,EULER=.5772156649)
      INTEGER i,ii,nm1
      REAL a,b,c,d,del,fact,h,psi
      nm1=n-1
      if(n.lt.0.or.x.lt.0..or.(x.eq.0..and.(n.eq.0.or.n.eq.1)))then
        pause 'bad arguments in expint'
      else if(n.eq.0)then
        expint=exp(-x)/x
      else if(x.eq.0.)then
        expint=1./nm1
      else if(x.gt.1.)then
        b=x+n
        c=1./FPMIN
        d=1./b
        h=d
        do 11 i=1,MAXIT
          a=-i*(nm1+i)
          b=b+2.
          d=1./(a*d+b)
          c=b+a/c
          del=c*d
          h=h*del
          if(abs(del-1.).lt.EPS)then
            expint=h*exp(-x)
            return
          endif
11      continue
        pause 'continued fraction failed in expint'
      else
        if(nm1.ne.0)then
          expint=1./nm1
        else
          expint=-log(x)-EULER
        endif
        fact=1.
        do 13 i=1,MAXIT
          fact=-fact*x/i
          if(i.ne.nm1)then
            del=-fact/(i-nm1)
          else
            psi=-EULER
            do 12 ii=1,nm1
              psi=psi+1./ii
12          continue
            del=fact*(-log(x)+psi)
          endif
          expint=expint+del
          if(abs(del).lt.abs(expint)*EPS) return
13      continue
        pause 'series failed in expint'
      endif
      return
      END

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


real function pnorm(x,mean,sd)
! This function calculates the area of the tail left to x
! of the Gaussian curve with mean and sd
implicit none
real, intent(in) :: x, mean, sd
real             :: x_
real, parameter  :: inv_sqrt2 = 1d0/sqrt(2d0)

x_    = (x-mean)/sd
pnorm = 0.5*(1d0+erf(x_*inv_sqrt2))
return
end function pnorm


!ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
!
  SUBROUTINE plag_coeff(npoi,nder,x,xp,coef)
    !
    ! npoi - number of points (determines the order of Lagrange
    ! polynomial
    ! which is equal npoi-1)
    ! nder - number of derivatives computed 0 - function only, 1 - first
    ! derivative
    ! x - actual point where function and derivatives are evaluated
    ! xp(npoi) - array of points where function is known
    ! coef(0:nder,npoi) - weights for computation of function and
    ! derivatives,
    ! f=sum(fun(1:npoi)*coef(0,1:npoi) gives the function value
    ! df=sum(fun(1:npoi)*coef(1,1:npoi) gives the derivative value value
    !
    !
    INTEGER, INTENT(in)                                :: npoi,nder
    double precision, INTENT(in)                          :: x
    double precision, DIMENSION(npoi), INTENT(in)         :: xp
    double precision, DIMENSION(0:nder,npoi), INTENT(out) :: coef
    double precision, DIMENSION(:), ALLOCATABLE           :: dummy
    !
    INTEGER                                            :: i,k,j
    double precision                                      :: fac
    !
    DO i=1,npoi
       coef(0,i)=1.d0
       DO k=1,npoi
          IF(k.EQ.i) CYCLE
          coef(0,i)=coef(0,i)*(x-xp(k))/(xp(i)-xp(k))
       ENDDO
    ENDDO
    !
    IF(nder.EQ.0) RETURN
    !
    ALLOCATE(dummy(npoi))
    !
    DO i=1,npoi
       dummy=1.d0
       dummy(i)=0.d0
       DO k=1,npoi
          IF(k.EQ.i) CYCLE
          fac=(x-xp(k))/(xp(i)-xp(k))
          DO j=1,npoi
             IF(j.EQ.k) THEN
                dummy(j)=dummy(j)/(xp(i)-xp(k))
             ELSE
                dummy(j)=dummy(j)*fac
             ENDIF
          ENDDO
       ENDDO
       coef(1,i)=SUM(dummy)
    ENDDO
    !
    DEALLOCATE(dummy)
    !
    RETURN
  END SUBROUTINE plag_coeff


PROGRAM mbernoa

! Code converted using TO_F90 by Alan Miller
! Date: 2004-06-28  Time: 12:58:09

!       ===========================================================
!       Purpose: This program computes Bernoulli number Bn using
!                subroutine BERNOA
!       Example: Compute Bernouli number Bn for n = 0,1,...,10
!                Computed results:

!                   n            Bn
!                 --------------------------
!                   0     .100000000000D+01
!                   1    -.500000000000D+00
!                   2     .166666666667D+00
!                   4    -.333333333333D-01
!                   6     .238095238095D-01
!                   8    -.333333333333D-01
!                  10     .757575757576D-01
!       ===========================================================

DOUBLE PRECISION :: b
DIMENSION b(0:200)
WRITE(*,*)'  Please enter Nmax'
!        READ(*,*)N
n=10
CALL bernoa(n,b)
WRITE(*,*)'   n            Bn'
WRITE(*,*)' --------------------------'
WRITE(*,20)0,b(0)
WRITE(*,20)1,b(1)
DO  k=2,n,2
  WRITE(*,20)k,b(k)
END DO
20      FORMAT(2X,i3,d22.12)
END PROGRAM mbernoa

SUBROUTINE bernoa(n,bn)

!       ======================================
!       Purpose: Compute Bernoulli number Bn
!       Input :  n --- Serial number
!       Output:  BN(n) --- Bn
!       ======================================

INTEGER, INTENT(IN)                      :: n
DOUBLE PRECISION, INTENT(OUT)            :: bn(0:n)
IMPLICIT DOUBLE PRECISION (a-h,o-z)

bn(0)=1.0D0
bn(1)=-0.5D0
DO  m=2,n
  s=-(1.0D0/(m+1.0D0)-0.5D0)
  DO  k=2,m-1
    r=1.0D0
    DO  j=2,k
      r=r*(j+m-k)/j
    END DO
    s=s-r*bn(k)
  END DO
  bn(m)=s
END DO
DO  m=3,n,2
  bn(m)=0.0D0
END DO
RETURN
END SUBROUTINE bernoa


! 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