! create a gaussian profile for bathymetry

  program create_gaussian_profile

  implicit none

  integer, parameter :: N = 200

  double precision, parameter :: horiz_size = 20000.d0, x0 = horiz_size / 2.d0, sigma = horiz_size / 40.d0, height = 300.d0

  double precision :: deltax,x

  integer :: i

  deltax = horiz_size / dble(N-1)

  do i = 1,N
    x = (i-1) * deltax
    print *,x, -3000.d0 + height * exp(-(x-x0)**2/(2*sigma**2))
  enddo

 end program create_gaussian_profile


!***********************************************************************
!                                                                      *
      SUBROUTINE Y_K(K,KM,GTheta,Phi,VAL_REAL,VAL_IM)
!                                                                      *
!     Calculates the spheric function Y^k _q by its algebraic formulae *
!     (see  subsection 5.2.2  Eq. (9) page 134 in                      *
!     D.A. Varshalovich, A.N. Moskalev and V.K. Khersonskii,           *
!     Quantum Theory of Angular Momentum; Berkeley, CA, 1981).         *
!                                                                      *
!     Written by G. Gaigalas and E. Gaidamauskas                       *
!                                         Last revision: 08 Sep 2008   *
!                                                                      *
!***********************************************************************
!
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY: DOUBLE
      USE CONS_C,          ONLY: ZERO, ONE
      USE FACTS_C
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN)       :: K, KM
      REAL(DOUBLE), INTENT(IN)  :: GTheta, Phi
      REAL(DOUBLE), INTENT(OUT) :: VAL_REAL, VAL_IM
!-----------------------------------------------
!   L o c a l   P a r a m e t e r s
!-----------------------------------------------
!      INTEGER, PARAMETER :: MFACT = 500
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!----------------------------------------------
      INTEGER :: I, MAX_REZIS, MIN_REZIS
      REAL(DOUBLE) :: PI, SUM, COEF
!----------------------------------------------
!
      IF (K >= IABS(KM)) THEN
         PI = 4.0D00*DATAN (ONE)
         IF(KM < 0) THEN
            MAX_REZIS = K
            MIN_REZIS = -KM
         ELSE
            MAX_REZIS = K
            MIN_REZIS = 0
         END IF
         SUM = ZERO
         DO I = MIN_REZIS, MAX_REZIS
            IF((2*I+KM) == 0) THEN
               SUM = (-1)**I * DEXP(GAM(K+I+1))/DEXP(GAM(K-I+1))       &
                   / (DEXP(GAM(I+1))*DEXP(GAM(I+KM+1)))                &
                   + SUM
            ELSE
               SUM = (-1)**I * DEXP(GAM(K+I+1))/DEXP(GAM(K-I+1))       &
                   * DSIN(GTheta*0.5)**(2*I+KM)                        &
                   / (DEXP(GAM(I+1))*DEXP(GAM(I+KM+1)))                &
                   + SUM
            END IF
         END DO
         COEF = (-1)**KM*DSQRT((2.0*K+1.0)*DEXP(GAM(K+KM+1))/          &
                (4.0*PI*DEXP(GAM(K-KM+1))))
         IF(KM == 0) THEN
            COEF = COEF
         ELSE
            COEF = COEF/(DCOS(GTheta*0.5))**KM
         END IF
         VAL_REAL = DCOS(KM*Phi)*COEF*SUM
         VAL_IM   = DSIN(KM*Phi)*COEF*SUM
      ELSE
         VAL_REAL = ZERO
         VAL_IM   = ZERO
      END IF
      RETURN
      END SUBROUTINE Y_K


MODULE FDLIB
 IMPLICIT NONE
 CONTAINS
!-----------------------------------------------------------
 INTEGER FUNCTION FCTL(N)
  IMPLICIT NONE
  INTEGER :: I, N
  IF (N == 0) THEN
   FCTL = 1
  ELSE
   FCTL = 1
   DO I = 1,N
    FCTL = FCTL*I
   END DO
  END IF
 END FUNCTION FCTL
!-----------------------------------------------------------
 FUNCTION COMB(K,N) RESULT(KCN)
  IMPLICIT NONE
  INTEGER :: K, N
  INTEGER :: NUM, DENOM
  REAL :: KCN
  NUM = FCTL(N)
  DENOM = FCTL(K)*FCTL(N-K)
  KCN = NUM/DENOM
 END FUNCTION COMB
!-----------------------------------------------------------
 FUNCTION FD(I) RESULT(COEFFS)
  IMPLICIT NONE
  INTEGER, INTENT(IN) :: I
  INTEGER, DIMENSION(0:I) :: COEFFS
  INTEGER :: J, Q, R
  R = MOD(I,2)
  IF (R == 0) THEN
   Q = I/2
  ELSE
   Q = (I-1)/2
  ENDIF
  DO J = 0,I
   COEFFS(J) = ((-1)**(Q-J))*COMB(J,I)
  END DO
 END FUNCTION FD
!-----------------------------------------------------------
END MODULE FDLIB


      SUBROUTINE MAPLL (X,Y,ALAT,ALONG,SLAT,SGN,E,RE)
C$*****************************************************************************
C$                                                                            *
C$                                                                            *
C$    DESCRIPTION:                                                            *
C$                                                                            *
C$    This subroutine converts from geodetic latitude and longitude to Polar  *
C$    Stereographic (X,Y) coordinates for the polar regions.  The equations   *
C$    are from Snyder, J. P., 1982,  Map Projections Used by the U.S.         *
C$    Geological Survey, Geological Survey Bulletin 1532, U.S. Government     *
C$    Printing Office.  See JPL Technical Memorandum 3349-85-101 for further  *
C$    details.                                                                *
C$                                                                            *
C$                                                                            *
C$    ARGUMENTS:                                                              *
C$                                                                            *
C$    Variable    Type        I/O    Description                              *
C$                                                                            *
C$    ALAT       REAL*4        I     Geodetic Latitude (degrees, +90 to -90)  *
C$    ALONG      REAL*4        I     Geodetic Longitude (degrees, 0 to 360)   *
C$    X          REAL*4        O     Polar Stereographic X Coordinate (km)    *
C$    Y          REAL*4        O     Polar Stereographic Y Coordinate (km)    *
C$                                                                            *
C$                                                                            *
C$                  Written by C. S. Morris - April 29, 1985                  *
C$                  Revised by C. S. Morris - December 11, 1985               *
C$                                                                     	      *
C$                  Revised by V. J. Troisi - January 1990                    *
C$                  SGN - provides hemisphere dependency (+/- 1)              *
C$		    Revised by Xiaoming Li - October 1996                     *
C$		    Corrected equation for RHO                                *
C$*****************************************************************************
      REAL*4 X,Y,ALAT,ALONG,E,E2,CDR,PI,SLAT,MC
C$*****************************************************************************
C$                                                                            *
C$    DEFINITION OF CONSTANTS:                                                *
C$                                                                            *
C$    Conversion constant from degrees to radians = 57.29577951.              *
      CDR=57.29577951
      E2=E*E
C$    Pi=3.141592654.                                                         *
      PI=3.141592654
C$                                                                            *
C$*****************************************************************************
C     Compute X and Y in grid coordinates.
      IF (ABS(ALAT).LT.PI/2.) GOTO 250
      X=0.0
      Y=0.0
      GOTO 999
  250 CONTINUE
      T=TAN(PI/4.-ALAT/2.)/((1.-E*SIN(ALAT))/(1.+E*SIN(ALAT)))**(E/2.)
      IF (ABS(90.-SLAT).LT.1.E-5) THEN
      RHO=2.*RE*T/((1.+E)**(1.+E)*(1.-E)**(1.-E))**(1/2.)
      ELSE
      SL=SLAT*PI/180.
      TC=TAN(PI/4.-SL/2.)/((1.-E*SIN(SL))/(1.+E*SIN(SL)))**(E/2.)
      MC=COS(SL)/SQRT(1.0-E2*(SIN(SL)**2))
      RHO=RE*MC*T/TC
      END IF
      Y=-RHO*SGN*COS(SGN*ALONG)
      X= RHO*SGN*SIN(SGN*ALONG)
  999 CONTINUE
      END


module module_rk

use module_types, only: dp

implicit none

contains
! ...
! =====================================================================
! =====================================================================
! ...
function rk4(y,x,h,derivs) result(yout)

! Given values for the variables y(1:n) and their derivatives dydx(1:n)
! known at x, use the fourth-order Runge-Kutta method to advance the
! solution over an interval h and return the incremented variable as
! yout(1:n), which neet not be a distinct array from y. The user supplies
! the subroutine derivs(x,y,dydx), which returns derivatives dydx at x.
! Numerical Recipes

real(dp), dimension(:), intent(in)  :: y
real(dp), intent(in)                :: x,h
real(dp), dimension(size(y))        :: yout
external derivs

! ... Local variables
! ...
real(dp) h6,hh,xh
real(dp), dimension(size(y))        :: dydx,dym,dyt,yt

hh = h*0.5d0
h6 = h/6.d0
xh = x + hh

CALL derivs (x,y,dydx)
yt(:) = y(:) + hh*dydx(:)          ! First step

CALL derivs(xh,yt,dyt)             ! Second step
yt(:) = y(:) + hh*dyt(:)

CALL derivs(xh,yt,dym)             ! Third step
yt(:)  = y(:)   + h*dym(:)
dym(:) = dyt(:) + dym(:)

CALL derivs(x+h,yt,dyt)            ! Fourth step

                                   ! Accumulate increments with proper weights
yout(:) = y(:) + h6*(dydx(:)+dyt(:)+2.d0*dym(:))

return
end function rk4
! ...
! =====================================================================
! ...
function rk5 (x,t,h,RHS) result(xn)

! ... Given values for the variables x(1:n) and a function, RHS, returning
! ... its derivatives dxdt(1:n), a fifth-order Runge-Kutta
! ... method is used to advance the solution over an interval h and return
! ... the incremented variable as xn(1:n).
! ... The user must supply the subroutine RHS(t,x,dxdt) returning
! ... derivatives dxdt at t.
! ... Coefficients as in Butcher's Fifth Order
! ... Quim Ballabrera, March 2017.

real(dp), intent(in)                 :: t,h
real(dp), dimension(:), intent(in)   :: x
real(dp), dimension(size(x))         :: xn
external                             :: RHS

! ... Local variables
! ...
real(dp), dimension(size(x))         :: k1,k2,k3,k4,k5,k6

CALL RHS(t,x,k1)
k1 = h*k1

CALL RHS(t+0.25D0*h, x+0.25D0*k1, k2)
k2 = h*k2

CALL RHS(t+0.25D0*h, x+(k1+k2)/8.0D0, k3)
k3 = h*k3

CALL RHS(t+0.5D0*h, x-0.5D0*k2+k3, k4)
k4 = h*k4

CALL RHS(t+0.75D0*h, x+(3D0*k1+9D0*k4)/16.0D0, k5)
k5 = h*k5

CALL RHS(t+h, x+(-3.0D0*k1+2D0*k2+12.0D0*k3-12D0*k4+8D0*k5)/7.0D0, k6)
k6 = h*k6

xn(:) = x(:) + (7.0D0*k1(:) + 32.0D0*k3(:) + 12.0D0*k4(:) + &
                32.0D0*k5(:) + 7.0D0*k6(:))/90.0D0

return
end function rk5
! ...
! ====================================================================

end module module_rk


!------------------------------------------------------------------------
!EV The subroutines SPLINE and SPLINT can be used for interpolating a
!   function of one independent variable.
!------------------------------------------------------------------------

SUBROUTINE spline(x, y, n, yp1, ypn, y2)
    !
    ! Given arrays y(1:n) and x(1:n) containing a tabulated function and its
    ! independent variable, respectively, with x(1) < x(2) < ... < x(n), and given
    ! values yp1 and ypn for the 1st derivative of the interpolating function at
    ! the points 1 and n, respectively, this routine returns an array y2(1:n) of
    ! length n which contains the 2nd derivative of the interpolating function at
    ! the tabulated points x(i).  If yp1 and/or ypn are equal to 10^30 or larger,
    ! the routine is signaled to set the corresponding boundary condition for a
    ! natural spline, with zero 2nd derivative on that boundary.  From "Numerical
    ! Recipes", Ch. 3.3, p. 109.
    IMPLICIT NONE
    ! Passed variables:
    INTEGER n
    REAL x(n), y(n), yp1, ypn, y2(n)
    ! Local variables:
    INTEGER i, j, NMAX
    PARAMETER (NMAX = 500)        ! Maximum expected value of n
    REAL p, qn, sig, un, u(NMAX)
    !
    if (yp1.gt..99e30) then
        ! Natural lower boundary condition:
        y2(1) = 0.e0
        u(1) = 0.e0
    else
        ! Specified 1st derivative yp1:
        y2(1) = -.5e0
        u(1) = (3.e0 / (x(2) - x(1))) * ((y(2) - y(1)) / (x(2) - x(1)) - yp1)
    endif
    ! We need at least N+1 points to construct an interpolating polynomial
    ! of degree N:
    if (n.lt.4) stop ' Too few points for cubic spline'
    !
    ! Decomposition loop of the tridiagonal algorithm.
    ! y2,u: temporary storage of the decomposed factors.
    do i = 2, n - 1
        sig = (x(i) - x(i - 1)) / (x(i + 1) - x(i - 1))
        p = sig * y2(i - 1) + 2.e0
        y2(i) = (sig - 1.e0) / p
        u(i) = (6.e0 * ((y(i + 1) - y(i)) / (x(i + 1) - x(i)) - (y(i) - y(i - 1))&
                / (x(i) - x(i - 1))) / (x(i + 1) - x(i - 1)) - sig * u(i - 1)) / p
    enddo
    if (ypn.gt..99e30) then
        ! Natural upper boundary condition:
        qn = 0.e0
        un = 0.e0
    else
        ! Specified 1st derivative ypn:
        qn = .5e0
        un = (3.e0 / (x(n) - x(n - 1))) * (ypn - (y(n) - y(n - 1)) / (x(n) - x(n - 1)))
    endif
    y2(n) = (un - qn * u(n - 1)) / (qn * y2(n - 1) + 1.e0)
    !
    ! Backsubstitution loop of the tridiagonal algorithm.
    do j = n - 1, 1, -1
        y2(j) = y2(j) * y2(j + 1) + u(j)
    enddo
    !
    return
END


PROGRAM BENCHMARK
    USE ROOT

    REAL           :: a = 0, b = 1
    REAL           :: x, x_0 = 0.25, x_1 = 0.5, x_2 = 0.75
    REAL, EXTERNAL :: f, df

    INTEGER        :: nroot
    INTEGER        :: debug = 1

    nroot =  BRACKET(f, a, b)
    PRINT 1000, nroot
    PRINT *

    PRINT 2000, a, b
    x = BISECTION(f, a, b, debug)
    PRINT *

    PRINT 3000, a, b
    x = FALSE_POSITION(f, a, b, debug)
    PRINT *

    PRINT 4000, x_0
    x = NEWTON_RAPHSON(f, df, x_0, debug)
    PRINT *

    PRINT 5000, x_0, x_1
    x = SECANT(f, x_0, x_1, debug)
    PRINT *

    PRINT 6000, x_0, x_1, x_2
    x = MUELLER(f, x_0, x_1, x_2, debug)

    ! format
    1000 FORMAT ('There is ', I2, ' root(s)')
    2000 FORMAT ('Bisection method: a = ', F7.3, ', b = ', F7.3)
    3000 FORMAT ('False position method: a = ', F7.3, ', b = ', F7.3)
    4000 FORMAT ('Newton-Raphson method: x_0 = ', F7.3)
    5000 FORMAT ('Secant method: x_0 = ', F7.3, ', x_1 = ', F7.3)
    6000 FORMAT ('Mueller method: x_0 = ', F7.3, ', x_1 = ', F7.3, ', x_2 = ', F7.3)
END PROGRAM BENCHMARK

REAL FUNCTION f(x)
    IMPLICIT NONE

    REAL, INTENT(IN) :: x

    f = COS(x) - x * SIN(x)
END FUNCTION f

REAL FUNCTION df(x)
    IMPLICIT NONE

    REAL, INTENT(IN) :: x

    df = -2 * SIN(x) - x * COS(x)
END FUNCTION df


! perfect_number.f90
! Calculate Perfect numbers
!
! vim: set ft=fortran sw=2 ts=2 :

module perfect_number
  implicit none
  private
  public :: perfect_numbers, perfect_numbers_realloc, to_string

contains

   pure logical function is_perfect (n)

    implicit none
    integer, intent( in ) :: n
    integer :: i, s, limit

    s = 0
    limit = int(sqrt(real(n)))
    do i = 1, (n-1)
    ! do i = 2, limit
      if (modulo(n, i) == 0) then
        s = s + i
      end if
    end do

    is_perfect = (s == n)

  end function is_perfect

  subroutine perfect_numbers_realloc (n, res)
    !use ISO_FORTRAN_ENV, only: ERROR_UNIT
    implicit none

    integer, intent( in ) :: n
    integer, dimension(:), allocatable, intent( out ) :: res
    integer :: i

    do i = 1, n
      if (is_perfect(i)) then
        if (allocated(res)) then
          res = [res, i]
        else
          res = [i]
        end if
      end if
    end do

  end subroutine perfect_numbers_realloc

  subroutine perfect_numbers (n, res)
    use ISO_FORTRAN_ENV, only: ERROR_UNIT
    implicit none

    integer, intent( in ) :: n
    integer, dimension(:), allocatable, intent( out ) :: res

    logical, dimension(:), allocatable :: flags
    integer :: s, i, c, idx

    ! flag perfect numbers
    allocate(flags(1:n), stat=s)
    if (s /= 0) then
      write (ERROR_UNIT,*) "Error allocating data"
      stop -1
    end if
    flags = .false.
    c = 0

    !$omp parallel do private(i), schedule(dynamic)
    do i = 1, n
      if (is_perfect(i)) then
        flags(i) = .true.
        c = c + 1
      end if
    end do
    !$omp end parallel do

    ! copy perfect numbers to output array
    allocate(res(1:c), stat=s)
    if (s /= 0) then
      write (ERROR_UNIT,*) "Error allocating data"
      stop -1
    end if

    idx = 1
    do i = 1, n
      if (flags(i)) then
        res(idx) = i
        idx = idx + 1
      end if
    end do

  end subroutine perfect_numbers

  subroutine to_string(ary, str)
    use ISO_FORTRAN_ENV, only: ERROR_UNIT
    implicit none

    integer, dimension(:), intent( in ) :: ary
    character(:), allocatable, intent( out ) :: str
    character(5) :: num_str

    integer :: len, s, i

    len = size(ary)

    allocate(character(8*len) :: str, stat=s)
    if (s /= 0) then
      write (ERROR_UNIT,*) "Error allocating data"
      stop -1
    end if

    ! fill-in output string
    str = ""
    do i = 1, (len-1)
      write(num_str, '(I5)') ary(i)
      str = str // num_str // ", "
    end do
    write(num_str, '(I5)') ary(len)
    str = str // num_str

  end subroutine to_string

end module perfect_number


!Matric Multiplication
program Intrinsic_FUnction
    implicit none

    INTEGER  :: i, j
    INTEGER, DIMENSION(2, 2) :: matA, matB, matC

    data matA(1, :)/1, 2/
    data matA(2, :)/2, 1/

    matB = reshape((/5, 6, 7, 8/), (/2, 2/))

    matC = MATMUL(matA, matB)

    print *, "Matric Multiplication of MAtA and MAtb is"

    do i = 1, 2
        print *, (matC(i, j), j=1, 2)
    end do

end program Intrinsic_FUnction


SUBROUTINE LUDCMPX (A , INDX , D , N , NP , ERROR )
IMPLICIT NONE
!PARAMETER DECLARATION
INTEGER, PARAMETER:: NMAX=50
!DATA DECLARATION
REAL(8) R0    /0.0D0/
REAL(8) R1    /1.0D0/
REAL(8) TINY  /1.0D-19/
CHARACTER	  NAME*6
DATA NAME/'LUDCMP'/
!SCALAR VARIABLES FROM ARGUMENTS
INTEGER N, NP
LOGICAL ERROR
REAL(8) D
!ARRAYS FROM ARGUMENTS
REAL(8), DIMENSION(NP,NP):: A
INTEGER, DIMENSION(N):: INDX
!LOCAL SCALAR VARIABLES
INTEGER I, J, K, IMAX
REAL(8) AAMAX, SUM, DUM
!LOCAL ARRAYS
REAL(8), DIMENSION(N):: VV
!INTIALIZE LOCAL SCALAR VARIABLES
I=0      ; J=0    ; K=0    ; IMAX=0
AAMAX=R0 ; SUM=R0 ; DUM=R0 ; VV=R0
!***********************************************************************
! Routine to do LU decomposition
! See NUMERICAL RECIPES p35.
!*ACRONYM
! LU_DeCOmPosition
!*DESCRIPTION
!*EXTERNAL
! Arrays
!=A      - LU decomposed matrix
!=INDX   - Permutation vector
! Variables
!=D      - Row interchange indicator
! N      - Size of the problem
! NP     - Physical size of A matrix ( NP >= N )
! ERROR  - Error flag
!*INTERNAL
! Arrays
! VV     - store the implicit scalling of each rows
!***********************************************************************
! Loop over each rows to get the implicit scalling factors
! --------------------------------------------------------
DO 12 I=1,N
	AAMAX=R0
        DO 11 J=1,N
        	IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
   	11   CONTINUE
        IF(AAMAX.EQ.R0)THEN
		ERROR=.TRUE.
          	GOTO 999
        ENDIF
        VV(I)=R1/AAMAX
12 CONTINUE
! Loop over columns of Crout's methods
! ------------------------------------
DO 19 J=1,N
	IF (J.GT.1) THEN
! Calculate upper triangle components Bij see equation(2.3.12), except i=j
        	DO 14 I=1,J-1
            		SUM=A(I,J)
            		IF (I.GT.1)THEN
              			DO 13 K=1,I-1
                			IF(ABS(A(I,K)).LT.TINY.AND.ABS(A(K,J)).LT.TINY)GOTO 13
! If A(I,K) and A(K,J) are very small, skip the following line
                			SUM=SUM-A(I,K)*A(K,J)
   				13         CONTINUE
              			A(I,J)=SUM
            		ENDIF
   		14     CONTINUE
	ENDIF
! Initialize for the search for largest pivot element
        AAMAX=R0
! Calculate diagonal components Bij see equation(2.3.12) ,i=j, and
! lower triangle components aij see equation 2.3.13, i=j+1,..N
        DO 16 I=J,N
        	SUM=A(I,J)
          	IF (J.GT.1)THEN
            		DO 15 K=1,J-1
              			IF(ABS(A(I,K)).LT.TINY.AND.ABS(A(K,J)).LT.TINY)GOTO 15
! If A(I,K) and A(K,J) are very small, skip the following line.
              			SUM=SUM-A(I,K)*A(K,J)
   			15       CONTINUE
            		A(I,J)=SUM
          	ENDIF
! Find largest pivot element
          	DUM=VV(I)*ABS(SUM)
          	IF (DUM.GE.AAMAX) THEN
            		IMAX=I
            		AAMAX=DUM
          	ENDIF
   	16   CONTINUE
! Interchange rows
        IF(J.NE.IMAX)THEN
        	DO 17 K=1,N
            		DUM=A(IMAX,K)
            		A(IMAX,K)=A(J,K)
            		A(J,K)=DUM
   		17     CONTINUE
! Change sign of row channge indicator and interchange scale factor
          	D=-D
          	VV(IMAX)=VV(J)
	ENDIF
! record interchange row number
        INDX(J)=IMAX
! Divided by the pivot element and get final aij values, see equation 2.3.13,
! i=j+1,..N
        IF(J.NE.N)THEN
        	IF(ABS(A(J,J)).LT.TINY)A(J,J)=TINY
          	DUM=R1/A(J,J)
          	DO 18 I=J+1,N
            		A(I,J)=A(I,J)*DUM
   		18     CONTINUE
	ENDIF
! Go back for next column
19 CONTINUE
IF(ABS(A(N,N)).LT.TINY)A(N,N)=TINY
999 CONTINUE
RETURN
END


module gamma_funcs
  use iso_fortran_env
  implicit none
contains
  elemental function digamma (x)

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

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

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

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

    r = r * r

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

  end function digamma

  elemental function trigamma (x)

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

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

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

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

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

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

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

  end function trigamma

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

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

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

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

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

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

  end function quadgamma

end module gamma_funcs


! --------------------------------------------------------------------
!
! Copyright (C) 2015 Rocco Meli
!
! This program is free software: you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation, either version 3 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
! ---------------------------------------------------------------------

MODULE OVERLAP

    USE CONSTANTS
    USE FACT
    USE GAUSSIAN
    USE LA

    CONTAINS

        FUNCTION Si(a,b,aa,bb,Rai,Rbi,Ri)
            ! ------------------------------------------------------------------------------------------------
            ! Compute overlap integral between two unnormalized Cartesian Gaussian functions along direction i
            ! ------------------------------------------------------------------------------------------------

            IMPLICIT NONE

            ! INPUT
            INTEGER, intent(in) :: a,b ! Angular momentum coefficients of the Gaussians along direction i
            REAL*8, intent(in) :: aa, bb ! Exponential coefficients of the Gaussians
            REAL*8, intent(in) :: Rai, Rbi ! Centers of the Gaussians
            REAL*8, intent(in) :: Ri ! Center of the Gaussians product

            ! INTERMEDIATE VARIABLE
            REAL*8 :: tmp
            INTEGER :: i ! Loop index
            INTEGER :: j ! Loop index

            ! OUTPUT
            REAL*8 :: Si

            Si = 0.0D0

            DO i = 0, a
                DO j = 0, b
                    IF (MOD(i+j,2) == 0) THEN
                        tmp = binom(a,i) * binom(b,j) * factorial2(i + j - 1)
                        tmp = tmp * (Ri-Rai)**(a-i)
                        tmp = tmp * (Ri-Rbi)**(b-j)
                        tmp = tmp / (2.0D0 * (aa + bb))**((i + j) / 2.0D0)

                        Si = Si + tmp
                    END IF
                END DO
            END DO
        END FUNCTION Si

        FUNCTION overlap_coeff(ax,ay,az,bx,by,bz,aa,bb,Ra,Rb) result(S)
            ! -----------------------------------------------------------------
            ! Compute overlap integral between two Cartesian Gaussian functions
            ! -----------------------------------------------------------------
            !
            ! Source:
            !   The Mathematica Journal
            !   Evaluation of Gaussian Molecular Integrals
            !   I. Overlap Integrals
            !   Minhhuy Hô and Julio Manuel Hernández-Pérez
            !
            ! -----------------------------------------------------------------

            IMPLICIT NONE

            ! INPUT
            INTEGER, intent(in) :: ax, ay, az, bx, by, bz ! Angular momentum coefficients
            REAL*8, intent(in) :: aa, bb ! Exponential Gaussian coefficients
            REAL*8, dimension(3), intent(in) :: Ra, Rb ! Gaussian centers

            ! INTERMEDIATE VARIABLES
            REAL*8 :: pp ! Gaussian produc exponential coefficient
            REAL*8, dimension(3) :: Rp ! Gaussian produc center
            REAL*8 :: cp ! Gaussian product multiplicative constant

            ! OUTPUT
            REAL*8 :: S

            CALL gaussian_product(aa,bb,Ra,Rb,pp,Rp,cp) ! Compute PP, RP and CP

            S = 1
            S = S * Si(ax,bx,aa,bb,Ra(1),Rb(1),Rp(1))       ! Overlap along x
            S = S * Si(ay,by,aa,bb,Ra(2),Rb(2),Rp(2))       ! Overlap along y
            S = S * Si(az,bz,aa,bb,Ra(3),Rb(3),Rp(3))       ! Overlap along z
            S = S * norm(ax,ay,az,aa) * norm(bx,by,bz,bb)   ! Normalization of Gaussian functions
            S = S * cp                                      ! Gaussian product factor
            S = S * (PI / pp)**(3./2.)                      ! Solution of Gaussian integral

        END FUNCTION overlap_coeff

        ! ------------------
        ! OBARA-SAIKA SCHEME
        ! ------------------

        FUNCTION S00(aa,bb,Rai,Rbi)
            ! -----------------------------------------------------------
            ! Compute overlap between Gaussian with zero angular momentum
            ! -----------------------------------------------------------
            !
            ! Source:
            !   T. Helgaker, P. Jørgensen and J. Olsen
            !   Molecular Electronic-Structure Theory
            !   Wiley
            !   2000
            !
            ! -----------------------------------------------------------

            IMPLICIT NONE

            ! INPUT
            REAL*8, intent(in) :: aa, bb    ! Exponential coefficients of the Gaussians
            REAL*8, intent(in) :: Rai, Rbi  ! Centers of the Gaussians

            ! OUTPUT
            REAL*8 :: S00

            S00 = DSQRT(PI / (aa + bb)) * DEXP(-(aa * bb) / (aa + bb) * (Rai - Rbi)**2.0D0)

        END FUNCTION S00

        FUNCTION Sij(a,b,aa,bb,Rai,Rbi,Rpi)
            ! ------------------------------------------------------------------------
            ! Compute overlap between Gaussian along one direction using OS recursion.
            ! ------------------------------------------------------------------------
            !
            ! Source:
            !   T. Helgaker, P. Jørgensen and J. Olsen
            !   Molecular Electronic-Structure Theory
            !   Wiley
            !   2000
            !
            ! ------------------------------------------------------------------------

            IMPLICIT NONE

            ! INPUT
            INTEGER, intent(in) :: a,b          ! Angular momentum coefficients of the Gaussians along direction i
            REAL*8, intent(in) :: aa, bb        ! Exponential coefficients of the Gaussians
            REAL*8, intent(in) :: Rai, Rbi      ! Centers of the Gaussians
            REAL*8, intent(in) :: Rpi           ! Center of Gaussian product

            ! INTERMEDIATE VARIABLE
            REAL*8, dimension(-1:a+1,-1:b+1) :: S   ! Vector of overlap coefficients
            INTEGER :: i, j

            ! OUTPUT
            REAL*8 :: Sij                       ! Overlap integral

            S(-1,:) = 0.0D0
            S(:,-1) = 0.0D0

            S(0,0) = S00(aa,bb,Rai,Rbi)

            DO i = 0, a
                DO j = 0, b
                    S(i+1,j) = (Rpi - Rai) * S(i,j) + 1.0D0 / (2 * (aa+bb)) * (i * S(i-1,j) + j * S(i,j-1))
                    S(i,j+1) = (Rpi - Rbi) * S(i,j) + 1.0D0 / (2 * (aa+bb)) * (i * S(i-1,j) + j * S(i,j-1))
                END DO
            END DO

            Sij = S(a,b)

        END FUNCTION Sij

        FUNCTION overlap_coeff_OS(ax,ay,az,bx,by,bz,aa,bb,Ra,Rb) result(S)
            ! ------------------------------------------------------------------------------------
            ! Compute overlap integral between two Cartesian Gaussian functions using OS recursion
            ! ------------------------------------------------------------------------------------

            IMPLICIT NONE

            ! INPUT
            INTEGER, intent(in) :: ax, ay, az, bx, by, bz ! Angular momentum coefficients
            REAL*8, intent(in) :: aa, bb ! Exponential Gaussian coefficients
            REAL*8, dimension(3), intent(in) :: Ra, Rb ! Gaussian centers

            ! INTERMEDIATE VARIABLES
            REAL*8 :: pp ! Gaussian produc exponential coefficient
            REAL*8, dimension(3) :: Rp ! Gaussian produc center
            REAL*8 :: cp ! Gaussian product multiplicative constant

            ! OUTPUT
            REAL*8 :: S

            CALL gaussian_product(aa,bb,Ra,Rb,pp,Rp,cp) ! Compute PP, RP and CP

            S = 1
            S = S * Sij(ax,bx,aa,bb,Ra(1),Rb(1),Rp(1))       ! Overlap along x
            S = S * Sij(ay,by,aa,bb,Ra(2),Rb(2),Rp(2))       ! Overlap along y
            S = S * Sij(az,bz,aa,bb,Ra(3),Rb(3),Rp(3))       ! Overlap along z
            S = S * norm(ax,ay,az,aa) * norm(bx,by,bz,bb)    ! Normalization of Gaussian functions

        END FUNCTION overlap_coeff_OS

        ! -------------
        ! OVERLAP MARIX
        ! -------------
        SUBROUTINE S_overlap(Kf,c,basis_D,basis_A,basis_L,basis_R,S)
            ! ----------------------------------------------
            ! Compute overlap matrix between basis function.
            ! ----------------------------------------------

            IMPLICIT NONE

            ! TODO Allow flexibility for basis sets other than STO-3G
            INTEGER, intent(in) :: c ! Number of contractions per basis function

            ! INPUT
            INTEGER, intent(in) :: Kf ! Number of basis functions
            REAL*8, dimension(Kf,3), intent(in) :: basis_R ! Basis set niclear positions
            INTEGER, dimension(Kf,3), intent(in) :: basis_L ! Basis set angular momenta
            REAL*8, dimension(Kf,3), intent(in) :: basis_D ! Basis set contraction coefficients
            REAL*8, dimension(Kf,3), intent(in) :: basis_A ! Basis set exponential contraction coefficients

            ! INTERMEDIATE VARIABLES
            INTEGER :: i,j,k,l
            REAL*8 :: tmp

            ! OUTPUT
            REAL*8, dimension(Kf,Kf), intent(out) :: S

            S(:,:) = 0.0D0

            DO i = 1,Kf
                DO j = 1,Kf
                    DO k = 1,c
                        DO l = 1,c
                            tmp = basis_D(i,k) * basis_D(j,l)
                            tmp = tmp * overlap_coeff_OS(   basis_L(i,1),&  ! lx for basis function i
                                                            basis_L(i,2),&  ! ly for basis function i
                                                            basis_L(i,3),&  ! lz for basis function i
                                                            basis_L(j,1),&  ! lx for basis function j
                                                            basis_L(j,2),&  ! ly for basis function j
                                                            basis_L(j,3),&  ! lz for basis function j
                                                            basis_A(i,k),&  ! Exponential coefficient for basis function i, contraction k
                                                            basis_A(j,l),&  ! Exponential coefficient for basis function j, contraction l
                                                            basis_R(i,:),&  ! Center of basis function i
                                                            basis_R(j,:))   ! Center of basis function j

                            S(i,j) = S(i,j) + tmp
                        END DO ! l
                    END DO ! k
                END DO ! j
            END DO ! i

        END SUBROUTINE S_overlap

        SUBROUTINE X_transform(Kf,SS,X)

            IMPLICIT NONE

            ! INPUT
            INTEGER, intent(in) :: Kf                       ! Basis set size
            REAl*8, dimension(Kf,Kf), intent(in) :: SS      ! Overlap matrix S

            ! INTERMEDIATE VARIABLES
            REAL*8, dimension(Kf) :: sss                    ! Temporal storage of eigenvalues
            REAL*8, dimension(Kf,Kf) :: S_sqrt              ! Inverse square root of S
            REAL*8, dimension(Kf,Kf) :: U                   ! Temporal storage of eigenvectors
            INTEGER :: i

            ! OUTPUT
            REAL*8, dimension(Kf,Kf), intent(out) :: X      ! Basi set orthogonalization matrix

            CALL EIGS(Kf,SS,U,sss)

            S_sqrt(:,:) = 0.0D0 ! Initialize U

            ! Store square of eigenvectors as a diagonal matrix in U
            DO i = 0, Kf
                S_sqrt(i,i) = (sss(i))**(-0.5D0)
            END DO

            X = MATMUL(U,S_sqrt)

        END SUBROUTINE

END MODULE OVERLAP


      PROGRAM PROG_91

C     Code from Kayode
C     *******************************************************************
C     * THIS PROGRAM CALCULATES THE YEARLY CASH FLOWS, THE CUMULATIVE   *
C     * CASH FLOWS, DISCOUNT FACTORS AT A GIVEN RATE AND PRESENT        *
C     * VALUES. THE PROGRAM FURTHER CALCULATES THE NET PRESENT VALUE,   *
C     * PRESENT VALUE RATIO, THE AVERAGE RATE OF RETURN, THE NET        *
C     * RETURN RATE, AND THE PAYBACK PERIOD.                            *
C     *******************************************************************
C     ARR    =    AVERAGE RATE OF RETURN
C     YCF    =    YEARLY CASH FLOW
C     DF     =    DISCOUNT FACTOR
C     CUCF   =    CUMULATIVE CASH FLOW
C     NPV    =    NET PRESENT VALUE
C     NOCF   =    NUMBER OF PROJECT LIFE EXCLUDING YEAR 0
C     NRR    =    NET RETURN RATE
C     PV     =    PRESENT VALUE
C     PVR    =    PRESENT VALUE RATIO
C     TIME   =    PAYBACK PERIOD
C     *******************************************************************

      REAL*8 YCF, DF, PV, NPV, CUCF
      EXTERNAL XNPV
      REAL NRR

      INTEGER TIME, TIME1

      DIMENSION YCF(0:100), DF(0:100), PV(0:100), CUCF(0:100)
C
      OPEN (UNIT = 3, FILE = 'DATA91_B.DAT', STATUS ='OLD', ERR=18)
      OPEN (UNIT = 1, FILE = 'PRN_ECO_B')
C      READ THE NUMBER OF YEARLY CASH FLOWS EXCLUDING YEAR 0: NOCF
      READ (3, *, ERR=19) NOCF
C      READ THE ANNUAL DISCOUNT RATE IN PERCENTAGE: DISC
C      READ THE YEARLY CASH FLOW: YCF
      READ (3, *, ERR=19) DISC
      READ (3, *, ERR=19) (YCF(K), K = 0, NOCF)

      GO TO 10

 18   WRITE (*, 21)
 21   FORMAT (6X,'DATA FILE DOES NOT EXIST')

      GO TO 999

 19   WRITE (*, 23)
 23   FORMAT(6X,'ERROR MESSAGE IN THE DATA VALUE')

      GO TO 999

 10   WRITE (1, 100)
 100  FORMAT (//,25X,'NET PRESENT VALUE CALCULATION',/1H, 78(1H*))

      NOCF1 = NOCF + 1

      WRITE (1, 110) NOCF1
 110  FORMAT(/,20X,I4,3X,'YEARLY CASH FLOWS INCLUDING YEAR 0')

      WRITE (1, 120) DISC
 120  FORMAT (/,20X,F8.2,3X,'PERCENTAGE ANNUAL DISCOUNT RATE ',/,
     + 1H, 78(1H-))

      WRITE (1, 130)
 130  FORMAT (//, 7X,'YEAR', 5X, 'CASH FLOWS ($)', 4X, 'CUMULATIVE',
     + 10X, 'DISCOUNT', 8X, 'PRESENT')

      WRITE (1, 140)
 140  FORMAT (34X,'CASH FLOWS ($)', 6X, 'FACTOR', 10X, 'VALUE ($)',
     + /,1H, 78(1H-))

C     CALCULATE THE CUMULATIVE CASH FLOW

      CUCF(0) = YCF(0)
      DO I = 1, NOCF
         CUCF(I) = CUCF(I-1) + YCF(I)
      END DO

      R1 = DISC/100.0
      PV(0) = YCF(0)*1.0

      DO 15 I1 = 0, 0
      IF (I1 .EQ. 0) THEN
         R1 = 0.0
         DF(I1) = 1.0/((1.0+R1)**I1)
         PV(I1) = YCF(I1)*DF(I1)
      ELSE
      ENDIF
 15   CONTINUE

      R1 = DISC/100.0

      DO 20 I1 = 1, NOCF
         DF(I1) = 1.0/((1.0+R1)**I1)
         PV(I1) = YCF(I1)*DF(I1)
 20   CONTINUE

      DO K = 0, NOCF
      WRITE (1, 150) K, YCF(K), CUCF(K), DF(K), PV(K)
 150  FORMAT (5X,I3,5X,F14.2,5X,F14.2,5X,F9.4,5X,F14.2)
      END DO

      WRITE (1, 160)
 160  FORMAT (78(1H-))

C     CALCULATE THE NET PRESENT VALUE FROM THE PRESENT VALUE

      NPV = 0.0
      DO J = 0, NOCF
      NPV = NPV + PV(J)
      END DO

      WRITE (1, 170) NPV
 170  FORMAT (1H0, 6X,'THE NET PRESENT VALUE ($):', 3X, T40, F14.2)

C     CALCULATE THE PRESENT VALUE RATIO, PVR
C     PVR = PRESENT VALUE OF ALL POSITIVE CASH FLOWS/
C     PRESENT VALUE OF ALL NEGATIVE CASH FLOWS
      SUM1 = 0.0

      DO K = 1, NOCF
      SUM1 = SUM1 + PV(K)
      END DO

      PVR = SUM1 /ABS(YCF(0))

      WRITE (1, 180) PVR
 180  FORMAT (1H0, 6X, 'PRESENT VALUE RATIO:', 3X, T40, F8.3)

C     CALCULATE THE NET RETURN RATE (NRR) i.e. THE NET PRESENT VALUE
C     DIVIDED BY THE PRODUCT OF INITIAL INVESTMENT AND THE PROJECT LIFE
C     (EXCLUDING YEAR 0).

      NRR = ABS(NPV/(ABS(PV(0))*NOCF))*100

      WRITE(1, 190) NRR
 190  FORMAT (1H0, 6X, 'THE NET RETURN RATE:', 3X, T40, F8.2, 3X, '%')

C     CALCULATE THE AVERAGE RATE OF RETURN (ARR) i.e THE AVERAGE
C     CASH FLOW DURING THE LIFE OF THE PROJECT (EXCLUDING YEAR 0).

      SUM = 0.0
      DO I = 1, NOCF
         SUM = SUM + YCF(I)
      END DO

      AVSUM = SUM/NOCF
      ARR = (AVSUM/ABS(YCF(0)))*100.0

      WRITE (1, 200) ARR
 200  FORMAT(1H0, 6X, 'THE AVERAGE RATE OF RETURN:', 3X, T40, F8.2,
     + 3X,'%')

C     CALCULATE THE PAYBACK TIME FROM THE CUMULATIVE CASH FLOW, TIME: YEARS

      DO I=0, NOCF
         IF ( CUCF(I+1) .GT. CUCF(I) .AND. CUCF(I+1) .GE. 0.0) THEN
            TEMP = CUCF(I+1)
            CUCF(I+1) = CUCF(I)
            CUCF(I) = TEMP
            TIME = I
            TIME1 = TIME + 1
            GO TO 40
         ELSE
         ENDIF
      END DO

 40   WRITE (1, 210) TIME, TIME1
 210  FORMAT (1H0,6X,'THE PAYBACK PERIOD IS BETWEEN:',
     + 3X,T45,I2,2X,'AND',2X,I2,3X,'YEARS')

C     FORM FEED THE PRINTING PAPER TO TOP OF THE NEXT PAGE.

      WRITE(1, *) CHAR(12)

      CLOSE (3, STATUS = 'KEEP')
      CLOSE (1)

 999  STOP
      END


!=================================================
! SUBROUTINE
!	BSPLINE(px,bx,ndeg)
!
!	no common
!=================================================

module func_bspline

	implicit none

contains

function b21(xx)
	implicit none
	real(8), intent(in) :: xx
	real(8) :: b21
		b21 = xx
	return
end function

function b31(xx)
	implicit none
	real(8), intent(in) :: xx
	real(8) :: b31
		b31 = xx * xx /2.d0
	return
end function

function b32(xx)
	implicit none
	real(8), intent(in) :: xx
	real(8) :: b32
		b32 = ((-2.d0 * xx +2.d0) * xx +1.d0) / 2.d0
	return
end function

function b41(xx)
	implicit none
	real(8), intent(in) :: xx
	real(8) :: b41
		b41 = xx * xx * xx / 6.d0
	return
end function

function b42(xx)
	implicit none
	real(8), intent(in) :: xx
	real(8) :: b42
		b42 = (((-3.d0 * xx + 3.d0) * xx + 3.d0) * xx + 1.d0) / 6.0d0
	return
end function

end module func_bspline

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

module mod_bspline

	implicit none

contains
!==========
subroutine BSPLINE(px,bx,ndeg)

	use func_bspline
	implicit none

	integer, intent(in) :: ndeg
	real(8), intent(in) :: px
	real(8), intent(out) :: bx(4)

	real(8) :: pr

	pr = 1.d0 - px

	if(ndeg == 0) then
		bx(1) = 1.d0
	else if(ndeg == 1) then
		bx(1) = b21(px)
		bx(2) = b21(pr)
	else if(ndeg == 2) then
		bx(1) = b31(px)
		bx(2) = b32(px)
		bx(3) = b31(pr)
	else if(ndeg == 3) then
		bx(1) = b41(px)
		bx(2) = b42(px)
		bx(3) = b42(pr)
		bx(4) = b41(pr)
	end if

return
end subroutine BSPLINE

end module mod_bspline


MODULE mod_thermodynamics

    USE mod_constants

    IMPLICIT NONE

CONTAINS

    ELEMENTAL FUNCTION specific_energy(P, rho) RESULT(e)

        IMPLICIT NONE

        REAL(dp_kind), INTENT(IN) :: P, rho
        REAL(dp_kind) :: e

        e = P / ((gamma - 1) * rho)

    END FUNCTION specific_energy

    ELEMENTAL FUNCTION pressure(e, rho) RESULT(P)

        IMPLICIT NONE

        REAL(dp_kind), INTENT(IN)  :: e, rho
        REAL(dp_kind) :: P

        P = (gamma - 1) * rho * e

    END FUNCTION pressure

    ELEMENTAL FUNCTION sound_speed(e, rho) RESULT(c)

        IMPLICIT NONE

        REAL(dp_kind), INTENT(IN) :: e
        REAL(dp_kind), INTENT(IN), OPTIONAL :: rho
        REAL(dp_kind) :: c

        c = SQRT(gamma * (gamma - 1) * e)

    END FUNCTION sound_speed

    FUNCTION pressure_RAR(P_, v_, v,  dP_dv) RESULT(P)

        IMPLICIT NONE

        REAL(dp_kind), INTENT(IN) :: P_, v_, v
        REAL(dp_kind), INTENT(OUT), OPTIONAL :: dP_dv
        REAL(dp_kind) :: P

        P = P_ * (v_ / v)**gamma

        IF (PRESENT(dP_dv)) dP_dv = - gamma * P/v

    END FUNCTION pressure_RAR

    FUNCTION integral_c_v_isentropic(P_, v_, v) RESULT(integ)

        ! calcolo di int_{v_}^v c(s_, v)/v dv

        IMPLICIT NONE

        REAL(dp_kind), INTENT(IN) :: P_, v_, v
        REAL(dp_kind) :: integ

        integ =  (2*SQRT(gamma*P_*v_)/(gamma-1)) * (1 - (v_/v)**((gamma-1)/2))

    END FUNCTION integral_c_v_isentropic

    FUNCTION sound_speed_isentropic(P_, v_, v) RESULT(c_isent)

        IMPLICIT NONE

        REAL(dp_kind), INTENT(IN) :: P_, v_, v
        REAL(dp_kind) :: c_isent

        c_isent = SQRT(gamma*P_*v_) * (v_/v)**((gamma-1)/2)

    END FUNCTION sound_speed_isentropic

    FUNCTION pressure_RH(P_, v_, v,  dP_dv) RESULT(P)

        IMPLICIT NONE

        REAL(dp_kind), INTENT(IN) :: P_, v_, v
        REAL(dp_kind), INTENT(OUT), OPTIONAL :: dP_dv
        REAL(dp_kind) :: P

        REAL(dp_kind) :: NUM, DEN

        ! Controllo che v non sia inferiore all'asintoto (Vedi testo)

        NUM = (gamma + 1) * v_  -  (gamma - 1) * v
        DEN = (gamma + 1) * v   -  (gamma - 1) * v_

        P = P_ * NUM/DEN

        IF (PRESENT(dP_dv)) dP_dv = -4 * gamma * P_ * v_/DEN**2

    END FUNCTION pressure_RH

END MODULE mod_thermodynamics


subroutine median(xin,n,xmed)

! Find the median of X(1), ... , X(N), using as much of the quicksort
! algorithm as is needed to isolate it.

!     Latest revision - 26 November 1996
implicit none

integer :: n
double precision :: xin(n),x(n),xmed

! Local variables

integer          :: hi, lo, nby2, nby2p1, mid, i, j, k
double precision :: temp, xhi, xlo, xmax, xmin
logical          :: odd

x = xin

nby2 = n / 2
nby2p1 = nby2 + 1
odd = .true.

!     HI & LO are position limits encompassing the median.

if (n == 2 * nby2) odd = .false.
lo = 1
hi = n
if (n < 3) then
  if (n < 1) then
    xmed = 0.d0
    return
  end if
  xmed = x(1)
  if (n == 1) return
  xmed = 0.d5*(xmed + x(2))
  return
end if

!     Find median of 1st, middle & last values.

10 mid = (lo + hi)/2
xmed = x(mid)
xlo = x(lo)
xhi = x(hi)
if (xhi < xlo) then          ! Swap xhi & xlo
  temp = xhi
  xhi = xlo
  xlo = temp
end if
if (xmed > xhi) then
  xmed = xhi
else if (xmed < xlo) then
  xmed = xlo
end if

! The basic quicksort algorithm to move all values <= the sort key (XMED)
! to the left-hand end, and all higher values to the other end.

i = lo
j = hi
50 do
  if (x(i) >= xmed) exit
  i = i + 1
end do
do
  if (x(j) <= xmed) exit
  j = j - 1
end do
if (i < j) then
  temp = x(i)
  x(i) = x(j)
  x(j) = temp
  i = i + 1
  j = j - 1

!     Decide which half the median is in.

  if (i <= j) go to 50
end if

if (.not. odd) then
  if (j == nby2 .and. i == nby2p1) go to 130
  if (j < nby2) lo = i
  if (i > nby2p1) hi = j
  if (i /= j) go to 100
  if (i == nby2) lo = nby2
  if (j == nby2p1) hi = nby2p1
else
  if (j < nby2p1) lo = i
  if (i > nby2p1) hi = j
  if (i /= j) go to 100

! Test whether median has been isolated.

  if (i == nby2p1) return
end if
100 if (lo < hi - 1) go to 10

if (.not. odd) then
  xmed = 0.5d0*(x(nby2) + x(nby2p1))
  return
end if
temp = x(lo)
if (temp > x(hi)) then
  x(lo) = x(hi)
  x(hi) = temp
end if
xmed = x(nby2p1)
return

! Special case, N even, J = N/2 & I = J + 1, so the median is
! between the two halves of the series.   Find max. of the first
! half & min. of the second half, then average.

130 xmax = x(1)
do k = lo, j
  xmax = max(xmax, x(k))
end do
xmin = x(n)
do k = i, hi
  xmin = min(xmin, x(k))
end do
xmed = 0.5d0*(xmin + xmax)

end subroutine median


MODULE MathKernel

!=======================================================================================
! Common Math Operation Collections
! Includes:
!       Det : Detting determinant of a matrix
!       InvMat : General purpose matrix inversion
!       InvMat3 : Matrix inversion for 3x3 Matrix
!       InvMat2 : Matrix inversion for 2x2 Matrix
!       Cross : Vector cross product
!       IsPlanar : Judging if 4 points are on the same plane
!       GaussianMask : Generating gaussian points and weights for caritsian coordinates
!       AxialRotate : Rotate a group of points along a given axis for given angle
!       LeastSquare : Return the least-square coefficients for a given series of data
!
! Author: Haoguang Yang
!
!=======================================================================================

    implicit none

CONTAINS

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!   Function to find the determinant of a square matrix   !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
REAL(8) FUNCTION Det(matrix, n)
!Description: The subroutine is based on two key points:
!1] A determinant is unaltered when row operations are performed: Hence, using this principle,
!row operations (column operations would work as well) are used
!to convert the matrix into upper traingular form
!2]The determinant of a triangular matrix is obtained by finding the product of the diagonal elements
    IMPLICIT NONE
    REAL(8), DIMENSION(n,n) :: matrix
    INTEGER, INTENT(IN) :: n
    REAL(8) :: m, temp
    INTEGER :: i, j, k, l
    LOGICAL :: DetExists = .TRUE.

    select case (n)
    case (2)
        Det = matrix(1,1)*matrix(2,2)-matrix(1,2)*matrix(2,1)
    case (3)
        Det = matrix(1,1)*matrix(2,2)*matrix(3,3)+ &
              matrix(1,2)*matrix(2,3)*matrix(3,1)+ &
              matrix(1,3)*matrix(2,1)*matrix(3,2)- &
              matrix(1,1)*matrix(2,3)*matrix(3,2)- &
              matrix(1,2)*matrix(2,1)*matrix(3,3)- &
              matrix(1,3)*matrix(2,2)*matrix(3,1)
    case (4:)
        l = 1
        !Convert to upper triangular form
        DO k = 1, n-1
            IF (matrix(k,k) == 0) THEN
                DetExists = .FALSE.
                DO i = k+1, n
                    IF (matrix(i,k) /= 0) THEN
                        DO j = 1, n
                            temp = matrix(i,j)
                            matrix(i,j)= matrix(k,j)
                            matrix(k,j) = temp
                        END DO
                        DetExists = .TRUE.
                        l=-l
                        EXIT
                    ENDIF
                END DO
                IF (DetExists .EQV. .FALSE.) THEN
                    Det = 0
                    return
                END IF
            ENDIF
            DO j = k+1, n
                m = matrix(j,k)/matrix(k,k)
                DO i = k+1, n
                    matrix(j,i) = matrix(j,i) - m*matrix(k,i)
                END DO
            END DO
        END DO
        !Calculate determinant by finding product of diagonal elements
        Det = l
        DO i = 1, n
            Det = Det * matrix(i,i)
        END DO
    END select
END FUNCTION Det

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!     Functions To Calculate The Inverse Of A Small Matrix     !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!2x2
SUBROUTINE InvMat2 (A, AINV, OK_FLAG)

      IMPLICIT NONE

      DOUBLE PRECISION, DIMENSION(2,2), INTENT(IN)  :: A
      DOUBLE PRECISION, DIMENSION(2,2), INTENT(OUT) :: AINV
      LOGICAL, INTENT(OUT) :: OK_FLAG

      DOUBLE PRECISION, PARAMETER :: EPS = 1.0D-10
      DOUBLE PRECISION :: DET
      DOUBLE PRECISION, DIMENSION(2,2) :: COFACTOR

      DET =   A(1,1)*A(2,2) - A(1,2)*A(2,1)

      IF (ABS(DET) .LE. EPS) THEN
         AINV = 0.0D0
         OK_FLAG = .FALSE.
         RETURN
      END IF

      COFACTOR(1,1) = +A(2,2)
      COFACTOR(1,2) = -A(2,1)
      COFACTOR(2,1) = -A(1,2)
      COFACTOR(2,2) = +A(1,1)

      AINV = TRANSPOSE(COFACTOR) / DET

      OK_FLAG = .TRUE.

      RETURN

END SUBROUTINE InvMat2

!3x3
SUBROUTINE InvMat3 (A, AINV, OK_FLAG)

      IMPLICIT NONE

      DOUBLE PRECISION, DIMENSION(3,3), INTENT(IN)  :: A
      DOUBLE PRECISION, DIMENSION(3,3), INTENT(OUT) :: AINV
      LOGICAL, INTENT(OUT) :: OK_FLAG

      DOUBLE PRECISION, PARAMETER :: EPS = 1.0D-10
      DOUBLE PRECISION :: DET
      DOUBLE PRECISION, DIMENSION(3,3) :: COFACTOR

      DET =   A(1,1)*A(2,2)*A(3,3)  &
            - A(1,1)*A(2,3)*A(3,2)  &
            - A(1,2)*A(2,1)*A(3,3)  &
            + A(1,2)*A(2,3)*A(3,1)  &
            + A(1,3)*A(2,1)*A(3,2)  &
            - A(1,3)*A(2,2)*A(3,1)

      IF (ABS(DET) .LE. EPS) THEN
         AINV = 0.0D0
         OK_FLAG = .FALSE.
         RETURN
      END IF

      COFACTOR(1,1) = +(A(2,2)*A(3,3)-A(2,3)*A(3,2))
      COFACTOR(1,2) = -(A(2,1)*A(3,3)-A(2,3)*A(3,1))
      COFACTOR(1,3) = +(A(2,1)*A(3,2)-A(2,2)*A(3,1))
      COFACTOR(2,1) = -(A(1,2)*A(3,3)-A(1,3)*A(3,2))
      COFACTOR(2,2) = +(A(1,1)*A(3,3)-A(1,3)*A(3,1))
      COFACTOR(2,3) = -(A(1,1)*A(3,2)-A(1,2)*A(3,1))
      COFACTOR(3,1) = +(A(1,2)*A(2,3)-A(1,3)*A(2,2))
      COFACTOR(3,2) = -(A(1,1)*A(2,3)-A(1,3)*A(2,1))
      COFACTOR(3,3) = +(A(1,1)*A(2,2)-A(1,2)*A(2,1))

      AINV = TRANSPOSE(COFACTOR) / DET

      OK_FLAG = .TRUE.

      RETURN

END SUBROUTINE InvMat3

!General inverse
subroutine InvMat(MatIn,MatOut,n)
!============================================================
! Inverse matrix
! Method: Based on Doolittle LU factorization for Ax=b
!-----------------------------------------------------------
! input ...
! a(n,n) - array of coefficients for matrix A
! n      - dimension
! output ...
! c(n,n) - inverse matrix of A
! comments ...
! the original matrix a(n,n) will be destroyed
! during the calculation
!===========================================================
implicit none
integer n
double precision MatIn(n,n), MatOut(n,n)
double precision L(n,n), U(n,n), b(n), d(n), x(n)
double precision coeff
integer i, j, k

! step 0: initialization for matrices L and U and b
! Fortran 90/95 aloows such operations on matrices
L=0.0
U=0.0
b=0.0

! step 1: forward elimination
do k=1, n-1
   do i=k+1,n
      coeff=MatIn(i,k)/MatIn(k,k)
      L(i,k) = coeff
      do j=k+1,n
         MatIn(i,j) = MatIn(i,j)-coeff*MatIn(k,j)
      end do
   end do
end do

! Step 2: prepare L and U matrices
! L matrix is a matrix of the elimination coefficient
! + the diagonal elements are 1.0
do i=1,n
  L(i,i) = 1.0
end do
! U matrix is the upper triangular part of A
do j=1,n
  do i=1,j
    U(i,j) = MatIn(i,j)
  end do
end do

! Step 3: compute columns of the inverse matrix C
do k=1,n
  b(k)=1.0
  d(1) = b(1)
! Step 3a: Solve Ld=b using the forward substitution
  do i=2,n
    d(i)=b(i)
    do j=1,i-1
      d(i) = d(i) - L(i,j)*d(j)
    end do
  end do
! Step 3b: Solve Ux=d using the back substitution
  x(n)=d(n)/U(n,n)
  do i = n-1,1,-1
    x(i) = d(i)
    do j=n,i+1,-1
      x(i)=x(i)-U(i,j)*x(j)
    end do
    x(i) = x(i)/u(i,i)
  end do
! Step 3c: fill the solutions x(n) into column k of C
  do i=1,n
    MatOut(i,k) = x(i)
  end do
  b(k)=0.0
end do
end subroutine InvMat

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!      Function calculating cross product of 3D vectors        !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
FUNCTION cross(a, b)
  implicit none
  real(8), DIMENSION(3) :: cross
  real(8), DIMENSION(3), INTENT(IN) :: a, b

  cross(1) = a(2) * b(3) - a(3) * b(2)
  cross(2) = a(3) * b(1) - a(1) * b(3)
  cross(3) = a(1) * b(2) - a(2) * b(1)
END FUNCTION cross

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!    Subroutine Judging if four points are in the same place   !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine IsPlanar(Judge, NormalVec, NPoints, PositionData)
    implicit none
    integer ::  NPoints
    real(8) ::  PositionData(NPoints*3), NormalVec(3), V(3,3), Criteria
    logical ::  Judge

    Judge = .False.
    if (NPoints == 4) then
        V=reshape((/PositionData(4:11:3)-PositionData(1)*(/1,1,1/), &
            PositionData(5:12:3)-PositionData(2)*(/1,1,1/), &
            PositionData(6:13:3)-PositionData(3)*(/1,1,1/)/),shape(V))              !problematic expression
        NormalVec = cross(V(2,:),V(3,:)-V(1,:))
        Criteria  = dot_product(NormalVec,V(1,:))

        if (abs(Criteria) .LT. 1.0D-10) then
            Judge = .True.
            return
        endif
    endif
end subroutine IsPlanar

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!    Function Returning Weight Masks for Gaussian Quadrature    !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine GaussianMask (GaussianPoints, Weights, QuadratureOrder)
    implicit none
    !integer ::  EdgesPerNode, NumberOfEdges
    integer ::  QuadratureOrder
    real(8) ::  GaussianPoints (QuadratureOrder), Weights(QuadratureOrder)

    select case (QuadratureOrder)
    case (1)
        GaussianPoints=0.
        Weights=2.
    case (2)
        GaussianPoints=(/1./sqrt(3.), -1./sqrt(3.)/)
        Weights=(/1.,1./)
    case (3)
        GaussianPoints=(/sqrt(3./5.), 0., -sqrt(3./5.)/)
        Weights=(/5./9., 8./9., 5./9./)
    !case (4)
    !Other Higher Orders

    end select
end subroutine GaussianMask

!subroutine GaussianMaskSimplex (GaussianPts, Weights, QuadratureOrder)
!    implicit none
!    integer ::  QuadratureOrder
!    real(8) ::  GaussianPts(npg)

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!  Subroutine performing spacial rotations along a given axis   !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine AxialRotate(PtIn, PtOut, Axis, Theta)
	implicit none
	real(8) :: PtIn(3), PtOut(3), Axis(3), Theta
	real(8) :: C, S, R(3,3)

	C = cos(Theta)
	S = sin(Theta)
	Axis = Axis/sqrt(dot_product(Axis, Axis))
	R = reshape((/Axis(1)**2+(1-Axis(1)**2)*C, Axis(1)*Axis(2)*(1-C)-Axis(3)*S, Axis(1)*Axis(3)*(1-C)+Axis(2)*S, &
				  Axis(1)*Axis(2)*(1-C)+Axis(3)*S, Axis(2)**2+(1-Axis(2)**2)*C, Axis(2)*Axis(3)*(1-C)-Axis(1)*S, &
				  Axis(1)*Axis(3)*(1-C)-Axis(2)*S, Axis(2)*Axis(3)*(1-C)+Axis(1)*S, Axis(3)**2+(1-Axis(3)**2)*C/),(/3,3/))
	PtOut = matmul(R,PtIn)
end subroutine AxialRotate

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!              Perform least-square approoximation              !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine LeastSquare (coeff, value, Ncoeff, Nval, sets)
    implicit none
    integer ::  Ncoeff, Nval, sets, i
    real(8) ::  coeff (Ncoeff, sets), value (Nval, Ncoeff+sets)
    real(8) ::  ATA (Ncoeff, Ncoeff), ATY (Ncoeff)

    ATA = matmul(transpose(value(:,1:Ncoeff)),value(:,1:Ncoeff))        !May waste a lot of calcullatons here...
    call InvMat(ATA, ATA, Ncoeff)

    do i = 1,sets
        ATY = matmul(transpose(value(:,1:Ncoeff)),value(:,Ncoeff+i))
        coeff(:,i) = matmul(ATA,ATY)
    end do

end subroutine LeastSquare
    END MODULE MathKernel

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!                Calculate Stiffness Matrix                !!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine GetDMat (Young, Poisson, DMatrix)
    implicit none
    real(8),dimension(6,6)  ::  DMatrix
    real(8), intent(in)     ::  Young, Poisson
    real(8)                 ::  G, lambda
    integer                 ::  i

    DMatrix(:,:) = 0
    G = Young/(2*(1+Poisson))
    lambda = Poisson*Young/(1+Poisson)/(1-2*Poisson)
    DMatrix(1:3,1:3) = lambda
    do i = 1,6
        DMatrix(i,i) = DMatrix(i,i) + 2*G
    end do
    return
end subroutine GetDMat


PROGRAM decibels
IMPLICIT NONE
  REAL :: ratio ! In decibels
  REAL :: power_level, reference = 1.0 ! Power levels in mW
  WRITE(*, *) "Enter a power level in mW"
  READ(*, *) power_level
  ratio = 10 * LOG(power_level / reference) / LOG(10.0)
  WRITE(*, *) power_level, " mW against ", reference, " mW reference is ", ratio, " decibels"

END PROGRAM decibels


program FD
    implicit none

!   Sun 15 Apr 2018 12:44:36
!
!   Compile with: "gfortran FD.f95 -o FD"
!   Run with: "./FD"

    integer, dimension(:),allocatable :: a_seed
    integer :: i_seed
    integer, dimension(1:8) :: dt_seed

    real :: pi, x1, x2, z1, z2, ds, s, dw, t
    integer, parameter :: num_trading_days = 250, s_0 = 100
    real, parameter :: drift = 0.16, r = 0.04, k = 0.2!, volatility = 0.2
!   Change volatility from 0.2 to 0.6 for section 2 (g)
    real, parameter :: dt = 1.0/float(num_trading_days)
    real, dimension(:,:), allocatable :: portfolio_value
    integer, dimension(4) :: indx = [1, 2, 5, 20]
    real, dimension(2) :: volatility_array = [0.2, 0.6]
    real, dimension(:), allocatable :: prob_loss
    integer :: num_years, itter_per_simulation, i, j, h, l, m, f, q
    real :: mean, variance, volatility

    pi = acos(-1.0)

!   Question 2. (b)
    call random_seed(size=i_seed)
    allocate(a_seed(1:i_seed))
    call random_seed(get=a_seed)
    call date_and_time(values=dt_seed)
    a_seed(i_seed)=dt_seed(8); a_seed(1)=dt_seed(8)*dt_seed(7)*dt_seed(6)
    call random_seed(put=a_seed)
    deallocate(a_seed)

!   Question 2. (c)
    s = float(s_0)
    t = 0.0
    open(10 , file = "s_price_1yr.dat")
        do i = 1, num_trading_days
            call random_number(x1)
            call random_number(x2)
!           write(6,*) "The random number x1 is: ", x1
!           write(6,*) "The random number x2 is: ", x2
            z1 = sqrt(-2.0*log(x1))*cos(2.0*pi*x2)
            z2 = sqrt(-2.0*log(x2))*sin(2.0*pi*x2)
!           write(6,*) "The value of z1 is: ", z1
!           write(6,*) "The value of z2 is: ", z2

!           Question 2. (c)
            dw = sqrt(dt)*z1
            ds = s*(drift*dt + volatility_array(1)*dw )
            s = s + ds
            write(10,*) s , t
            t = t+dt
        end do
    close(10)

!   Question 2. (d)

    open(11, file = "portfolio_value_1yr.dat")
    open(12, file = "portfolio_value_2yr.dat")
    open(13, file = "portfolio_value_5yr.dat")
    open(14, file = "portfolio_value_20yr.dat")
        do q=1,size(volatility_array)
            volatility = volatility_array(q)
            do i=1,size(indx)
                num_years = indx(i)
                itter_per_simulation = num_trading_days*num_years
!                write(6,*) itter_per_simulation
                allocate(portfolio_value(itter_per_simulation,1000))
                m = 0
                portfolio_value(:,:) = 0.0
                allocate(prob_loss(itter_per_simulation))
                prob_loss = 0
                do j = 1, 1000
                    s = float(s_0)
                    t = 0.0
                    do h = 1, itter_per_simulation

                        call random_number(x1)
                        call random_number(x2)

                        z1 = sqrt(-2.0*log(x1))*cos(2.0*pi*x2)
                        z2 = sqrt(-2.0*log(x2))*sin(2.0*pi*x2)

                        dw = sqrt(dt)*z1
                        ds = s*(drift*dt + volatility*dw )
                        s = s + ds
                        t = t+dt

                        portfolio_value(h,j) = s*exp(-r*t)-s_0

                        if (s .ge. (s_0*(1.0+k)*exp(r*t))) then
                            portfolio_value(h,j) = s_0*k
                            exit
                        end if

                        if (volatility .eq. 0.2) then
                            if (num_years .eq. 1) then
                                write(11,*) portfolio_value(h,j), t
                            else if (num_years .eq. 2) then
                                write(12,*) portfolio_value(h,j), t
                            else if (num_years .eq. 5) then
                                write(13,*) portfolio_value(h,j), t
                            else if (num_years .eq. 20) then
                                write(14,*) portfolio_value(h,j), t
                            end if
                        end if

                        if (portfolio_value(h,j) .le. 0) then
                            prob_loss(h) = (prob_loss(h) + 1)
                        end if
                    end do

                    do l = 1 , int(itter_per_simulation-h)
                        t = t+dt
                        f = h + l
                        portfolio_value(f,j) = s_0*k
                        if (volatility .eq. 0.2) then
                            if (num_years .eq. 1) then
                                write(11,*) portfolio_value(f,j), t
                            else if (num_years .eq. 2) then
                                write(12,*) portfolio_value(f,j), t
                            else if (num_years .eq. 5) then
                                write(13,*) portfolio_value(f,j), t
                            else if (num_years .eq. 20) then
                                write(14,*) portfolio_value(f,j), t
                            end if
                        end if
!                       p = p + 1
                    end do

                end do

!            prob_loss = prob_loss(h)/1000

                if (indx(i) .eq. 20) then
                    t = 0.0
                    open(15, file = "statistics.dat")
                    open(16, file = "prob_loss.dat")
                    open(17, file = "prob_loss_06.dat")
                    open(18, file = "statistics_06.dat")
                        do h = 1, itter_per_simulation
                            t = t+dt
                            if (volatility .eq. 0.2) then
                                write(16,*) prob_loss(h)/1000, t
                            else if (volatility .eq. 0.6) then
                                write(17,*) prob_loss(h)/1000, t
                            end if
                            mean = sum(portfolio_value(h,:))/1000
                            !WORK OUT HOW VARIANCE CHANGES OVER PORTFOLIO TIMEFRAME
                            variance = 0.0
                            do j = 1, 1000
                                variance=variance+(portfolio_value(h,j)-mean)**2.0
                            end do
                            variance = variance/real(j-1)
                            if (volatility .eq. 0.2) then
                                write(15,*) mean, variance, t
                            else if (volatility .eq. 0.6) then
                                write(18,*) mean, variance, t
                            end if
                        end do
                    close(15)
                    close(16)
                    close(17)
                    close(18)
                end if
!               write(6,*) "m_count", m
                deallocate (portfolio_value)
                deallocate(prob_loss)
            end do
        end do
    close(11)
    close(12)
    close(13)
    close(14)
end program FD


SUBROUTINE eta_linear_3D_standing(H,angle,Lx,Ly,xc,yc,omega,time,eta,etax,etay,etaxx,etayy,etat)
!
! By Allan P. Engsig-Karup.
USE Precision
USE Constants
IMPLICIT NONE
REAL(KIND=long), INTENT(IN)  :: H,Lx,Ly,xc,yc,omega,time
REAL(KIND=long), INTENT(OUT) :: eta,etax,etay
REAL(KIND=long), INTENT(OUT) :: etaxx,etayy,etat
! REAL(KIND=long), OPTIONAL :: y,etay,etayy !Boundary fitted ?
! Local variables
REAL(KIND=long) :: kx, ky, half_H, k_omegat, sink_omegat
!
REAL(KIND=long) :: HH,k,w,angle,tmp,x,y
!
x = xc*COS(-angle)-yc*SIN(-angle)
y = xc*SIN(-angle)+yc*COS(-angle)
!
kx    = two*pi/Lx; ky = two*pi/Ly
k = SQRT(kx**2+ky**2)
w = omega
HH = H
!
eta   =  half*HH*COS(w*time)*COS(kx*X)*COS(ky*Y)
etax  = -kx*half*HH*COS(w*time)*SIN(kx*X)*COS(ky*Y)
etaxx = -kx**2*half*HH*COS(w*time)*COS(kx*X)*COS(ky*Y)
etay  = -ky*half*HH*COS(w*time)*SIN(kx*X)*COS(ky*Y)
etayy = -ky**2*half*HH*COS(w*time)*COS(kx*X)*COS(ky*Y)
etat  = -half*w*HH*SIN(w*time)*COS(kx*X)*COS(ky*Y)
!
tmp = etax
etax = tmp*COS(angle)-etay*SIN(angle)
etay = tmp*SIN(angle)+etay*COS(angle)
!
tmp = etaxx
etaxx = tmp*COS(angle)-etayy*SIN(angle)
etayy = tmp*SIN(angle)+etayy*COS(angle)
!
!xc = x*COS(angle)-y*SIN(angle)
!yc = x*SIN(angle)+y*COS(angle)

END SUBROUTINE eta_linear_3D_standing


Subroutine Parab_interp(n, x, y, nn, xx, yy)
! This routine interpolates a vector x,y to another vector xx,yy
! Note: It doesn't check that xx is within x
!
  Implicit None
  Integer :: n, nn
  Real, dimension(n) :: x, y
  Real, dimension(3) :: x3, y3
  Real, dimension(nn) :: xx, yy
  Integer, dimension(1) :: imin1
  Integer :: ii, i1, i3
  Real :: pend
!
  If (n .eq. 1) then ! 1-point (absurd)
     yy=y
  Else if (n .eq. 2) then ! 2-point (linear interpolation)
     pend=(y(2)-y(1))/(x(2)-x(1))
     yy(1:nn)=pend*(xx(1:nn)-x(1)) + y(1)
  Else if (n .eq. 3) then ! 3-point (parabolic interpolation)
     Call ThreePt_Parab_interp(nn, x, y, xx, yy)
  Else ! More than 3 points (parabolic)
     Do ii=1, nn
        imin1=MinLoc(Abs( xx(ii)-x(:) ))
        i1=imin1(1)-1
        i3=imin1(1)+1
        If (i1 .le. 0) then
           i1=1
           i3=3
        Else if (i3 .gt. n) then
           i1=n-2
           i3=n
        End if
        x3(1:3)=x(i1:i3)
        y3(1:3)=y(i1:i3)
        Call ThreePt_parab_interp(1, x3, y3, xx(ii), yy(ii))
     End do
  End if
  Return
End Subroutine Parab_interp
! This routine performs a parabolic interpolation of the parabola that
! passes through 3 points x,y to a vector xx,yy
!
Subroutine ThreePt_Parab_interp(nn, x, y, xx, yy)
  Implicit None
  Integer :: nn
  Real, dimension (3) :: x, y
  Real, dimension (nn) :: xx, yy
  Real :: den, a, b, c, x1, x2, x3, y1, y2, y3
!
  x1=x(1)
  x2=x(2)
  x3=x(3)
  y1=y(1)
  y2=y(2)
  y3=y(3)
  den = (x1 - x2)*(x1 - x3)*(x2 - x3)
  a = (x3*(y2-y1)+x2*(y1-y3)+x1*(y3-y2))/den
  b = (x3*x3*(y1-y2)+x1*x1*(y2-y3)+x2*x2*(y3-y1))/den
  c = (x1*x3*y2*(x3-x1)+x2*x2*(x3*y1-x1*y3)+ &
       x2*(x1*x1*y3-x3*x3*y1))/den
  yy = a*xx*xx + b*xx + c
  Return
End Subroutine ThreePt_Parab_interp


! $UWHPSC/codes/adaptive_quadrature/openmp2/functions_mod.f90

module functions_mod

    ! Define the function we want to integrate.
    ! Also define the indefinite integral (anti-derivative) of g for
    ! use in computing the true solution to compute the error.

    ! The counter gcounter can be initialized to 0 in the main program
    ! and then will count how many times the function g is called.

    implicit none
    integer :: gcounter
    real(kind=8), parameter :: beta = 10.d0
    save

contains

real(kind=8) function g(x)
    ! Test function to integrate
    implicit none
    real(kind=8), intent(in) :: x
    g = exp(-beta**2 * x**2) + sin(x)
    gcounter = gcounter + 1
end function g

real(kind=8) function gint(x)
    ! Anti-derivative of g
    implicit none
    real(kind=8), parameter :: pi = 3.141592653589793d0
    real(kind=8), intent(in) :: x
    gint = sqrt(pi)/(2.d0*beta) * erf(beta*x) - cos(x)
end function gint

end module functions_mod


!
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!     *                                                               *
!     *                  copyright (c) 1998 by UCAR                   *
!     *                                                               *
!     *       University Corporation for Atmospheric Research         *
!     *                                                               *
!     *                      all rights reserved                      *
!     *                                                               *
!     *                          Spherepack                           *
!     *                                                               *
!     *       A Package of Fortran77 Subroutines and Programs         *
!     *                                                               *
!     *              for Modeling Geophysical Processes               *
!     *                                                               *
!     *                             by                                *
!     *                                                               *
!     *                  John Adams and Paul Swarztrauber             *
!     *                                                               *
!     *                             of                                *
!     *                                                               *
!     *         the National Center for Atmospheric Research          *
!     *                                                               *
!     *                Boulder, Colorado  (80307)  U.S.A.             *
!     *                                                               *
!     *                   which is sponsored by                       *
!     *                                                               *
!     *              the National Science Foundation                  *
!     *                                                               *
!     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
!
!     Contains a test program for subroutine trssph
!
! ... author
!
!     John C Adams (1996, NCAR)
!
!     Subroutine trssph is used to demonstrate data transfer between a coarse
!     ten degree equally spaced grid and a higher resolution T64 Global Spectral
!     Gaussian grid.  The equally spaced data is stored in a 19 X 36 colatitude-
!     longitude array data_reg which runs north to south with increasing subscript
!     values.  The Gaussian grid data is stored in a 192 X 94 longitude-latitude
!     array data_gau which runs south to north with increasing latitude subscript.
!     First trssph is used to transfer data_reg to data_gau.  Then trssph is used to
!     transfer data_gau back to data_reg.
!
!     For testing purposes, data_reg is set equal the analytic function
!
!                       x*y*z
!           f(x, y, z) = e
!
!     in Cartesian coordinates x, y, z restricted to the surface of the sphere.
!     The same function is used to compute error in data_gau after the data transfer
!     with trssph.  Finally this is used to compute error in data_reg after the transfer
!     back with trssph.  Output from executing the test program on machines with
!     32 bit and 64 bit arithmetic is listed below.  The minimum required saved
!     and unsaved workspace lengths were predetermined by an earlier call to
!     trssph with nlon_reg=36, nlat_reg=19, nlon_gau=192, nlat_gau=94, lsave=1, lwork=1 and printout
!     of lsvmin and lwkmin.
!
!
! **********************************************************************
!
!     OUTPUT FROM EXECUTING CODE IN THIS FILE
!
! **********************************************************************
!
!     EQUALLY SPACED TO GAUSSIAN GRID TRANSFER
!
!     trssph input parameters:
!     intl =  0
!     igrid_reg(1) = -1   igrid_reg(2) =  1
!     nlon_reg =  36   nlat_reg =  19
!     igrid_gau(1) =  2   igrid_gau(2) =  0
!     nlon_gau = 194   nlat_gau =  92
!     lsave =   22213  lwork =   53347
!
!     trssph output:
!     ier =  0  lsvmin =   22213  lwkmin =   53347
!     *** 32 BIT ARITHMETIC
!     least squares error =  0.201E-06
!     *** 64 BIT ARITHMETIC
!     least squares error =  0.763E-11
!
!
!     GAUSSIAN TO EQUALLY SPACED GRID TRANSFER
!
!     trssph input parameters:
!     intl =  0
!     igrid_gau(1) =  2   igrid_gau(2) =  0
!     nlon_gau = 194   nlat_gau =  92
!     igrid_reg(1) = -1   igrid_reg(2) =  1
!     nlon_reg =  36   nlat_reg =  19
!     lsave =   22213  lwork =   53347
!
!     trssph output:
!     ier =  0  lsvmin =   22213  lwkmin =   53347
!     *** 32 BIT ARITHMETIC
!     least squares error =  0.618E-06
!     *** 64 BIT ARITHMETIC
!     least squares error =  0.547E-11
!
! **********************************************************************
!
!     END OF OUTPUT ... CODE FOLLOWS
!
! **********************************************************************
!
program test_trssph

    use, intrinsic :: ISO_Fortran_env, only: &
        stdout => OUTPUT_UNIT

    use spherepack

    ! Explicit typing only
    implicit none

    !Set grid sizes with parameter statements
    integer(ip), parameter :: NLAT_GAU = 92, NLON_GAU = 194
    integer(ip), parameter :: NLAT_REG = 19, NLON_REG = 36
    real(wp) :: data_reg(NLAT_REG, NLON_REG), data_gau(NLON_GAU, NLAT_GAU)
    real(wp), dimension(NLAT_GAU) :: colatitudes, gaussian_latitudes, gaussian_weights
    integer(ip) :: igrid_reg(2), igrid_gau(2)
    real(wp)    :: dlat_reg, dlon_reg, dlon_gau
    real(wp)    :: cosp, sinp, cost, sint, xyz, err2, theta, phi, dif
    integer(ip) :: i, j, intl, error_flag

    ! Set equally spaced grid increments
    dlat_reg = PI/(NLAT_REG-1)
    dlon_reg = TWO_PI/NLON_REG
    dlon_gau = TWO_PI/NLON_GAU

    ! Set given data in data_reg from f(x, y, z)= exp(x*y*z) restricted
    ! to nlat_reg by nlon_reg equally spaced grid on the sphere
    do  j=1, NLON_REG
        phi = real(j-1, kind=wp)*dlon_reg
        cosp = cos(phi)
        sinp = sin(phi)
        do i=1, NLAT_REG
            ! Set north to south oriented colatitude point
            theta = real(i-1, kind=wp)*dlat_reg
            cost = cos(theta)
            sint = sin(theta)
            xyz = (sint*(sint*cost*sinp*cosp))
            data_reg(i, j) = exp(xyz)
        end do
    end do

    ! Set initial call flag
    intl = 0

    ! Flag data_reg grid as north to south equally spaced
    igrid_reg(1) = -1

    ! Flag data_reg grid as colatitude by longitude
    igrid_reg(2) = 1

    ! Flag data_gau grid as south to north Gaussian
    igrid_gau(1) = 2

    ! Flag data_gau grid as longitude by latitude
    igrid_gau(2) = 0

    ! Print trssph input parameters
    write (stdout, 100) intl, igrid_reg(1), igrid_reg(2), NLON_REG, NLAT_REG, &
        igrid_gau(1), igrid_gau(2), NLON_GAU, NLAT_GAU
100 format(//' EQUALLY SPACED TO GAUSSIAN GRID TRANSFER ' , &
        /' trssph input arguments: ' , &
        /' intl = ', i2, &
        /' igrid_reg(1) = ', i2, 2x, ' igrid_reg(2) = ', i2, &
        /' nlon_reg = ', i3, 2x, ' nlat_reg = ', i3, &
        /' igrid_gau(1) = ', i2, 2x, ' igrid_gau(2) = ', i2, &
        /' nlon_gau = ', i3, 2x, ' nlat_gau = ', i3)

    ! Transfer data from data_reg to data_gau
    call trssph(intl, igrid_reg, NLON_REG, NLAT_REG, data_reg, igrid_gau, NLON_GAU, &
        NLAT_GAU, data_gau, error_flag)

    if (error_flag == 0) then
        !
        ! Compute nlat_gau gaussian colatitudinal points
        ! and set in colatitudes with south to north orientation
        ! for computing error in data_gau
        call compute_gaussian_latitudes_and_weights( &
            NLAT_GAU, gaussian_latitudes, gaussian_weights, error_flag)

        colatitudes = PI - gaussian_latitudes

        ! Compute the least squares error in data_gau
        err2 = 0.0_wp
        do j=1, NLON_GAU
            phi = real(j - 1, kind=wp) * dlon_gau
            cosp = cos(phi)
            sinp = sin(phi)
            do i=1, NLAT_GAU
                theta = colatitudes(i)
                cost = cos(theta)
                sint = sin(theta)
                xyz = (sint*(sint*cost*sinp*cosp))
                dif = abs(data_gau(j, i)-exp(xyz))
                err2 = err2 + dif**2
            end do
        end do
        err2 = sqrt(err2/(NLON_GAU*NLAT_GAU))
        write (stdout, 300) err2
300     format(' least squares error = ', e10.3)
    end if

    ! Set data_reg to zero
    data_reg = 0.0_wp

    write (stdout, 400) intl, igrid_gau(1), igrid_gau(2), NLON_GAU, NLAT_GAU, igrid_reg(1), &
        igrid_reg(2), NLON_REG, NLAT_REG
400 format(/' GAUSSIAN TO EQUALLY SPACED GRID TRANSFER ' , &
        /' trssph input arguments: ' , &
        /' intl = ', i2, &
        /' igrid_gau(1) = ', i2, 2x, ' igrid_gau(2) = ', i2, &
        /' nlon_gau = ', i3, 2x, ' nlat_gau = ', i3, &
        /' igrid_reg(1) = ', i2, 2x, ' igrid_reg(2) = ', i2, &
        /' nlon_reg = ', i3, 2x, ' nlat_reg = ', i3)

    ! Transfer data_gau back to data_reg
    call trssph(intl, igrid_gau, NLON_GAU, NLAT_GAU, data_gau, igrid_reg, NLON_REG, &
        NLAT_REG, data_reg, error_flag)

    if (error_flag == 0) then

        ! Compute the least squares error in data_reg
        err2 = 0.0
        do j=1, NLON_REG
            phi = real(j-1, kind=wp)*dlon_reg
            cosp = cos(phi)
            sinp = sin(phi)
            do i=1, NLAT_REG
                theta = real(i - 1, kind=wp)*dlat_reg
                cost = cos(theta)
                sint = sin(theta)
                xyz = (sint*(sint*cost*sinp*cosp))
                dif = abs(data_reg(i, j)-exp(xyz))
                err2 = err2+dif**2
            end do
        end do
        err2 = sqrt(err2/(NLAT_REG*NLON_REG))
        write (stdout, 300) err2
    end if

end program test_trssph


program NthRootTest
  implicit none

  print *, nthroot(10, 7131.5**10)
  print *, nthroot(5, 34.0)

contains

  function nthroot(n, A, p)
    real :: nthroot
    integer, intent(in)        :: n
    real, intent(in)           :: A
    real, intent(in), optional :: p

    real :: rp, x(2)

    if ( A < 0 ) then
       stop "A < 0"       ! we handle only real positive numbers
    elseif ( A == 0 ) then
       nthroot = 0
       return
    end if

    if ( present(p) ) then
       rp = p
    else
       rp = 0.001
    end if

    x(1) = A
    x(2) = A/n   ! starting "guessed" value...

    do while ( abs(x(2) - x(1)) > rp )
       x(1) = x(2)
       x(2) = ((n-1.0)*x(2) + A/(x(2) ** (n-1.0)))/real(n)
    end do

    nthroot = x(2)

  end function nthroot

end program NthRootTest


module routines
implicit none
contains

function cross (A, B)
   real(kind=8), dimension(3), intent(in) :: A, B
   real(kind=8), dimension(3) :: cross
   integer :: i

   cross(1) = A(2)*B(3) - A(3)*B(2)
   cross(2) = A(3)*B(1) - A(1)*B(3)
   cross(3) = A(1)*B(2) - A(2)*B(1)

end function cross

end module routines


! ====================================================================
! File: vectorUtils.f90
! Author: C.A.(Sandy) Mader
! Date Started: July 14, 2014
! Date Modified:

subroutine cross_product_3d(v1, v2, cross)
  use constants
  implicit none

  real(kind=realType), dimension(3), intent(in) :: v1, v2
  real(kind=realType), dimension(3), intent(out) :: cross
  cross(1) = (v1(2)*v2(3) - v1(3)*v2(2))
  cross(2) = (v1(3)*v2(1) - v1(1)*v2(3))
  cross(3) = (v1(1)*v2(2) - v1(2)*v2(1))

end subroutine cross_product_3d

subroutine getMag(V, mag)

  use constants
  implicit none

  ! Subroutine Variables
  real(kind=realType), dimension(3), intent(in) :: V
  real(kind=realType), intent(out) :: mag
  mag = sqrt(v(1)**2 + v(2)**2 + v(3)**2 + 1e-30)

end subroutine getMag

subroutine getRotationMatrix3d(v1, v2, Mi)
  use precision
  use constants
  implicit none

  ! Subroutine Variables
  real(kind=realType), dimension(3), intent(in) :: v1, v2
  real(kind=realType), dimension(3, 3), intent(out) :: Mi

  ! Local Variables
  real(kind=realType), dimension(3) :: axis, vv1, vv2
  real(kind=realType):: magV1, magV2, axisMag, angle, arg
  real(kind=realType), dimension(3, 3):: A, C
  real(kind=realType), parameter :: tol= 1.4901161193847656e-08

  call getMag(v1, magV1)
  call getMag(v2, magV2)

  ! Start by determining the rotation axis by getting the
  ! cross product between v1, v2

  call cross_product_3d(v1,v2,axis)
  ! Now Normalize
  call getMag(axis,axisMag)

  ! When axisMag is less that sqrt(eps), the acos 'arg' value will be
  ! exactly one which will give a nan in complex mode.
  if (axisMag < tol) then
     ! no rotation at this point, angle is 0
     angle = zero
     ! the axis doesn't matter so set to x
     axis = zero
     axis(1) = one
  else
     axis = axis/axisMag
     ! Now compute the rotation angle about that axis
     vv1 = v1/magv1
     vv2 = v2/magv2
     arg = min(one, vv1(1)*vv2(1) + vv1(2)*vv2(2) + vv1(3)*vv2(3))
     angle = acos(arg)
  end if
  ! Now that we have an axis and an angle,build the rotation Matrix
  ! A skew symmetric representation of the normalized axis
  A(1,1) = zero
  A(1,2) = -axis(3)
  A(1,3) = axis(2)
  A(2,1) = axis(3)
  A(2,2) = zero
  A(2,3) = -axis(1)
  A(3,1) = -axis(2)
  A(3,2) = axis(1)
  A(3,3) = zero

  !C = A*A
  C(1,1)= A(1,1)*A(1,1)+A(1,2)*A(2,1)+A(1,3)*A(3,1)
  C(1,2)= A(1,1)*A(1,2)+A(1,2)*A(2,2)+A(1,3)*A(3,2)
  C(1,3)= A(1,1)*A(1,3)+A(1,2)*A(2,3)+A(1,3)*A(3,3)
  C(2,1)= A(2,1)*A(1,1)+A(2,2)*A(2,1)+A(2,3)*A(3,1)
  C(2,2)= A(2,1)*A(1,2)+A(2,2)*A(2,2)+A(2,3)*A(3,2)
  C(2,3)= A(2,1)*A(1,3)+A(2,2)*A(2,3)+A(2,3)*A(3,3)
  C(3,1)= A(3,1)*A(1,1)+A(3,2)*A(2,1)+A(3,3)*A(3,1)
  C(3,2)= A(3,1)*A(1,2)+A(3,2)*A(2,2)+A(3,3)*A(3,2)
  C(3,3)= A(3,1)*A(1,3)+A(3,2)*A(2,3)+A(3,3)*A(3,3)

  ! Rodrigues formula for the rotation matrix
  Mi = zero
  Mi(1, 1) = one
  Mi(2, 2) = one
  Mi(3, 3) = one

  Mi = Mi + sin(angle)*A + (one-cos(angle))*C

end subroutine getRotationMatrix3d


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! BenchIT - Performance Measurement for Scientific Applications
! Contact: developer@benchit.org
!
! $Id: gauss.f90 1 2009-09-11 12:26:19Z william $
! $URL: svn+ssh://william@rupert.zih.tu-dresden.de/svn-base/benchit-root/BenchITv6/kernel/numerical/gauss/F95/0/0/double/gauss.f90 $
! For license details see COPYING in the package base directory
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Kernel: Gaussian Linear Equation System Solver
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

! seriell Gauss
subroutine entry(A,b,x,n)
   implicit none

   integer(kind=4) :: i, i1, i2, j0, j1, j2, j, k, n, m
   real(kind=8)    :: A(n,n), mi, b(n), t, x(n), bi, mt, t1
!****************************************************************
   do i=1,n-1,1
      t=1.0D0/A(i,i)
      do j=i+1,n
         b(j)=b(j)-b(i)*(A(j,i)*t)
         do k=i+1,n
            A(k,j)=A(k,j)-(A(i,j)*t)*A(k,i)
         end do
      end do
   end do

   x(n)=b(n)/A(n,n)
   do i=n-1,1,-1
      x(i)=b(i)
      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


module conjugate_gradient

  ! import dependencies
  use iso_fortran_env, only : dp => REAL64

  implicit none

contains

  !-------------------------------------------------------------------!
  ! Solve the linear system using preconditioned conjugate gradient
  ! method
  !-------------------------------------------------------------------!

  subroutine dpparcg(A, M, b, max_it, max_tol, x, iter, tol, flag)

    use clock_class, only : clock

    real(dp), intent(in) :: A(:,:)
    real(dp), intent(in) :: M(:,:)
    real(dp), intent(in) :: b(:)
    integer , intent(in) :: max_it
    real(dp), intent(in) :: max_tol

    real(dp), intent(inout) :: x(:)
    integer , intent(out)   :: iter
    real(dp), intent(out)   :: tol
    integer , intent(out)   :: flag

    ! create local data
    real(dp), allocatable :: p(:), r(:), w(:), z(:)
    real(dp), allocatable :: rho(:), tau(:)
    real(dp) :: alpha, beta
    real(dp) :: bnorm, rnorm
    type(clock) :: timer

    ! Memory allocations
    allocate(r, p, w, z, mold=x)
    allocate(rho(max_it))
    allocate(tau(max_it))

    ! Start the iteration counter
    iter = 1

    ! Norm of the right hand side
    bnorm = co_norm2(b)

    ! Norm of the initial residual
    r         = b - co_matmul(A, x)
    rnorm     = co_norm2(r)
    tol       = rnorm/bnorm
    rho(iter) = rnorm*rnorm

    if (this_image() .eq. 1) then
       open(10, file='pcg.log', action='write', position='append')
    end if

    ! Apply Iterative scheme until tolerance is achieved
    do while ((tol .gt. max_tol) .and. (iter .lt. max_it))

       call timer % start()

       ! step (a)
       z = co_matmul(M,r)

       ! step (b)
       tau(iter) = co_dot_product(z,r)

       ! step (c) compute the descent direction
       if ( iter .eq. 1) then
          ! steepest descent direction p
          beta = 0.0d0
          p = z
       else
          ! take a conjugate direction
          beta = tau(iter)/tau(iter-1)
          p = z + beta*p
       end if

       ! step (b) compute the solution update
       w = co_matmul(A,p)

       ! step (c) compute the step size for update
       alpha = tau(iter)/co_dot_product(p, w)

       ! step (d) Add dx to the old solution
       x = x + alpha*p

       ! step (e) compute the new residual
       r = r - alpha*w
       !r = b - matmul(A, x)

       ! step(f) update values before next iteration
       rnorm = co_norm2(r)
       tol = rnorm/bnorm

       call timer % stop()

       if (this_image() .eq. 1) then
          write(10,*) iter, tol, timer % getelapsed()
          print *, iter, tol, timer % getelapsed()
       end if

       call timer % reset()

       iter = iter + 1

       rho(iter) = rnorm*rnorm

    end do

    close(10)

    deallocate(r, p, w, rho, tau)

    flag = 0

  end subroutine dpparcg

  subroutine dparcg(A, b, max_it, max_tol, x, iter, tol, flag)

    use clock_class, only : clock

    real(dp), intent(in) :: A(:,:)
    real(dp), intent(in) :: b(:)
    integer , intent(in) :: max_it
    real(dp), intent(in) :: max_tol

    real(dp), intent(inout) :: x(:)
    integer , intent(out)   :: iter
    real(dp), intent(out)   :: tol
    integer , intent(out)   :: flag

    ! create local data
    real(dp), allocatable :: p(:), r(:), w(:)
    real(dp), allocatable :: rho(:)
    real(dp) :: alpha, beta
    real(dp) :: bnorm, rnorm

    type(clock) :: timer

    ! Memory allocations
    allocate(r, p, w, mold=x)
    allocate(rho(max_it))

    ! Start the iteration counter
    iter = 1

    ! Norm of the right hand side
    bnorm = co_norm2(b)

    ! Norm of the initial residual
    r         = b - co_matmul(A, x)
    rnorm     = co_norm2(r)
    tol       = rnorm/bnorm
    rho(iter) = rnorm*rnorm

    if (this_image() .eq. 1) then
       open(10, file='cg.log', action='write', position='append')
    end if

    ! Apply Iterative scheme until tolerance is achieved
    do while ((tol .gt. max_tol) .and. (iter .lt. max_it))

       call timer % start()

       ! step (a) compute the descent direction
       if ( iter .eq. 1) then
          ! steepest descent direction p
          p = r
       else
          ! take a conjugate direction
          beta = rho(iter)/rho(iter-1)
          p = r + beta*p
       end if

       ! step (b) compute the solution update
       w = co_matmul(A,p)

       ! step (c) compute the step size for update
       alpha = rho(iter)/co_dot_product(p, w)

       ! step (d) Add dx to the old solution
       x = x + alpha*p

       ! step (e) compute the new residual
       r = r - alpha*w
       !r = b - matmul(A, x)

       ! step(f) update values before next iteration
       rnorm = co_norm2(r)
       tol = rnorm/bnorm

       call timer % stop()

       if (this_image() .eq. 1) then
          write(10,*) iter, tol, timer % getelapsed()
          print *, iter, tol, timer % getelapsed()
       end if

       call timer % reset()

       iter = iter + 1

       rho(iter) = rnorm*rnorm

    end do

    close(10)

    deallocate(r, p, w, rho)

    flag = 0

  end subroutine dparcg

  !===================================================================!
  ! Function to compute the dot product of two distributed vector
  !===================================================================!

  function co_dot_product(a, b) result(dot)

    real(8), intent(in) :: a(:), b(:)
    real(8) :: dot

    ! find dot product, sum over processors, take sqrt and return
    dot = dot_product(a, b)
    call co_sum (dot)

  end function co_dot_product

  !===================================================================!
  ! Function to compute the norm of a distributed vector
  !===================================================================!

  function co_norm2(x) result(norm)

    real(8), intent(in) :: x(:)
    real(8) :: xdot, norm

    ! find dot product, sum over processors, take sqrt and return
    xdot = dot_product(x,x)
    call co_sum (xdot)
    norm = sqrt(xdot)

  end function co_norm2

  !===================================================================!
  ! Function that computes the matrix vector product in a distributed
  ! fashion for columnwise decomposition of matrix
  ! ===================================================================!

  function co_matmul(A, x) result(b)

    ! Arguments
    real(8), intent(in) :: A(:,:)
    real(8), intent(in) :: x(:)
    real(8) :: b(size(x))

    ! Local variables
    integer :: nimages
    integer :: me, local_size
    integer :: stat
    character(10) :: msg

    ! Create a local vector of global sizse (optimize this!)
    real(8), allocatable :: work(:)
    allocate(work, mold=A(:,1))

    ! Determine partition
    nimages = num_images()
    me = this_image()
    local_size = size(x)

    ! Multiply, sum and distrbute
    work = matmul(A,x)
    call co_sum(work, stat=stat, errmsg=msg)
    b = work((me-1)*local_size+1:me*local_size)

    deallocate(work)

  end function co_matmul

end module conjugate_gradient

module system

  implicit none

contains

  !-------------------------------------------------------------------!
  ! Assemble -U_xx = 2x - 0.5, U(0) = 1;  U(1)= 0, x in [0,1]
  !-------------------------------------------------------------------!

  subroutine assemble_system_dirichlet(a, b, npts, V, rhs, u, P, ispreconditioned)

    implicit none

    real(8), intent(in)  :: a, b ! bounds of the domain
    integer, intent(in)  :: npts ! number of interior points
    real(8), intent(out) :: V(npts,npts) ! banded matrix
    real(8), intent(out) :: rhs(npts)
    real(8), intent(out) :: u(npts)
    real(8), intent(out) :: P(npts,npts)
    real(8) :: S(npts,npts), D(npts, npts)

    real(8), parameter :: PI = 3.141592653589793d0
    real(8)            :: h, alpha
    integer            :: M, N
    integer            :: i, j, k

    logical, intent(in) :: ispreconditioned

    ! h = width / num_interior_pts + 1
    h = (b-a)/dble(npts+1)
    V = 0.0d0

    ! Size of the linear system = unknowns (interior nodes)
    M = npts ! nrows
    N = npts ! ncols

    ! Set the inner block
    rows: do i = 1, M
       cols: do j = 1, N
          if (j .eq. i-1) then
             ! lower triangle
             V(j,i) = -1.0d0
          else if (j .eq. i+1) then
             ! upper triangle
             V(j,i) = -1.0d0
          else if (j .eq. i) then
             ! diagonal
             V(j,i) = 2.0d0
          else
             ! skip
          end if
       end do cols
    end do rows

    ! Assemble the RHS
    do i = 1, M
       rhs(i) = h*h*(2.0d0*dble(i)*h - 0.5d0)
    end do
    rhs(1) = rhs(1) + 1.0d0
    rhs(M) = rhs(M)

    ! Initial solution profile use sin function as a first guess
    do i = 1, M
       u(i) =  sin(dble(i)*h*PI)
    end do

    if (ispreconditioned .eqv. .true.) then
       ! Find the sine transform matrix
       alpha = sqrt(2.0d0/dble(npts+1))
       do j = 1, M
          do k = 1, N
             S(k,j) = alpha*sin(PI*dble(j*k)/dble(npts+1))
          end do
       end do

       ! Find the diagonal matrix
       D = matmul(S, matmul(V, S))

       ! Invert the digonal matrix easily
       do j = 1, M
          D(j,j) = 1.0d0/D(j,j)
       end do

       ! Define the preconditioner
       p = matmul(S, matmul(D, S))
    end if

end subroutine assemble_system_dirichlet

end module system

program main

  use conjugate_gradient, only: dparcg, dpparcg
  use system, only : assemble_system_dirichlet
  use clock_class, only : clock

!!$  serial : block
!!$
!!$    integer, parameter :: npts = 64
!!$    real(8), parameter :: max_tol = 1.0d-8
!!$    integer, parameter :: max_it = 100000
!!$    real(8) :: x(npts,3), b(npts), A(npts,npts), P(npts, npts)
!!$    integer :: iter, flag, i, j
!!$    real(8) :: tol
!!$
!!$    ! solve using CG
!!$    call assemble_system_dirichlet(0.0d0, 1.0d0, npts, A, b, x(:,2), P)
!!$    call dparcg(A, b, max_it, max_tol, x(:,2), iter, tol, flag)
!!$    print *, 'cg', tol, iter
!!$
!!$  end block serial

  parallel : block

    integer, parameter :: npts = 25000
    integer, parameter :: max_it = 1000
    real(8), parameter :: max_tol = 1.0d-8

    real(8), allocatable :: x(:)[:], b(:)[:], A(:,:)[:], P(:,:)[:]
    real(8), allocatable :: xtmp(:), btmp(:), Atmp(:,:), Ptmp(:,:)

    integer :: iter, flag, i, j
    real(8) :: tol
    integer :: nimages
    integer :: me, local_size
    type(clock) :: timer
    logical , parameter :: precon = .false.

    allocate(A(npts,npts)[*])
    allocate(P(npts,npts)[*])
    allocate(x(npts)[*])
    allocate(b(npts)[*])

    ! Determine partition
    nimages    = num_images()
    me         = this_image()
    local_size = npts/nimages

    ! Assemble system on master
    if (me .eq. 1) then
       call assemble_system_dirichlet(0.0d0, 1.0d0, npts, A, b, x, P, precon)
    end if

    !sync all

    call timer % start()

    ! Split A, b, x into pieces
    allocate(Atmp(npts,local_size))
    allocate(Ptmp(npts,local_size))
    allocate(xtmp(local_size))
    allocate(btmp(local_size))

    ! Copy from proc 1
    Atmp = A(1:npts,(me-1)*local_size+1:me*local_size)[1]
    Ptmp = P(1:npts,(me-1)*local_size+1:me*local_size)[1]
    xtmp = x((me-1)*local_size+1:me*local_size)[1]
    btmp = b((me-1)*local_size+1:me*local_size)[1]

    ! clearup memory
    deallocate(A,b,x,P)

    ! Distribute the work to processors

    if (precon .eqv. .false.) then
       call dparcg(Atmp, btmp, max_it, max_tol, xtmp, iter, tol, flag)
    else
       call dpparcg(Atmp, Ptmp, btmp, max_it, max_tol, xtmp, iter, tol, flag)
    end if

    call timer % stop()

    if (this_image() .eq. 1) then
       write(*, '("Model run time:",F8.3," seconds")') timer % getelapsed()
    end if

    !if (me .eq. 1) then
    print *, 'cg', tol, iter

    !end if

  end block parallel

end program main