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


!-----------------------------------------------------------------------
      function power2(number)
! Returns TRUE if the number is a power of 2, if not it returns FALSE
        implicit none
        integer :: number,x
        logical :: power2
        x = number
           ! write(*,*) x
        if (x .eq. 0)then
           power2 = .false.
           return
        endif

        do while(MOD(x,2) .eq. 0)
           x = x / 2
        end do
        if (x .gt. 1) then
           power2 =.false.
           return
        else
           power2 = .true.
        endif

      end function power2
!-----------------------------------------------------------------------


double precision function true_solution(x, t)

! True solution for the porous medium equation,
!     q_t = (q**2)_xx.

    double precision :: x, t
    double precision :: mass, tau, t0
    parameter(mass = 1.d0)
    parameter(t0 = .3d0)

    tau = t + t0
    true_solution = (mass - 1.d0/12.d0 * x**2 / tau**(2.d0/3.d0)) / tau**(1.d0/3.d0)
    if (true_solution < 0.d0) true_solution = 0.d0
end function true_solution


      PROGRAM TEST

!  One use for FM involves programs that don't need multiple precision results but do need some
!  of the special functions available in FM but not in the Fortran standard.  These include:

!  BERNOULLI(N)
!  BETA(X,Y)
!  BINOMIAL(N,K) or BINOMIAL(X,Y)
!  COS_INTEGRAL(X)
!  COSH_INTEGRAL(X)
!  EXP_INTEGRAL_EI(X)
!  EXP_INTEGRAL_EN(N,X)
!  FRESNEL_C(X)
!  FRESNEL_S(X)
!  INCOMPLETE_BETA(X,A,B)
!  INCOMPLETE_GAMMA1(X,Y)
!  INCOMPLETE_GAMMA2(X,Y)
!  LOG_INTEGRAL(X)
!  POCHHAMMER(X,N)
!  POLYGAMMA(N,X)
!  PSI(X)
!  SIN_INTEGRAL(X)
!  SINH_INTEGRAL(X)

!  See the complete list of FM functions in FM_User_Manual.txt.

!  For this application, no TYPE(FM) variables need to be declared.  Just add USE FMZM at the top
!  and compile and link the program like SampleFM.f95.

      USE FMZM
      IMPLICIT NONE

      INTEGER :: J
      DOUBLE PRECISION :: A, B, C, C_FM, ERR, MAX_ERR

!             To use with 53-bit double precision, having about 16 significant digits of accuracy,
!             set the FM precision to 16 digits.

      CALL FM_SET(16)

!             1.  Check to see if Fortran's intrinsic gamma function is correctly rounded.

!                 A is the double precision variable, so GAMMA(A) uses Fortran's intrinsic gamma.

!                 TO_FM(A) converts A to an FM number, so GAMMA( TO_FM(A) ) uses FM's gamma,
!                 then the "=" rounds the result back to double precision variable C_FM.

!                 It is possible that different compilers might give different results for this
!                 test.  Some compilers may not give results that are correctly rounded to full
!                 double precision accuray when A is large, but C_FM should be correctly rounded.

      MAX_ERR = 0
      DO J = 10, 150, 10
         A = J + 0.5D0
         C = GAMMA(A)
         C_FM = GAMMA( TO_FM(A) )
         ERR = ABS( (C - C_FM) / C_FM )
         IF (ERR > MAX_ERR) THEN
             MAX_ERR = ERR
             B = A
         ENDIF
      ENDDO

      WRITE (*,"(///A/)") " Sample 1.  Compare Fortran's built-in gamma function to FM's"
      IF (MAX_ERR > 0) THEN
          A = B
          WRITE (*,"(A,ES13.7,A,F7.3)") ' Maximum relative error in Fortran gamma was ',  &
                                         MAX_ERR, ' for A = ', A
          C = GAMMA(A)
          WRITE (*,"(ES25.15,A)") C,    ' = GAMMA(A)'
          C_FM = GAMMA( TO_FM(A) )
          WRITE (*,"(ES25.15,A)") C_FM, ' = GAMMA( TO_FM(A) )'
      ELSE
          WRITE (*,"(A)") ' All Fortran gamma results were correctly rounded.'
      ENDIF

!             2.  Binomial coefficients.

!                 Find the probability of getting exactly 10,000 heads in 20,000 tosses
!                 of a fair coin.

!                 Here we could not store the results of the binomial and power separately in
!                 double precision, since BINOMIAL( 20000, 10000 ) = 2.2e+6018 and
!                 2**20000 = 4.0e+6020 would both overflow in double precision.

      WRITE (*,"(//A)") " Sample 2.  Binomial coefficients"
      WRITE (*,"(A)")   "            Find the probability of getting exactly 10,000 heads"
      WRITE (*,"(A/)")  "            in 20,000 tosses of a fair coin."

      C_FM = BINOMIAL( TO_FM(20000), TO_FM(10000) ) / TO_FM(2)**20000

      WRITE (*,"(A,F20.16)") " BINOMIAL( TO_FM(20000), TO_FM(10000) ) / TO_FM(2)**20000 =", C_FM

!             3.  Log Integral function.

!                 Estimate the number of primes less than 10**30.

      WRITE (*,"(//A)") " Sample 3.  Log integral"
      WRITE (*,"(A/)")  "            Estimate the number of primes less than 10**30."

      C_FM = LOG_INTEGRAL( TO_FM('1.0E+30') )

      WRITE (*,"(A,ES23.15)") " LOG_INTEGRAL(TO_FM('1.0E+30')) =", C_FM

!             4.  Psi and polygamma functions.

!                 Rational series can often be summed using these functions.
!                 Sum (n=1 to infinity) 1/(n**2 * (8n+1)**2) =
!                 16*(psi(1) - psi(9/8)) + polygamma(1,1) + polygamma(1,9/8)
!                 Reference: Abramowitz & Stegun, Handbook of Mathematical Functions,
!                 chapter 6, Example 10.

      WRITE (*,"(//A)") " Sample 4.  Psi and polygamma functions."
      WRITE (*,"(A)")   "            Sum (n=1 to infinity) 1/(n**2 * (8n+1)**2) ="
      WRITE (*,"(A/)")  "            16*(psi(1) - psi(9/8)) + polygamma(1,1) + polygamma(1,9/8)"

      C_FM = 16*( PSI( TO_FM(1) ) - PSI( TO_FM(9)/8 ) ) +           &
             POLYGAMMA( 1, TO_FM(1) ) + POLYGAMMA( 1, TO_FM(9)/8 )

      WRITE (*,"(A,F19.16)") " Sum =", C_FM

!             5.  Incomplete gamma and gamma functions.

!                 Find the probability that an observed chi-square for a correct model should be
!                 less that 2.3 when the number of degrees of freedom is 5.
!                 Reference: Knuth, Volume 2, 3rd ed., Page 56, and Press, Flannery, Teukolsky,
!                 Vetterling, Numerical Recipes, 1st ed., Page 165.

      WRITE (*,"(//A/)") " Sample 5.  Incomplete gamma and gamma functions."

      C_FM = INCOMPLETE_GAMMA1( TO_FM(5)/2, TO_FM('2.3')/2 ) / GAMMA( TO_FM(5)/2 )

      WRITE (*,"(A,F19.16/)") " Probability =", C_FM

      END PROGRAM TEST


!>  Discrete Fourier (Inverse)Transform utilities.
!!
!!  Procedures
!!  --------------------------------------
!!  dft         Compute the discrete Fourier transform of a signal.
!!  idft        Compute the inverse discrete Fourier transform of a frequency spectrum.
!!  idft_eval   Compute the inverse discrete Fourier transform evaluated at user-specified points.
!!
!!  @author Nathan A. Wukie
!!  @date   2/26/2018
!!
!----------------------------------------------------------------------
module mod_dft
#include <messenger.h>
    use mod_kinds,      only: ik, rk
    use mod_constants,  only: PI, ZERO, ONE, TWO
    use mod_gridspace,  only: linspace
    use DNAD_D
    implicit none

contains

    !>  Computes the discrete Fourier transform of an input data set.
    !!
    !!  ADAPTED FROM:
    !!  www.nayuki.io/res/how-to-implement-the-discrete-fourier-transform/dft.py
    !!
    !!  LICENCE:
    !!  Public Domain
    !!
    !!  Computes X[i] = (1/N)sum[ x(i)e^(-j*2pi*n*k*/N) ]
    !!
    !!  NOTE: The normalization convention used here, (1/N), defines
    !!  the DC part of the transform X[0] to be the average.
    !!
    !!  The transform result is in 'standard' order:
    !!  [ DC, omega_1, omega_2,..., omega_n, -omega_n, ... -omega_2, -omega_1]
    !!
    !!  [DC|     positive frequencies      |       negative frequencies      ]
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/26/2018
    !!
    !!  @param[in]      input       periodic signal
    !!  @param[inout]   outreal     real part of DFT
    !!  @param[inout]   outimag     imag part of DFT
    !!
    !-----------------------------------------------------------------
    subroutine dft(inreal,inimag,outreal,outimag,negate)
        type(AD_D), intent(in)                  :: inreal(:)
        type(AD_D), intent(in)                  :: inimag(:)
        type(AD_D), intent(inout), allocatable  :: outreal(:)
        type(AD_D), intent(inout), allocatable  :: outimag(:)
        logical,    intent(in), optional        :: negate

        real(rk)    :: theta, freq, change
        integer     :: n, imode, itheta

        ! Check odd-count input
        if (mod(size(inreal),2) == 0) call chidg_signal(FATAL,"dft: expecting odd-count of input values.")

        ! Initialize derivative arrays
        outreal = inreal
        outimag = inreal

        outreal = ZERO
        outimag = ZERO

        change = ONE
        if (present(negate)) then
            if (negate) change = -ONE
        end if

        ! Loop over output modes
        n = size(inreal)
        do imode = 1,n
            do itheta = 1,n
                if (imode <= ((size(inreal)-1)/2 + 1)) then
                    freq = change*TWO*PI*real(imode-1,rk)  ! positive frequencies
                else
                    freq = -change*TWO*PI*real(size(inreal)-imode+1,rk) ! negative frequencies
                end if
                theta = real(itheta-1,rk) / real(n,rk)
                outreal(imode) = outreal(imode)  +  inreal(itheta)*cos(freq*theta)  +  inimag(itheta)*sin(freq*theta)
                outimag(imode) = outimag(imode)  -  inreal(itheta)*sin(freq*theta)  +  inimag(itheta)*cos(freq*theta)
            end do !itheta
        end do !imode

        ! Normalize
        outreal = outreal / real(n,rk)
        outimag = outimag / real(n,rk)

    end subroutine dft
    !******************************************************************

    !>  Computes the partial discrete Fourier transform of an input data set.
    !!
    !!  Here, we wish to compute the dft of a signal defined from 0 to 2pi.
    !!  However, the incoming signal is defined only on a section of that
    !!  range 0 to 2pi/T, where T is some integer indicating the number of
    !!  sections the original range has been broken into.
    !!
    !!  For mode numbers that are multiples of T, their dft can be computed
    !!  as
    !!
    !!      F[k] = (T/N)sum[ f(i) e^(-j k 2pi n/N) ]
    !!
    !!  ADAPTED FROM:
    !!  www.nayuki.io/res/how-to-implement-the-discrete-fourier-transform/dft.py
    !!
    !!  LICENCE:
    !!  Public Domain
    !!
    !!  NOTE: The normalization convention used here, (1/N), defines
    !!  the DC part of the transform X[0] to be the average.
    !!
    !!  The transform result is in 'standard' order:
    !!  [ DC, omega_1, omega_2,..., omega_n, -omega_n, ... -omega_2, -omega_1]
    !!
    !!  [DC|     positive frequencies      |       negative frequencies      ]
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/26/2018
    !!
    !!  @param[in]      input       periodic signal
    !!  @param[inout]   outreal     real part of DFT
    !!  @param[inout]   outimag     imag part of DFT
    !!  @param[in]      factor      number of 'passages' in periodic signal
    !!                              that the dft of the input signal will
    !!                              have to be multiplied by.
    !!  @param[in]      modes       'm' in e^i m theta. Starting from 0.
    !!
    !-----------------------------------------------------------------
    subroutine pdft(inreal,inimag,outreal,outimag,factor,modes)
        type(AD_D),     intent(in)                  :: inreal(:)
        type(AD_D),     intent(in)                  :: inimag(:)
        type(AD_D),     intent(inout), allocatable  :: outreal(:)
        type(AD_D),     intent(inout), allocatable  :: outimag(:)
        integer(ik),    intent(in)                  :: factor
        integer(ik),    intent(in)                  :: modes(:)

        real(rk)    :: theta, mode
        integer     :: n, imode, itheta, ierr

        ! Check odd-count input
        if (mod(size(inreal),2) == 0) call chidg_signal(FATAL,"pdft: expecting odd-count of input values.")

        ! Initialize derivative arrays
        allocate(outreal(size(modes)), outimag(size(modes)), stat=ierr)
        if (ierr/=0) call AllocationError
        outreal = ZERO*inreal(1)
        outimag = ZERO*inreal(1)

        ! Loop over output modes
        n = size(inreal)
        do imode = 1,size(modes)
            mode = real(modes(imode),rk)
            do itheta = 1,n
                theta = TWO*PI*real(itheta-1,rk)/real(n*factor,rk)
                outreal(imode) = outreal(imode)  +  inreal(itheta)*cos(mode*theta)  +  inimag(itheta)*sin(mode*theta)
                outimag(imode) = outimag(imode)  -  inreal(itheta)*sin(mode*theta)  +  inimag(itheta)*cos(mode*theta)
            end do !itheta
        end do !imode

        ! Normalize
        outreal = real(factor,rk)*outreal/real(n*factor,rk)
        outimag = real(factor,rk)*outimag/real(n*factor,rk)

    end subroutine pdft
    !******************************************************************

    !>  Computes the inverse discrete Fourier transform of an input data set.
    !!
    !!  Computes x[i] = sum[ X(i)e^(j*2pi*n*k*/N) ]
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/26/2018
    !!
    !-----------------------------------------------------------------
    function idft(inreal,inimag) result(output)
        type(AD_D),     intent(in)  :: inreal(:)
        type(AD_D),     intent(in)  :: inimag(:)

        type(AD_D), allocatable :: output(:)
        real(rk),   allocatable :: theta(:)
        real(rk)                :: freq
        integer                 :: itheta, imode, ierr

        ! Check odd-count input
        if (mod(size(inreal),2) == 0) call chidg_signal(FATAL,"idft: expecting odd-count of input values.")

        ! Allocate and initialize derivatives
        allocate(output(size(inreal)), stat=ierr)
        if (ierr /= 0) call AllocationError
        output(:) = inreal(1)
        output = ZERO

        ! Theta at equispaced nodes
        theta = linspace(0._rk, real((size(inreal)-1),rk)/real(size(inreal)),size(inreal))

        ! Loop over output points
        do itheta = 1,size(theta)
            do imode = 1,size(inreal)
                freq = TWO*PI*real(imode-1,rk)
                output(itheta) = output(itheta) + inreal(imode)*cos(freq*theta(itheta)) - inimag(imode)*sin(freq*theta(itheta))
            end do !imode
        end do !itheta

    end function idft
    !******************************************************************

    !>  Computes the inverse discrete Fourier transform evaluated
    !!  at user-specified locations, instead of the traditional
    !!  equi-spaced grid.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   2/26/2018
    !!
    !!  @param[in]  inreal  Real part of DFT. (could be directly from 'dft')
    !!  @param[in]  inimag  Imag part of DFT. (could be directly from 'dft')
    !!  @param[in]  theta   Array of locations where the idft will be evaluated
    !!                      normalized by the period.
    !!  @param[in]  theta   location T normalized by the periodicity. T=t/P
    !!
    !!  For example, if the original dft was computed over a period P=2.5, then
    !!  say we want to evaluate the transform at a location t=0.7. The incoming
    !!  value for theta would be T=0.7/2.5
    !!
    !---------------------------------------------------------------------------
    subroutine idft_eval(inreal,inimag,theta,outreal,outimag,negate,symmetric)
        type(AD_D),     intent(in)           :: inreal(:)
        type(AD_D),     intent(in)           :: inimag(:)
        type(AD_D),     intent(in)           :: theta(:)
        type(AD_D),     intent(inout)        :: outreal(:)
        type(AD_D),     intent(inout)        :: outimag(:)
        logical,        intent(in), optional :: negate
        logical,        intent(in), optional :: symmetric

        real(rk)    :: freq, change
        integer     :: itheta, imode, ierr
        logical     :: compute_symmetric

        ! Allocate and initialize derivatives
        outreal(:) = inreal(1)
        outimag(:) = inreal(1)
        outreal = ZERO
        outimag = ZERO

        change = ONE
        if (present(negate)) then
            if (negate) change = -ONE
        end if

        compute_symmetric = .false.
        if (present(symmetric)) then
            if (symmetric) then
                compute_symmetric = .true.
            end if
        end if

        if (compute_symmetric) then
            do itheta = 1,size(theta)
                do imode = 1,size(inreal)
                    if (imode <= ((size(inreal)-1)/2 + 1)) then
                        freq = change*TWO*PI*real(imode-1,rk)  ! positive frequencies
                        if (imode > 1) then
                            outreal(itheta) = outreal(itheta) + TWO*(inreal(imode)*cos(freq*theta(itheta)) - inimag(imode)*sin(freq*theta(itheta)))
                        else
                            outreal(itheta) = outreal(itheta) + inreal(imode)*cos(freq*theta(itheta)) - inimag(imode)*sin(freq*theta(itheta))
                        end if
                        outimag(itheta) = ZERO
                    end if
                end do
            end do
        else
            do itheta = 1,size(theta)
                do imode = 1,size(inreal)
                    if (imode <= ((size(inreal)-1)/2 + 1)) then
                        freq = change*TWO*PI*real(imode-1,rk)  ! positive frequencies
                    else
                        freq = -change*TWO*PI*real(size(inreal)-imode+1,rk) ! negative frequencies
                    end if
                    outreal(itheta) = outreal(itheta) + inreal(imode)*cos(freq*theta(itheta)) - inimag(imode)*sin(freq*theta(itheta))
                    outimag(itheta) = outimag(itheta) + inreal(imode)*sin(freq*theta(itheta)) + inimag(imode)*cos(freq*theta(itheta))
                end do
            end do

        end if

    end subroutine idft_eval
    !******************************************************************

    !>  Computes the inverse discrete Fourier transform of a partial DFT
    !!  evaluated with pdft at user-specified locations, instead of the
    !!  traditional equi-spaced grid.
    !!
    !!  @author Nathan A. Wukie
    !!  @date   4/15/2018
    !!
    !!  @param[in]  inreal  Real part of DFT. (could be directly from 'dft')
    !!  @param[in]  inimag  Imag part of DFT. (could be directly from 'dft')
    !!  @param[in]  theta   Array of locations where the idft will be evaluated
    !!                      normalized by the period.
    !!  @param[in]  period  Period, which will be used to normalize the 'theta'
    !!                      inputs with respect to the Fourier transform.
    !!
    !!  For example, if the original dft was computed over a period 2.5, then
    !!  say we want to evaluate the transform at a location 0.7. The incoming
    !!  value for theta would be 0.7/2.5
    !!
    !---------------------------------------------------------------------------
    subroutine ipdft_eval(inreal,inimag,theta,factor,modes,outreal,outimag)
        type(AD_D),     intent(in)      :: inreal(:)
        type(AD_D),     intent(in)      :: inimag(:)
        real(rk),       intent(in)      :: theta(:)
        integer(ik),    intent(in)      :: factor
        integer(ik),    intent(in)      :: modes(:)
        type(AD_D),     intent(inout)   :: outreal(:)
        type(AD_D),     intent(inout)   :: outimag(:)

        real(rk)    :: mode
        integer     :: itheta, imode, ierr

        ! Allocate and initialize derivatives
        outreal(:) = inreal(1)
        outimag(:) = inreal(1)
        outreal = ZERO
        outimag = ZERO

        do itheta = 1,size(theta)
            do imode = 1,size(inreal)
                mode = real(modes(imode),rk)
                outreal(itheta) = outreal(itheta) + inreal(imode)*cos(mode*TWO*PI*theta(itheta)) - inimag(imode)*sin(mode*TWO*PI*theta(itheta))
                outimag(itheta) = outimag(itheta) + inreal(imode)*sin(mode*TWO*PI*theta(itheta)) + inimag(imode)*cos(mode*TWO*PI*theta(itheta))
            end do !imode
        end do !itheta

    end subroutine ipdft_eval
    !******************************************************************

end module mod_dft


      REAL FUNCTION ZCRVALUE(ALPH)
C*****************************ZCRVALUE**********************************
C
	IMPLICIT NONE
C	CALCULATE THE CRITICAL VALUE Z SUCH THAT PR[X > Z] = ALPH
C	WHERE X IS A STANDARD NORMAL R.V.
C
C       REF: SEE KENNEDY & GENTLE. STATISTICAL COMPUTING P.95
C***********************************************************************
C
C Arguments:
C
	REAL ALPH
C
C Locals:
C
	REAL C0,C1,C2,D1,D2,D3,T,CALPH
      DATA C0,C1,C2,D1,D2,D3 /   2.515517,.802853,.010328
     +  , 1.432788,.189269,.001308/
C
C Code:
C
	IF (ALPH.LE.0.5) THEN
	    T =SQRT(ALOG(1./ALPH**2)       )
	    ZCRVALUE = C0     +C1*T + C2*T**2
	    ZCRVALUE = ZCRVALUE/(1. + D1*T + D2*T**2 + D3*T**3)
	    ZCRVALUE = T-ZCRVALUE
	ELSE
	    CALPH=1.-ALPH
	    T =SQRT(ALOG(1./CALPH**2)       )
	    ZCRVALUE = C0     +C1*T + C2*T**2
	    ZCRVALUE = ZCRVALUE/(1. + D1*T + D2*T**2 + D3*T**3)
	    ZCRVALUE = T-ZCRVALUE
	    ZCRVALUE = -ZCRVALUE
	END IF
C
C    Finished.
C
	RETURN
	END


program arrayops
    implicit none
    integer :: i, j
    integer, parameter :: M = 5
    real, dimension(M) :: x
    real :: s, t

    ! initialize the array
    do i=1, M
        x(i) = i
    end do

    ! sum
    s = 0.
    do i=1,M
        s = s + x(i)
    end do
    write(*,*)"sum = ",s

    ! average (mean)
    write(*,*)"average = ",s/M

    ! product
    s = 1.
    do i=1,M
        s = s * x(i)
    end do
    write(*,*)"product = ",s

    ! maximum value
    s = x(1)
    do i=2,M
        if (x(i) > s) then
            s = x(i)
        end if
    end do
    write(*,*)"max = ",s

    ! minimum value
    s = x(1)
    do i=2,M
        if (x(i) < s) then
            s = x(i)
        end if
    end do
    write(*,*)"min = ",s

    ! norm
    s = 0.
    do i=1,M
        s = s + x(i) * x(i)
    end do
    write(*,*)"norm = ",sqrt(s)

    ! second largest value
    if (x(1) > x(2)) then
        s = x(2)
        t = x(1)
    else
        s = x(2)
        t = x(1)
    end if
    do i=3,M
        if (x(i) > s) then
            if (x(i) > t) then
               s = t
               t = x(i)
            else
                s =x(i)
            end if
        end if
    end do
    write(*,*)"second largest value = ", s

end program


    MODULE random_standard_exponential_mod
! .. Implicit None Statement ..
      IMPLICIT NONE
! ..
    CONTAINS

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

      FUNCTION random_standard_exponential()
!**********************************************************************C
!                                                                      C
!                                                                      C
!     (STANDARD-)  E X P O N E N T I A L   DISTRIBUTION                C
!                                                                      C
!                                                                      C
!**********************************************************************C
!**********************************************************************C
!                                                                      C
!     FOR DETAILS SEE:                                                 C
!                                                                      C
!               AHRENS, J.H. AND DIETER, U.                            C
!               COMPUTER METHODS FOR SAMPLING FROM THE                 C
!               EXPONENTIAL AND NORMAL DISTRIBUTIONS.                  C
!               COMM. ACM, 15,10 (OCT. 1972), 873 - 882.               C
!                                                                      C
!     ALL STATEMENT NUMBERS CORRESPOND TO THE STEPS OF ALGORITHM       C
!     'SA' IN THE ABOVE PAPER (SLIGHTLY MODIFIED IMPLEMENTATION)       C
!                                                                      C
!     Modified by Barry W. Brown, Feb 3, 1988 to use RANF instead of   C
!     SUNIF.  The argument IR thus goes away.                          C
!                                                                      C
!**********************************************************************C
!     Q(N) = SUM(ALOG(2.0)**K/K!)    K=1,..,N ,      THE HIGHEST N
!     (HERE 8) IS DETERMINED BY Q(N)=1.0 WITHIN STANDARD PRECISION
!     JJV added a Save statement for q (in Data statement)
! .. Use Statements ..
        USE random_standard_uniform_mod
! ..
! .. Implicit None Statement ..
        IMPLICIT NONE
! ..
! .. Function Return Value ..
        REAL :: random_standard_exponential
! ..
! .. Local Scalars ..
        REAL :: a, q1, u, umin, ustar
        INTEGER :: i
! ..
! .. Local Arrays ..
        REAL, SAVE :: q(8)
! ..
! .. Intrinsic Functions ..
        INTRINSIC AMIN1
! ..
! .. Equivalences ..
        EQUIVALENCE (q(1),q1)
! ..
! .. Data Statements ..
        DATA q/0.6931472, 0.9333737, 0.9888778, 0.9984959, 0.9998293, &
          0.9999833, 0.9999986, 0.9999999/
! ..
! .. Executable Statements ..

        a = 0.0
        u = random_standard_uniform()
        GO TO 20

10      CONTINUE
        a = a + q1
20      CONTINUE
        u = u + u
!     JJV changed the following to reflect the true algorithm and
!     JJV prevent unpredictable behavior if U is initially 0.5.
!      IF (u.LE.1.0) GO TO 20
        IF (u<1.0) GO TO 10
        u = u - 1.0
        IF (u<=q1) THEN
          random_standard_exponential = a + u
          RETURN
        END IF

        i = 1
        ustar = random_standard_uniform()
        umin = ustar
        ustar = random_standard_uniform()
        umin = AMIN1(ustar,umin)
        i = i + 1
        DO WHILE (u>q(i))
          ustar = random_standard_uniform()
          umin = AMIN1(ustar,umin)
          i = i + 1
        END DO
        random_standard_exponential = a + umin*q1
        RETURN

      END FUNCTION random_standard_exponential

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

    END MODULE random_standard_exponential_mod


real function matrix_multiply_test(N,method)

    use mod_rand
    implicit none

    external DGEMM,DDOT

    double precision :: DDOT
    integer, intent(in) :: N,method
    integer :: start,finish,count_rate
    double precision, dimension(:,:), allocatable :: A,B,C

    ! Local
    integer :: i,j,k

    ! Create the random arrays
    call init_random_seed()
    allocate(A(N,N),B(N,N),C(N,N))
    call random_number(A)
    call random_number(B)

    ! Start the timer and start multiplying
    call system_clock(start,count_rate)
    select case(method)
        case(1) ! Default method provided as an intrinsic method
            C = matmul(A,B)
        case(2) ! Simple three loop multiplication
            !$OMP parallel do private(j,k)
            do i=1,N
                do j=1,N
                    do k=1,N
                        C(i,j) = C(i,j) + A(i,k) * B(k,j)
                    enddo
                enddo
            enddo
        case(3) ! OpenMP parallelized double loop
            !$OMP parallel do private(j)
            do i=1,N
                do j=1,N
                    C(i,j) = DDOT(N, A(i,:), 1, B(:,j), 1)
                enddo
            enddo
        case(4) ! BLAS Routine call
            ! call DGEMM(transa,transb,l,n,m,alpha,a,lda,b,ldb,beta,c,ldc)
            call DGEMM('N', 'N', N, N, N, 1.d0, A, N, B, N, 0.d0, C, N)
        case default
            print *, "***ERROR*** Invalid multiplication method!"
            matrix_multiply_test = -1
            return
    end select
    call system_clock(finish,count_rate)

    matrix_multiply_test = float(finish - start) / float(count_rate)

end function matrix_multiply_test

program matrix_multiply

    use omp_lib

    implicit none

    integer :: N, method, threads
    character(len=10) :: input_N, input_method, input_threads
    real :: matrix_multiply_test, time

    select case(iargc())
        case(0)
            N = 1000
            method = 1
            threads = 1
        case(1)
            call getarg(1,input_N)
            read(input_N,'(I10)') N
            method = 1
        case(2)
            call getarg(1,input_N)
            call getarg(2,input_method)
            read(input_N,'(I10)') N
            read(input_method,'(I10)') method
        case(3)
            call getarg(1,input_N)
            call getarg(2,input_method)
            call getarg(3,input_threads)
            read(input_N,'(I10)') N
            read(input_method,'(I10)') method
            read(input_threads,'(I10)') threads
        case default
            print *, "***ERROR*** Too many arguments!"
            stop
    end select

    !$ call omp_set_num_threads(threads)

    time = matrix_multiply_test(N, method)

    print '("Timing for ",i5,"x",i5," matrices: ",f10.5," s")',N,N,time

end program matrix_multiply


module slf_integrate

  use iso_fortran_env, only: r32 => real32, r64 => real64
  implicit none

  interface integrate
    module procedure integrate32
    module procedure integrate64
  end interface integrate

contains

  pure real(r32) function integrate32(y,x) result(intg)
    real(r32), dimension(:), intent(in) :: x, y
    integer :: n

    if (size(x) /= size(y)) error stop "size(x) /= size(y)"

    n = size(x)
    intg = sum((y(2:n) + y(1:n-1)) * (x(2:n) - x(1:n-1))) / 2
  end function

  pure real(r64) function integrate64(y,x) result(intg)
    real(r64), dimension(:), intent(in) :: x, y
    integer :: n

    if (size(x) /= size(y)) error stop "size(x) /= size(y)"

    n = size(x)
    intg = sum((y(2:n) + y(1:n-1)) * (x(2:n) - x(1:n-1))) / 2
  end function

end module slf_integrate


! quadrature.f90
! author: sunder

!-----------------------------------------------------------------------
! Various quadrature routines
!-----------------------------------------------------------------------

pure subroutine gauleg(x1, x2, x, w, n)
    implicit none
    ! Argument list
    integer, intent(in)           ::  n
    real, intent (in) :: x1, x2
    real, intent(out) :: x(n), w(n)
    ! Local variables
    real, parameter :: EPS = 1.0e-15
    real, parameter :: m_pi = 4.0*atan(1.0)
    integer  :: i,j,m
    real :: p1, p2, p3, pp, xl, xm, z, z1

    m  = (n+1)/2
    xm = 0.5*(x2+x1)
    xl = 0.5*(x2-x1)
    do i=1,m
        z = COS(M_PI*(i-0.25)/(n+0.5))
    1   continue
        p1 = 1.0
        p2 = 0.0
        do j = 1,n
            p3 = p2
            p2 = p1
            p1 = ((2.0*j-1.0)*z*p2-(j-1.0)*p3)/real(j)
        end do
        pp = real(n)*(z*p1-p2)/(z*z-1.0)
        z1 = z
        z  = z1-p1/pp
        if (abs(z-z1) .gt. EPS) goto 1
        x(i)    = xm-xl*z
        x(n+1-i)= xm+xl*z
        w(i)    = 2.0*xl/((1.0-z*z)*pp*pp)
        w(n+1-i)= w(i)
    end do
    return
end subroutine gauleg

pure subroutine gaulob(x1,x2,x,w,n1)

  !--------------------------------------------------------------------------
  implicit none
  !--------------------------------------------------------------------------
  ! Argument list
  integer          :: n1
  real :: x1,x2,x(n1),w(n1)
  ! Local variables
  real, parameter  :: EPS = 1.0e-15
  real, parameter  :: m_pi = 4.0*atan(1.0)
  integer           :: i,k
  real  :: xold(n1)
  real  :: P(n1,n1)
  integer           :: n, iter, maxiter
  !--------------------------------------------------------------------------
  intent(IN)  :: x1,x2,n1
  intent(OUT) :: x,w
  !--------------------------------------------------------------------------

  !
  n = N1-1;

  ! Use the Chebyshev-Gauss-Lobatto nodes as the first guess

  do i = 0, N
   x(i+1) = cos(m_pi*real(i)/real(N))
  end do
  ! The Legendre Vandermonde Matrix
  P=0.0
  !
  ! Compute P_(N) using the recursion relation
  ! Compute its first and second derivatives and
  ! update x using the Newton-Raphson method.
  !
  xold=2.0
  !
  maxiter = 100000
  do iter = 1, maxiter
    xold=x
    P(:,1)=1.0
    P(:,2)=x
    do k = 2, N
        P(:,k+1)=( (2*k-1)*x*P(:,k)-(k-1)*P(:,k-1) )/real(k)
    end do
    x=xold-( x*P(:,N1)-P(:,N) )/( N1*P(:,N1) )
    IF(maxval(abs(x-xold)) .le. eps) then
      exit
    end if
  end do
  w = 2.0/(real(N*N1)*P(:,N1)**2)
  w = 0.5*w*(x2-x1)
  x = x1 + 0.5*(x+1.0)*(x2-x1)
  !
end subroutine gaulob


!---------------------------------------------------------------------------------------------------
!
!	filename = consts.f90
!	authors = Edison Salazar
!		  Pedro Guarderas
!	date = 18/10/2013
!
!---------------------------------------------------------------------------------------------------

!---------------------------------------------------------------------------------------------------
! Module of constants
module consts
  implicit none
  ! Constants definition
  double precision :: pi_ = 4.0D0 * atan( 1.0D0 )
  double precision :: pi2_ = 8.0D0 * atan( 1.0D0 )
  double precision :: pi4_ = 16.0D0 * atan( 1.0D0 )

end module consts


!!Contains scripts used to correct or 'delint' a POSCAR.

Module delinter

  use num_types
  use numerical_utilities
  use vector_matrix_utilities, only: matrix_inverse, norm

  implicit none
  private
  public delint

CONTAINS

  !!Converts cell parameters into a matrix of basis
  !!vectors.
  !!<parameter name="params" regular="true">The cell parameters, a, b,
  !!c, alpha, beta, gamma.</parameter>
  !!<parameter name="basis" regular="true">The basis vectors of the
  !!cell.</parameter>
  SUBROUTINE cell2basis(params, basis)
    real(dp), intent(in) :: params(6)
    real(dp), intent(out) :: basis(3,3)

    real(dp) :: a, b, c, alpha, beta, gamma, temp

    a = params(1)
    b = params(2)
    c = params(3)
    alpha = params(4)
    beta = params(5)
    gamma = params(6)

    temp = (cos(alpha)-cos(beta)*cos(gamma))/sin(gamma)

    basis(1,1) = a
    basis(1,2) = b*cos(gamma)
    basis(1,3) = c*cos(beta)
    basis(2,1) = 0.0_dp
    basis(2,2) = b*sin(gamma)
    basis(2,3) = c*temp
    basis(3,1) = 0.0_dp
    basis(3,2) = 0.0_dp
    basis(3,3) = c*sqrt(1-cos(beta)**2 -temp**2)
  end SUBROUTINE cell2basis

  !!Returns the cosine of the angle between two
  !!vectors.
  !!<parameter name="vec1" regular="true">Vector 1.</parameter>
  !!<parameter name="vec2" regular="true">Vecotr 2.</parameter>
  !!<parameter name="ang" regular="true">The cosine of the angle
  !!between vecs 1 and 2.</parameter>
  SUBROUTINE cosangs(vec1, vec2, ang)
    real(dp), intent(in) :: vec1(3), vec2(3)
    real(dp), intent(out) :: ang

    ang = dot_product(vec1, vec2)/(sqrt(dot_product(vec1,vec1))*sqrt(dot_product(vec2,vec2)))
  end SUBROUTINE cosangs

  !!Converts crystall basis to cell parameters.
  !!<parameter name="vecs" regular="true">The input basis
  !!vectors.</parameter>
  !!<parameter name="params" regular="true">The output cell
  !!parameters.</parameter>
  SUBROUTINE basis2cell(vecs, params)
    real(dp), intent(in) :: vecs(3,3)
    real(dp), intent(out) :: params(6)

    integer :: i
    real(dp) :: alpha, beta, gamma

    do i=1,3
       params(i) = sqrt(dot_product(vecs(:,i),vecs(:,i)))
    end do

    call cosangs(vecs(:,2), vecs(:,3), alpha)
    call cosangs(vecs(:,1), vecs(:,3), beta)
    call cosangs(vecs(:,1), vecs(:,2), gamma)
    params(4) = acos(alpha)
    params(5) = acos(beta)
    params(6) = acos(gamma)
  end SUBROUTINE basis2cell

  !!Enforces the symmetries of the niggli case onto the
  !!cell parameters.
  !!<parameter name="in_params" regular="true">The input cell
  !!parameters.</parameter>
  !!<parameter name="case" regular="true">The niggli case
  !!number.</parameter>
  !!<parameter name="out_params" regular="true">The output symmetrized
  !!parameters.</parameter>
  !!<parameter name="eps" regular="true">Floating point tolerance.</parameter>
  SUBROUTINE symmetrize(in_params, case, out_params, eps)
    real(dp), intent(in) :: in_params(6)
    integer, intent(in) :: case
    real(dp), intent(out) :: out_params(6)
    real(dp), intent(in) :: eps

    real(dp) :: a0, b0, c0, alpha0, beta0, gamma0
    real(dp) :: a, b, c, alpha, beta, gamma
    real(dp) :: temp, pi

    pi = 3.1415926535897931_dp

    a0 = in_params(1)
    b0 = in_params(2)
    c0 = in_params(3)
    alpha0 = in_params(4)
    beta0 = in_params(5)
    gamma0 = in_params(6)

    if (case==1) then
       temp = (a0+b0+c0)/3.0_dp
       a = temp
       b = temp
       c = temp
       alpha = pi/3.0_dp
       beta= pi/3.0_dp
       gamma = pi/3.0_dp
    else if ((case==2) .or. (case==4)) then
       temp = (a0+b0+c0)/3.0_dp
       a = temp
       b = temp
       c = temp
       temp = (alpha0+beta0+gamma0)/3.0_dp
       alpha = temp
       beta = temp
       gamma = temp
    else if (case==3) then
       temp = (a0+b0+c0)/3.0_dp
       a = temp
       b = temp
       c = temp
       alpha = pi/2.0_dp
       beta = pi/2.0_dp
       gamma= pi/2.0_dp
    else if (case==5) then
       temp = (a0+b0+c0)/3.0_dp
       a = temp
       b = temp
       c = temp
       alpha = 1.910633236249019_dp
       beta = 1.910633236249019_dp
       gamma = 1.910633236249019_dp
    else if (case==6) then
       temp = (a0+b0+c0)/3.0_dp
       a = temp
       b = temp
       c = temp
       temp = acos(((((a**2+b**2)/2.0_dp)-cos(gamma0)*a*c)/2.0_dp)/(b+c))
       alpha = temp
       beta = temp
       gamma = gamma0
    else if (case==7) then
       temp = (a0+b0+c0)/3.0_dp
       a = temp
       b = temp
       c = temp
       alpha = acos(((((a**2+b**2)/2.0_dp)-2*cos(gamma0)*a*c))/(b+c))
       temp = (beta0+gamma0)/2.0_dp
       beta = temp
       gamma = temp
    else if (case==8) then
       temp = (a0+b0+c0)/3.0_dp
       a = temp
       b = temp
       c = temp
       alpha = acos((((a**2+b**2)/2.0_dp)-cos(gamma0)*a*c-cos(beta0)*a*b)/(b*c))
       beta = beta0
       gamma = gamma0
    else if (case==9) then
       temp = (a0+b0)/2.0_dp
       a = temp
       b = temp
       c = c0
       alpha = acos((a*a)/(2*b*c))
       beta = acos((a*a)/(2*a*c))
       gamma = pi/3.0_dp
    else if (case==10) then
       temp = (a0+b0)/2.0_dp
       a = temp
       b = temp
       c = c0
       temp = (alpha0+beta0)/2.0_dp
       alpha = temp
       beta = temp
       gamma = gamma0
    else if (case==11) then
       temp = (a0+b0)/2.0_dp
       a = temp
       b = temp
       c = c0
       alpha = pi/2.0_dp
       beta = pi/2.0_dp
       gamma = pi/2.0_dp
    else if (case==12) then
       temp = (a0+b0)/2.0_dp
       a = temp
       b = temp
       c = c0
       alpha = pi/2.0_dp
       beta = pi/2.0_dp
       gamma = pi/3.0_dp
    else if (case==13) then
       temp = (a0+b0)/2.0_dp
       a = temp
       b = temp
       c = c0
       alpha = pi/2.0_dp
       beta = pi/2.0_dp
       gamma = gamma0
    else if (case==15) then
       temp = (a0+b0)/2.0_dp
       a = temp
       b = temp
       c = c0
       alpha = acos(-(a*a)/(2*b*c))
       beta = acos(-(a*a)/(2*a*c))
       gamma = pi/2.0_dp
    else if (case==16) then
       temp = (a0+b0)/2.0_dp
       a = temp
       b = temp
       c = c0
       gamma = pi/2.0_dp
       alpha = acos((((a*a+b*b)/2.0_dp-cos(gamma)*a*c)/2.0_dp)/(b*c))
       beta = acos((((a*a+b*b)/2.0_dp-cos(gamma)*a*c)/2.0_dp)/(a*c))
    else if (case==14) then
       temp = (a0+b0)/2.0_dp
       a = temp
       b = temp
       c = c0
       gamma = gamma0
       temp = (alpha0+beta0)/2.0_dp
       alpha = temp
       beta = temp
    else if (case==17) then
       temp = (a0+b0)/2.0_dp
       a = temp
       b = temp
       c = c0
       gamma = gamma0
       beta= beta0
       alpha = acos(((a*a+b*b)/2.0_dp-cos(gamma)*a*c-cos(beta)*a*b)/(b*c))
    else if (case==18) then
       temp = (c0+b0)/2.0_dp
       a = a0
       b = temp
       c = temp
       alpha = acos((a*a)/(4*b*c))
       beta = acos((a*a)/(2*a*c))
       gamma = acos((a*a)/(2*a*b))
    else if (case==19) then
       temp = (c0+b0)/2.0_dp
       a = a0
       b = temp
       c = temp
       alpha = alpha0
       beta = acos((a*a)/(2*a*c))
       gamma = acos((a*a)/(2*a*b))
    else if ((case==20) .or. (case==25)) then
       temp = (c0+b0)/2.0_dp
       a = a0
       b = temp
       c = temp
       alpha = alpha0
       temp = (beta0+gamma0)/2.0_dp
       beta = temp
       gamma = temp
    else if (case==21) then
       temp = (c0+b0)/2.0_dp
       a = a0
       b = temp
       c = temp
       alpha = pi/2.0_dp
       beta = pi/2.0_dp
       gamma = pi/2.0_dp
    else if (case==22) then
       temp = (c0+b0)/2.0_dp
       a = a0
       b = temp
       c = temp
       alpha = acos(-(b*b)/(2*b*c))
       beta = pi/2.0_dp
       gamma = pi/2.0_dp
    else if (case==23) then
       temp = (c0+b0)/2.0_dp
       a = a0
       b = temp
       c = temp
       alpha = alpha0
       beta = pi/2.0_dp
       gamma = pi/2.0_dp
    else if (case==24) then
       temp = (c0+b0)/2.0_dp
       a = a0
       b = temp
       c = temp
       beta = acos(-(a*a)/(3*a*c))
       gamma = acos(-(a*a)/(3*a*b))
       alpha = acos(((a*a+b*b)*2.0_dp -cos(gamma)*a*c-cos(beta)*a*b)/(b*c))
    else if (case==26) then
       a = a0
       b = b0
       c = c0
       alpha = acos((a*a)/(4*b*c))
       beta = acos(-(a*a)/(2*a*c))
       gamma = acos(-(a*a)/(2*a*b))
    else if (case==27) then
       a = a0
       b = b0
       c = c0
       alpha = alpha0
       beta = acos(-(a*a)/(2*a*c))
       gamma = acos(-(a*a)/(2*a*b))
    else if (case==28) then
       a = a0
       b = b0
       c = c0
       alpha = alpha0
       beta = acos(-(a*a)/(2*a*c))
       gamma = acos((2*cos(alpha)*b*c)/(a*b))
    else if (case==29) then
       a = a0
       b = b0
       c = c0
       alpha = alpha0
       beta = acos((2*cos(alpha)*b*c)/(a*c))
       gamma = acos((a*a)/(2*a*b))
    else if (case==30) then
       a = a0
       b = b0
       c = c0
       alpha = acos((b*b)/(2*b*c))
       beta = beta0
       gamma = acos(2*cos(beta)*a*c/(a*b))
    else if ((case==31) .or. (case==44)) then
       a = a0
       b = b0
       c = c0
       alpha = alpha0
       beta = beta0
       gamma = gamma0
    else if (case==32) then
       a = a0
       b = b0
       c = c0
       alpha = pi/2.0_dp
       beta = pi/2.0_dp
       gamma = pi/2.0_dp
    else if (case==40) then
       a = a0
       b = b0
       c = c0
       alpha = acos(-(b*b)/(2*b*c))
       beta = pi/2.0_dp
       gamma = pi/2.0_dp
    else if (case==35) then
       a = a0
       b = b0
       c = c0
       alpha = alpha0
       beta = pi/2.0_dp
       gamma = pi/2.0_dp
    else if (case==36) then
       a = a0
       b = b0
       c = c0
       alpha = pi/2.0_dp
       beta = acos(-(a*a)/(2*a*c))
       gamma = pi/2.0_dp
    else if (case==33) then
       a = a0
       b = b0
       c = c0
       alpha = pi/2.0_dp
       beta = beta0
       gamma = pi/2.0_dp
    else if (case==38) then
       a = a0
       b = b0
       c = c0
       alpha = pi/2.0_dp
       beta = pi/2.0_dp
       gamma = acos(-(a*a)/(2*a*b))
    else if (case==34) then
       a = a0
       b = b0
       c = c0
       alpha = pi/2.0_dp
       beta = pi/2.0_dp
       gamma = gamma0
    else if (case==42) then
       a = a0
       b = b0
       c = c0
       alpha = acos(-(b*b)/(2*b*c))
       beta = acos(-(a*a)/(2*a*c))
       gamma = pi/2.0_dp

    else if (case==41) then
       a = a0
       b = b0
       c = c0
       alpha = acos(-(b*b)/(2*b*c))
       beta = beta0
       gamma = pi/2.0_dp
    else if (case==37) then
       a = a0
       b = b0
       c = c0
       alpha = alpha0
       beta = acos(-(a*a)/(2*a*c))
       gamma = pi/2.0_dp
     else if (case==39) then
       a = a0
       b = b0
       c = c0
       alpha = alpha0
       beta = pi/2.0_dp
       gamma = acos(-(a*a)/(2*a*b))
     else if (case==43) then
       a = a0
       b = b0
       c = c0
       gamma = gamma0
       beta = beta0
       temp = ((a*a+b*b)/2.0_dp)-cos(gamma)*a*c-cos(beta)*a*b
       if (equal(2*temp*cos(gamma)*a*b,b*b,eps)) then
          alpha = acos(temp/(b*c))
       else
          temp = (-(a*a+b*b)/2.0_dp)-cos(gamma)*a*c-cos(beta)*a*b
          alpha = acos(temp/(b*c))
       end if
    end if

    out_params(1) = a
    out_params(2) = b
    out_params(3) = c
    out_params(4) = alpha
    out_params(5) = beta
    out_params(6) = gamma
  end SUBROUTINE symmetrize

  !!Fixes a POSCAR so that it perfectly matches the expected
  !!symmetries.
  !!<parameter name="in_vecs" regular="true">The original lattice
  !!vectors.</parameter>
  !!<parameter name="case" regular="true">The niggli id for this
  !!lattice.</parameter>
  !!<paramter name="out_vecs" regular="true">The corrected lattice
  !!vectors.</parameter>
  !!<parameter name="eps_" regular="true">The floating point
  !!tollerance.</parameter>
  SUBROUTINE delint(in_vecs, case, out_vecs, eps_)
    real(dp), intent(in) :: in_vecs(3,3)
    integer, intent(in) :: case
    real(dp), intent(out) :: out_vecs(3,3)
    real(dp), optional, intent(in) :: eps_

    real(dp) :: eps
    real(dp) :: in_params(6), canonical_basis(3,3), rot_mat(3,3)
    real(dp) :: rot_test(3,3), cb_inv(3,3), ident(3,3), c_params(6)
    real(dp) :: fixed_basis(3,3)
    integer :: i

    ident = reshape((/1.0_dp,0.0_dp,0.0_dp, 0.0_dp,1.0_dp,0.0_dp, 0.0_dp,0.0_dp,1.0_dp/),(/3,3/))

    if (present(eps_)) then
       eps = eps_
    else
       eps = 1E-3
    end if

    call basis2cell(in_vecs, in_params)
    call cell2basis(in_params, canonical_basis)
    call matrix_inverse(canonical_basis, cb_inv)

    rot_mat = matmul(in_vecs, cb_inv)
    rot_test = matmul(rot_mat, transpose(rot_mat))
    if (.not. equal(rot_test, ident, eps)) then
       write(*,*) "Error generating rotation matrix in delinter."
       stop
    end if

    call symmetrize(in_params, case, c_params, eps)
    call cell2basis(c_params, fixed_basis)
    out_vecs = matmul(rot_mat, fixed_basis)

  end SUBROUTINE delint

end Module delinter


module m_stream
  ! no variables in this module
contains

  subroutine compute_stream_function(nx, ny, hx, hy, xmin, xmax, ymin, ymax, B, S)
    implicit none
    ! arguments
    integer, intent(in) :: nx, ny
    real, intent(in) :: hx, hy
    real, intent(in) :: xmin, xmax, ymin, ymax
    real, intent(in) :: B
    real, intent(out) :: S(:, :)
    ! local variables
    real, parameter :: pi = 3.141592653589793238462643383279502884
    real :: x = 0.0, y = 0.0
    integer :: i = 0, j = 0

    do concurrent (i=1:nx, j=1:ny)
      x = xmin + (i-1) * hx
      y = ymin + (j-1) * hy
      S(i, j) = B * sin((pi * x) / xmax) * sin((pi * y) / ymax)
    end do

  end subroutine compute_stream_function

  subroutine compute_velocity(S, hx, hy, vx, vy)
    implicit none
    ! arguments
    real, intent(in) :: hx, hy
    real, intent(in) :: S(:, :)
    real, intent(out) :: vx(:, :)
    real, intent(out) :: vy(:, :)
    ! local variables
    integer :: nx, ny
    nx = size(S, 1)
    ny = size(S, 2)

    ! Initialize vx and vy
    vx = 0.0
    vy = 0.0

    ! Compute velocity at each interior point using centered finite differences
    vx(2:nx-1, 2:ny-1) =  (S(2:nx-1, 3:ny) - S(2:nx-1, 1:ny-2)) / (2 * hy)
    vy(2:nx-1, 2:ny-1) = -(S(3:nx, 2:ny-1) - S(1:nx-2, 2:ny-1)) / (2 * hx)

  end subroutine compute_velocity

end module m_stream


! Sum square difference
!
! The sum of the squares of the first ten natural numbers is,
! 1^2 + 2^2 + ... + 10^2 = 385
!
! The square of the sum of the first ten natural numbers is,
! (1 + 2 + ... + 10)^2 = 55^2 = 3025
!
! Hence the difference between the sum of the squares of the first ten natural
! numbers and the square of the sum is 3025 - 385 = 2640.
!
! Find the difference between the sum of the squares of the first one hundred
! natural numbers and the square of the sum.
module Problem6

    implicit none
    private

    public :: solve
contains
    subroutine solve
        write (*, '(A)') 'Problem 6. Sum square difference.'

        write (*, '(A, I)') 'Difference 1: ', difference1()
    end subroutine

    function difference1()
        integer difference1
        integer sum
        integer square
        integer index

        ! initial values
        sum    = 0
        square = 0

        do concurrent (index = 1:100)
            ! the sum of the squares
            sum = sum + index ** 2

            ! the square of the sum
            square = square + index
        end do

        square = square ** 2

        difference1 = square - sum
    end function
end module


PROGRAM temp_conversion

!  Purpose:
!    To convert an input temperature from degrees Fahrenheit to
!    an output temperature in kelvins.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/03/06 -- S. J. Chapman        Original code
!

IMPLICIT NONE        ! Force explicit declaration of variables

! Data dictionary: declare variable types, definitions, & units
REAL :: temp_f       ! Temperature in degrees Fahrenheit
REAL :: temp_k       ! Temperature in kelvins

! Prompt the user for the input temperature.
WRITE (*,*) 'Enter the temperature in degrees Fahrenheit: '
READ  (*,*) temp_f

! Convert to kelvins.
temp_k = (5. / 9.) * (temp_f - 32.) + 273.15

! Write out the result.
WRITE (*,*) temp_f, ' degrees Fahrenheit = ', temp_k, ' kelvins'

! Finish up.
END PROGRAM temp_conversion


      SUBROUTINE resid(res,u,rhs,n)
      INTEGER n
      DOUBLE PRECISION res(n,n),rhs(n,n),u(n,n)
      INTEGER i,j
      DOUBLE PRECISION h,h2i
      h=1.d0/(n-1)
      h2i=1.d0/(h*h)
      do 12 j=2,n-1
        do 11 i=2,n-1
          res(i,j)=-h2i*(u(i+1,j)+u(i-1,j)+u(i,j+1)+u(i,j-1)-4.d0*u(i,
     *j))+rhs(i,j)
11      continue
12    continue
      do 13 i=1,n
        res(i,1)=0.d0
        res(i,n)=0.d0
        res(1,i)=0.d0
        res(n,i)=0.d0
13    continue
      return
      END

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


Module rocket_params_vars
  Implicit none
  integer, parameter :: no_eqs = 2
  real*8, parameter :: p_a = 101325.d0,  &
                         n = ... ,    &

                       ......

                      grav = 9.81d0,    &
                        pi = 4.*atan(1.d0), &
                    A_star = ...

  real :: p_c, p_c_dot, &
          r, r_dot, &
          p_c_old, r_old, &
          eta_crit

  contains

  Function f_cor()
   ! perimeter factor
   Implicit none
    real*8 :: f_cor, eta
     eta =  ...
     f_cor = 1.d0
     if( eta < ... )then
         f_cor = ...
     endif
   return
  End

  Function I_sp()
   ! specific impulse
   Implicit none
     real*8 :: I_sp
       I_sp = ...
     return
  End function

  Function ODEs( t ) result ( k )
   Implicit none
    real*8 :: t
    real*8, dimension( no_eqs ) :: k
     r_dot = a * p_c**n
     k( 1 ) =  ...
     k( 2 ) =  ...
   return
  End function

  Subroutine RK4( t, del_t )
   Implicit none
    integer, parameter :: no_stages = 4
    real*8 :: t, del_t
    real*8, dimension( no_eqs )  ::  k( no_stages, no_eqs )
!.. soln and slopes at interval beg
     p_c_old = p_c
     ...
     k( 1, : ) = ODEs( t )
!.. slopes at p_1 = 0.5
     p_c = p_c_old + 0.5d0 * ...
     ...
!.. slopes at p_2 = 0.5
     ...
!.. slopes at p_3 = 1.0
    ...
!.. update for end of interval
    ...
!.. update time
    ...
   return
  End subroutine

End module

Program Rocket_Perf
 Use rocket_params_vars
 Implicit none
 real*8 ::  V_c, ...
 real*8 ::  dt, time
 integer :: nstep = 0

 print*,'enter eta (fraction of effective propellant thickness beyond wich burn diminishes) : '
 read*, eta_crit

 print*,'enter time step size, dt [s] : '
 read*, dt

!.. initial params
  p_c =  ...    ! chamber pressure
  r = ...      ! chamber radius
  V_c = ...  ! chamber volume
  V_p = ...  ! propellant volume
  m_p = ...  ! propellant mass
  m_p_init = ...

  open( 1, file = 'rocket.dat',form='formatted')
  write(1,*)' "t [s]" "p_c [MPa]" ... '
  time = 0.d0
  nstep = 0

  do while(  m_p / m_p_init > 0.05d0 )

     nstep = nstep + 1

     ! update solution and time
     call RK4( ... )

     ! check chamber pressure... abort if p_c < p_a
     ...

     ! compute mass of propellant left
     ...

     ! print on screen and store soln
     if( nstep == 1 .or. mod(nstep,5)==0) &
        write(1,'(8(2x,e12.6))') time, p_c*1.d-6, ...
        write(*,'(8(a,e9.3))')' t = ',time,' s,   p_c = ', p_c*1d-6, ...

  enddo

  close(1)

  stop
End


!
!*******************************************************************************
!
subroutine gauss_quad(nt,kind,alpha,beta,x,w)
!
!*******************************************************************************
!
!  Discussion:
!
!  FORTRAN 90 subroutine to calculate abscissas and weights for Gauss-quadruature
!  for a wide range of orthogonal polynomials ortogonalized over a given range
!  [a,b] and weight function w(x).
!
!  Inputs:
!         nt    = Number of Gauss-quadruature points, [integer(kind = 4)]
!         kind  = Type of Quadrature rule,  [integer(kind = 4)]
!
!               = 1,   Legendre,             [-1,1],     w(x) = 1.0
!               = 2,   Associated Laguerre,  [0,inf],    w(x) = exp(-x)*x^alpha
!               = 3,   Hermite,              [-inf,inf], w(x) = exp(-x^2)
!               = 4,   Jacobi,               [-1,1],     w(x) = (1-x)^alpha*(1+x)^beta
!               = 5,   Chebyshev (Type I),   [-1,1],     w(x) = (1-x^2)^(-0.5)
!               = 6,   Chebyshev (type II),  [-1,1],     w(x) = (1-x^2)^(0.5)
!               = 7,   Gegenbauer,           [-1,1],     w(x) = (1-x^2)^(alpha-0.5)
!
!         alpha = Value of alpha, if needed, [real(kind = 8)]
!         beta  = Value of beta, if needed, [real(kind = 8)]
!
!   Outputs:
!         x(1:nt) = abscissas for Gauss-quadrature rule, [real(kind=8)]
!         w(1:nt) = weights for Gauss-quadrature rule, [real(kind=8)]
!
!   Note that Chebyshev Type II is a special case of Gegenbauer with alpha = 1
!
!   The algorithm is based on the three-term recurrence relation for each
!   polynomial. The terms are found for the normalized polynonmials, i.e.,
!
!   F(n,alpha,beta,x) = p(n,alpha,beta,x)/sqrt(N(n,alpha,beta)),
!
!   where n is the order of the polynomial, and p(n,alpha,beta) denotes
!   the standard textbook definition with p(0,alpha,beta) = 1.0, and
!   N(n,alpha,beta) is the norm integral defined as
!
!   N(n,alpha,beta) = int[a,b] dx w(x)*[p(n,alpha,beta,x)]^2.
!
!   The three-term recurrence relations can be written as (with fixed
!   alpha and beta)
!
!   a(n-1)*F(n-1,x) + b(n)*F(n,x) + a(n)*F(n+1,x) = x*F(n,x)
!
!   Using the notation
!   <g,p> = int[a,b] dx w(x)*g(x)*F(n,x).
!
!   b(n) = <x*F(n,alpha,beta),F(n,alpha,beta)>
!
!   The coefficients a(n) = k(n)/k(n+1)
!
!   where k(n) is the leading coefficient for F(n), that is
!
!   F(n) = k(n)*x^n + k(n-1)*x^(n-1) + ...
!
!   The abscicca x(k) is the kth eigenvalue of the tridigonal matrix
!
!   b(0)   a(0)      0      0      0                  0       0
!   a(0)   b(1)   a(1)      0      0                  0       0
!      0   a(1)   b(2)   a(2)      0                  0       0
!      0      0   a(2)   b(3)   a(3)                  0       0
!
!                                                b(n-1)  a(n-1)
!      0      0      0      0      0             a(n-1)    b(n)
!
!   The weights are obtained from the 1st component of the kth eigenvector,
!   vec(1,k), via:
!
!   w(k) = N(0,alpha,beta)*vec(1,k)^2/(sum_k vec(1,k)^2)
!
!   The eigenvalues and eigenvectors are obtained from a modified version of
!   the EISPACK routine tql2, named tri_eig
!
!   Dependencies:
!
!     Modules:
!
!        None
!
!     Subroutines:
!
!        jacobi_norm
!        tri_eig
!
!     External functions:
!
!       real(kind=8) :: poly_a
!       real(kind=8) :: poly_b
!       real(kind=8) :: poly_norm
!
!     MPI routines:
!
!        None
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL
!
!*******************************************************************************
!
   implicit none
   integer(kind=4), intent(in) :: nt, kind
   real(kind=8), intent(in) :: alpha, beta
   real(kind=8), intent(out) :: x(nt), w(nt)

   integer(kind=4) :: i, n
   real(kind=8) :: pi

   real(kind=8) :: xn, two_xn

   real(kind=8), allocatable :: d(:), e(:), z(:,:)
   real(kind=8) :: norm, int_norm
   integer(kind=4) :: ierror
!
!-----    External functions
!
   real(kind=8) :: poly_a
   real(kind=8) :: poly_b
   real(kind=8) :: poly_norm
!
!*******************************************************************************
!
   pi = 2.0d0*asin(1.0d0)
!
!----   Allocate and initalize arrays for the tri-diagonal matrix
!
   if(.not.allocated(d))allocate(d(nt))
   if(.not.allocated(e))allocate(e(nt))
   if(.not.allocated(z))allocate(z(nt,nt))
   d(1:nt) = 0.0d0
   e(1:nt) = 0.0d0
   z(1:nt,1:nt) = 0.0d0
!
!----   Set up tridiagonal matrix to be diagonalized for each integration type
!
   do i = 1, nt
      n = i - 1                           !   integer order of the polynomial, p(n,alpha,beta)
      xn = real(n,kind=8)
      two_xn = 2.0d0*xn
      d(i) = poly_b(n, kind, alpha, beta)
      if(i < nt)e(i+1)= poly_a(n, kind, alpha, beta)
      z(i,i) = 1.0d0
   end do
!
!   Find eigenvalues and eigenvectors of the tri-diagonal matrix
!
   call tri_eig(nt, nt, d, e, z, ierror)
!
!----    Find norm to set the weights
!
   norm = 0.0d0
   do i = 1, nt
      norm = norm + z(1,i)**2
   end do
!
!----    Set norm for the weights - integral with w(x)*[p(0,alpha,beta)]^2*dx
!
   int_norm = poly_norm(0,kind,alpha,beta)
!
!----   Put abscissas and weights into output arrays
!
   do i = 1, nt
      x(i) = d(i)
      w(i) = int_norm*z(1,i)**2/norm
   end do
!
!----   Delete temporary data
!
   if(allocated(d))deallocate(d)
   if(allocated(e))deallocate(e)
   if(allocated(z))deallocate(z)
!
!----   All done
!
   return
!
end subroutine gauss_quad
!
!*******************************************************************************
!
real(kind=8) function poly_b(n, kind, alpha, beta)
!
!*******************************************************************************
!
!  Discussion:
!
!  FORTRAN 90 function to calculate recurssion coefficient b(n), where
!   the three-term recurrence relations are written as (with fixed
!   alpha and beta) for the normalized orthogonal polynomials as:
!
!   a(n-1)*F(n-1,x) + b(n)*F(n,x) + a(n)*F(n+1,x) = x*F(n,x)
!
!  Inputs:
!         n     = order of the polynomial, [integer(kind = 4)]
!         kind  = Type of polynomial,  [integer(kind = 4)]
!
!               = 1,   Legendre,             [-1,1],     w(x) = 1.0
!               = 2,   Associated Laguerre,  [0,inf],    w(x) = exp(-x)*x^alpha
!               = 3,   Hermite,              [-inf,inf], w(x) = exp(-x^2)
!               = 4,   Jacobi,               [-1,1],     w(x) = (1-x)^alpha*(1+x)^beta
!               = 5,   Chebyshev (Type I),   [-1,1],     w(x) = (1-x^2)^(-0.5)
!               = 6,   Chebyshev (type II),  [-1,1],     w(x) = (1-x^2)^(0.5)
!               = 7,   Gegenbauer,           [-1,1],     w(x) = (1-x^2)^(alpha-0.5)
!
!         alpha = Value of alpha, if needed, [real(kind = 8)]
!         beta  = Value of beta, if needed, [real(kind = 8)]
!
!   Dependencies:
!
!     Modules:
!
!        None
!
!     Subroutines:
!
!        None
!
!     External functions:
!
!        None
!
!     MPI routines:
!
!        None
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL
!
!*******************************************************************************
!
    implicit none
    integer(kind=4), intent(in) :: n, kind
    real(kind=8), intent(in) :: alpha, beta
!--------------------------------------------------------------------
    real(kind=8) :: xn, two_xn, xLn
!*************************************************************************
    poly_b = 0.0d0
    xn = real(n,kind=8)
    two_xn = 2.0d0*xn
    if(kind == 1)then                       !   Legendre
       poly_b = 0.0d0
    elseif(kind == 2)then                   !   Associated Laguerre
       poly_b = two_xn + alpha + 1.0d0
    elseif(kind == 3)then                   !   Hermite
       poly_b = 0.0d0
    elseif(kind == 4)then                   !   Jacobi
       poly_b = 0.0d0
       if(n == 0 .and. abs(beta**2 - alpha**2) < 1.0d-10)return
       xLn = two_xn + alpha + beta
       poly_b = (beta**2 - alpha**2)/(xLn*(xLn+2.0d0))
    elseif(kind == 5)then                   !   Chebyshev (Type I)
       poly_b = 0.0d0
    elseif(kind == 6)then                   !   Chebyshev (Type II)
       poly_b = 0.0d0
    elseif(kind == 7)then                   !   Gegenbauer
       if(alpha < 1.0d0)stop 'Error in Gengenbauer polynomilas, alpha < 1'
       poly_b = 0.0d0
    end if
    return
end function poly_b
!
!*******************************************************************************
!
real(kind=8) function poly_a(n, kind, alpha, beta)
!
!*******************************************************************************
!
!  Discussion:
!
!  FORTRAN 90 function to calculate recurssion coefficient a(n), where
!   the three-term recurrence relations are written as (with fixed
!   alpha and beta) for the normalized orthogonal polynomials as:
!
!   a(n-1)*F(n-1,x) + b(n)*F(n,x) + a(n)*F(n+1,x) = x*F(n,x)
!
!  Inputs:
!         n     = order of the polynomial, [integer(kind = 4)]
!         kind  = Type of polynomial,  [integer(kind = 4)]
!
!               = 1,   Legendre,             [-1,1],     w(x) = 1.0
!               = 2,   Associated Laguerre,  [0,inf],    w(x) = exp(-x)*x^alpha
!               = 3,   Hermite,              [-inf,inf], w(x) = exp(-x^2)
!               = 4,   Jacobi,               [-1,1],     w(x) = (1-x)^alpha*(1+x)^beta
!               = 5,   Chebyshev (Type I),   [-1,1],     w(x) = (1-x^2)^(-0.5)
!               = 6,   Chebyshev (type II),  [-1,1],     w(x) = (1-x^2)^(0.5)
!               = 7,   Gegenbauer,           [-1,1],     w(x) = (1-x^2)^(alpha-0.5)
!
!         alpha = Value of alpha, if needed, [real(kind = 8)]
!         beta  = Value of beta, if needed, [real(kind = 8)]
!
!   Dependencies:
!
!     Modules:
!
!        None
!
!     Subroutines:
!
!        jacobi_norm
!        tri_eig
!
!     External functions:
!
!        real(kind=8) :: poly_norm
!
!     MPI routines:
!
!        None
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL
!
!*******************************************************************************
!
    implicit none
    integer(kind=4), intent(in) :: n, kind
    real(kind=8), intent(in) :: alpha, beta
!--------------------------------------------------------------------
    real(kind=8) :: xn, two_xn, XLn, temp
!---------   External functions
    real(kind=8) :: poly_norm
!*************************************************************************
!
    poly_a = 0.0d0
    xn = real(n,kind=8)
    two_xn = 2.0d0*xn
    if(kind == 1)then                       !   Legendre
       poly_a = (xn + 1.0d0)/sqrt((two_xn + 3.0d0)*(two_xn + 1.0d0))
    elseif(kind == 2)then                   !   Associated Laguerre
       poly_a = -sqrt((xn+1.0d0)*(xn+alpha+1.0d0))
    elseif(kind == 3)then                   !   Hermite
       poly_a = sqrt((xn + 1.0d0)/2.0d0)
    elseif(kind == 4)then                   !   Jacobi
       xLn = two_xn + alpha + beta
       temp = log_gamma(alpha + beta + two_xn + 1.0d0) + log_gamma(alpha + beta + xn + 2.0d0) -   &
              log_gamma(alpha + beta + xn + 1.0d0) - log_gamma(alpha + beta + two_xn + 3.0d0)
       temp = exp(temp)*2.0d0*(xn + 1.0d0)*sqrt(poly_norm(n+1,kind,alpha,beta)/poly_norm(n,kind,alpha,beta))
       poly_a = temp
    elseif(kind == 5)then                   !   Chebyshev (Type I)
       if(n == 0)then
          poly_a = 1.0d0/sqrt(2.0d0)
       else
          poly_a = 0.5d0
       end if
    elseif(kind == 6)then                   !   Chebyshev (Type II)
       poly_a = 0.5d0
    elseif(kind == 7)then                   !   Gegenbauer
       if(alpha < 1.0d0)stop 'Error in Gengenbauer polynomilas, alpha < 1'
       poly_a = 0.5d0*sqrt((xn+1.0d0)*(xn+2.0d0*alpha)/((xn+alpha)*(xn+alpha+1.0d0)))
    end if
    return
end function poly_a
!
!*******************************************************************************
!
real(kind=8) function poly_norm(n, kind, alpha, beta)
!
!*******************************************************************************
!
!  Discussion:
!
!  FORTRAN 90 function to calculate the normalization of orthogonal Polynomials
!
!   int[-1,1] w(x) [P(n,alpha,beta)]^2 dx
!  Inputs:
!         n     = order of the polynomial, [integer(kind = 4)]
!         kind  = Type of polynomial,  [integer(kind = 4)]
!
!               = 1,   Legendre,             [-1,1],     w(x) = 1.0
!               = 2,   Associated Laguerre,  [0,inf],    w(x) = exp(-x)*x^alpha
!               = 3,   Hermite,              [-inf,inf], w(x) = exp(-x^2)
!               = 4,   Jacobi,               [-1,1],     w(x) = (1-x)^alpha*(1+x)^beta
!               = 5,   Chebyshev (Type I),   [-1,1],     w(x) = (1-x^2)^(-0.5)
!               = 6,   Chebyshev (type II),  [-1,1],     w(x) = (1-x^2)^(0.5)
!               = 7,   Gegenbauer,           [-1,1],     w(x) = (1-x^2)^(alpha-0.5)
!
!         alpha = Value of alpha, if needed, [real(kind = 8)]
!         beta  = Value of beta, if needed, [real(kind = 8)]
!
!   Dependencies:
!
!     Modules:
!
!        None
!
!     Subroutines:
!
!        None
!
!     External functions:
!
!        None
!
!     MPI routines:
!
!        None
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL
!
!*******************************************************************************
!
    implicit none
    integer(kind=4), intent(in) :: n, kind
    real(kind=8), intent(in) :: alpha, beta
!--------------------------------------------------------------------
    real(kind=8) :: factor, xn, two_xn, pi
!*************************************************************************
!
    pi = 2.0d0*asin(1.0d0)
    poly_norm = 0.0d0
    xn = real(n,kind=8)
    two_xn = 2.0d0*xn
    if(kind == 1)then                       !   Legendre
       poly_norm = 2.0d0/(two_xn + 1.0d0)
    elseif(kind == 2)then                   !   Associated Laguerre
       poly_norm = exp(log_gamma(xn + alpha + 1.0d0) - log_gamma(xn + 1.0d0))
    elseif(kind == 3)then                   !   Hermite
       poly_norm = 2.0d0**xn*sqrt(pi)*exp(log_gamma(xn + 1.0d0))
    elseif(kind == 4)then                   !   Jacobi
       factor = log_gamma(xn + alpha + 1.0d0) + log_gamma(xn + beta + 1.0d0) -  &
                log_gamma(xn + 1.0d0) - log_gamma(xn + alpha + beta + 1.0d0)
       factor = factor + (alpha + beta + 1.0d0)*log(2.0d0) -                    &
                log(2.0d0*xn + alpha + beta + 1.0d0)
       poly_norm = exp(factor)
    elseif(kind == 5)then                   !   Chebyshev (Type I)
       if(n == 0)then
          poly_norm = pi
       else
          poly_norm = 0.5d0*pi
       end if
    elseif(kind == 6)then                   !   Chebyshev (Type II)
       poly_norm = 0.5d0*pi
    elseif(kind == 7)then                   !   Gegenbauer
       factor = log_gamma(xn + 2.0d0*alpha) - log_gamma(xn + 1.0d0) - 2.0d0*log_gamma(alpha)
       poly_norm = pi*2.0d0**(1.0d0 - 2.0d0*alpha)*exp(factor)/(xn + alpha)
    end if
    return
end function poly_norm
!
!*******************************************************************************
!
real(kind=8) function poly(n, kind, alpha, beta, x)
!
!*******************************************************************************
!
!  Discussion:
!
!  FORTRAN 90 function to calculate values at a given value of x for the
!   orthogonal polynomial p(n,alpha,beta,x).
!   Uses the three-term recurrence relation (with fixed
!   alpha and beta) for the normalized orthogonal polynomials F(n,alpha,beta,x) as:
!
!   a(n-1)*F(n-1,x) + b(n)*F(n,x) + a(n)*F(n+1,x) = x*F(n,x)
!
!   or
!
!   F(n) = ((x - b(n-1)*F(n-1)) - a(n-2)*F(n-2))/a(n-1)
!
!   with
!
!   F(n,alpha,beta,x) = p(n,alpha,beta,x)/sqrt(N(n,alpha,beta)),
!
!  Inputs:
!         n     = order of the polynomial, [integer(kind = 4)]
!         kind  = Type of polynomial,  [integer(kind = 4)]
!
!               = 1,   Legendre,             [-1,1],     w(x) = 1.0
!               = 2,   Associated Laguerre,  [0,inf],    w(x) = exp(-x)*x^alpha
!               = 3,   Hermite,              [-inf,inf], w(x) = exp(-x^2)
!               = 4,   Jacobi,               [-1,1],     w(x) = (1-x)^alpha*(1+x)^beta
!               = 5,   Chebyshev (Type I),   [-1,1],     w(x) = (1-x^2)^(-0.5)
!               = 6,   Chebyshev (type II),  [-1,1],     w(x) = (1-x^2)^(0.5)
!               = 7,   Gegenbauer,           [-1,1],     w(x) = (1-x^2)^(alpha-0.5)
!
!         alpha = Value of alpha, if needed, [real(kind = 8)]
!         beta  = Value of beta, if needed, [real(kind = 8)]
!
!   Dependencies:
!
!     Modules:
!
!        None
!
!     Subroutines:
!
!        None
!
!     External functions:
!
!        real(kind=8) :: poly_a
!        real(kind=8) :: poly_b
!        real(kind=8) :: poly_norm
!
!     MPI routines:
!
!        None
!
!  Licensing:
!
!    SPDX-License-Identifier: MIT
!
!  Date:
!
!    11 May 2021
!
!  Author:
!
!      Erich Ormand, LLNL
!
!*******************************************************************************
!
   implicit none
   integer(kind=4), intent(in) :: n, kind
   real(kind=8), intent(in) :: alpha, beta
   real(kind=8), intent(in) :: x
!----------------------------------------------------------------
   integer(kind=4) :: nn
   real(kind=8) :: p0, p1, p2
!
!-----    External functions
!
   real(kind=8) :: poly_a
   real(kind=8) :: poly_b
   real(kind=8) :: poly_norm
!
!*******************************************************************************
!
   p0 = 1.0d0
   p1 = 0.0d0
!---   If n=1, trivial, and exit
   poly = p0
   if(n == 0)return
   if(kind == 1)then
      p1 = x
   elseif(kind == 2)then
      p1 = (-x + alpha + 1.0d0)
   elseif(kind == 3)then
      p1 = 2.0d0*x
   elseif(kind == 4)then
      p1 = (alpha + 1.0d0) + (alpha + beta + 2.0d0)*0.5d0*(x-1.0d0)
   elseif(kind == 5)then
      p1 = x
   elseif(kind == 6)then
      p1 = 2.0d0*x
   elseif(kind == 7)then
      p1 = 2.0d0*alpha*x
   end if
!---   If n=1, trivial, and exit
   poly = p1
   if(n == 1)return
!---   First and second normalized polynomials
   p0 = p0/sqrt(poly_norm(0,kind,alpha,beta))
   p1 = p1/sqrt(poly_norm(1,kind,alpha,beta))
   p2 = 0.0d0
!---   Build up to n via recurrence relation
   do nn = 2, n
      p2 = (x - poly_b(nn-1,kind,alpha,beta))*p1 -            &
           poly_a(nn-2,kind,alpha,beta)*p0
      p2 = p2/poly_a(nn-1,kind,alpha,beta)
      p0 = p1
      p1 = p2
   end do
!---   Undo normalization and return
   poly = p2*sqrt(poly_norm(n,kind,alpha,beta))
   return
end function poly


C BACKWARD SUBSTITUTION

      SUBROUTINE SOLVE(N,A,IA,L,B,X)
      DIMENSION  A(IA,N),L(N),B(N),X(N)
      DO 3 K = 1,N-1
        DO 2 I = K+1,N
          B(L(I)) = B(L(I)) - A(L(I),K)*B(L(K))
   2    CONTINUE
   3  CONTINUE
      X(N) = B(L(N))/A(L(N),N)
      DO 5 I = N-1,1,-1
        SUM = B(L(I))
        DO 4 J = I+1,N
          SUM = SUM - A(L(I),J)*X(J)
   4    CONTINUE
        X(I) = SUM/A(L(I),I)
   5  CONTINUE
      RETURN
      END


      DOUBLE PRECISION FUNCTION WNORM(N,Z,XW)
      INTEGER N
      DOUBLE PRECISION Z(N), XW(N)
C     ------------------------------------------------------------
C
C*    Summary :
C
C     E N O R M : Return the norm to be used in exit (termination)
C                 criteria
C
C*    Input parameters
C     ================
C
C     N         Int Number of equations/unknowns
C     Z(N)     Dble  The vector, of which the norm is to be computed
C     XW(N)    Dble  The scaling values of Z(N)
C
C*    Output
C     ======
C
C     WNORM(N,Z,XW)  Dble  The mean square root norm of Z(N) subject
C                          to the scaling values in XW(N):
C                          = Sqrt( Sum(1,...N)((Z(I)/XW(I))**2) / N )
C
C     ------------------------------------------------------------
C*    End Prologue
      INTEGER I
      DOUBLE PRECISION S
C*    Begin
      S = 0.0D0
      DO 10 I=1,N
        S = S + ( Z(I)/XW(I) ) ** 2
10    CONTINUE
      WNORM = DSQRT( S / DBLE(FLOAT(N)) )
C     End of function WNORM
      RETURN
      END


REAL*8 function kern_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
kern_num = cos(sqrt((y_a - y_b)**2/ly**2 + (x_a - x_b)**2/lx**2))
end function
REAL*8 function dkdx_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdx_num = -(x_a - x_b)*sin(sqrt((lx**2*(y_a - y_b)**2 + ly**2*(x_a - &
      x_b)**2)/(lx**2*ly**2)))/(lx**2*sqrt((lx**2*(y_a - y_b)**2 + ly** &
      2*(x_a - x_b)**2)/(lx**2*ly**2)))
end function
REAL*8 function dkdy_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdy_num = -(y_a - y_b)*sin(sqrt((lx**2*(y_a - y_b)**2 + ly**2*(x_a - &
      x_b)**2)/(lx**2*ly**2)))/(ly**2*sqrt((lx**2*(y_a - y_b)**2 + ly** &
      2*(x_a - x_b)**2)/(lx**2*ly**2)))
end function
REAL*8 function dkdx0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdx0_num = (x_a - x_b)*sin(sqrt((lx**2*(y_a - y_b)**2 + ly**2*(x_a - &
      x_b)**2)/(lx**2*ly**2)))/(lx**2*sqrt((lx**2*(y_a - y_b)**2 + ly** &
      2*(x_a - x_b)**2)/(lx**2*ly**2)))
end function
REAL*8 function dkdy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
dkdy0_num = (y_a - y_b)*sin(sqrt((lx**2*(y_a - y_b)**2 + ly**2*(x_a - &
      x_b)**2)/(lx**2*ly**2)))/(ly**2*sqrt((lx**2*(y_a - y_b)**2 + ly** &
      2*(x_a - x_b)**2)/(lx**2*ly**2)))
end function
REAL*8 function d2kdxdx0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d2kdxdx0_num = ly**2*(lx**2*ly**2*sqrt((lx**2*(y_a - y_b)**2 + ly**2*( &
      x_a - x_b)**2)/(lx**2*ly**2))*(-(x_a - x_b)**2 + (lx**2*(y_a - &
      y_b)**2 + ly**2*(x_a - x_b)**2)/ly**2)*sin(sqrt((lx**2*(y_a - y_b &
      )**2 + ly**2*(x_a - x_b)**2)/(lx**2*ly**2))) + (x_a - x_b)**2*(lx &
      **2*(y_a - y_b)**2 + ly**2*(x_a - x_b)**2)*cos(sqrt((lx**2*(y_a - &
      y_b)**2 + ly**2*(x_a - x_b)**2)/(lx**2*ly**2))))/(lx**2*(lx**2*( &
      y_a - y_b)**2 + ly**2*(x_a - x_b)**2)**2)
end function
REAL*8 function d2kdydy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d2kdydy0_num = lx**2*(lx**2*ly**2*sqrt((lx**2*(y_a - y_b)**2 + ly**2*( &
      x_a - x_b)**2)/(lx**2*ly**2))*(-(y_a - y_b)**2 + (lx**2*(y_a - &
      y_b)**2 + ly**2*(x_a - x_b)**2)/lx**2)*sin(sqrt((lx**2*(y_a - y_b &
      )**2 + ly**2*(x_a - x_b)**2)/(lx**2*ly**2))) + (y_a - y_b)**2*(lx &
      **2*(y_a - y_b)**2 + ly**2*(x_a - x_b)**2)*cos(sqrt((lx**2*(y_a - &
      y_b)**2 + ly**2*(x_a - x_b)**2)/(lx**2*ly**2))))/(ly**2*(lx**2*( &
      y_a - y_b)**2 + ly**2*(x_a - x_b)**2)**2)
end function
REAL*8 function d2kdxdy0_num(x_a, y_a, x_b, y_b, lx, ly)
implicit none
REAL*8, intent(in) :: x_a
REAL*8, intent(in) :: y_a
REAL*8, intent(in) :: x_b
REAL*8, intent(in) :: y_b
REAL*8, intent(in) :: lx
REAL*8, intent(in) :: ly
d2kdxdy0_num = (x_a - x_b)*(y_a - y_b)*(cos(sqrt((y_a - y_b)**2/ly**2 + &
      (x_a - x_b)**2/lx**2))/((y_a - y_b)**2/ly**2 + (x_a - x_b)**2/lx &
      **2) - sin(sqrt((y_a - y_b)**2/ly**2 + (x_a - x_b)**2/lx**2))/(( &
      y_a - y_b)**2/ly**2 + (x_a - x_b)**2/lx**2)**(3.0d0/2.0d0))/(lx** &
      2*ly**2)
end function


SUBROUTINE calc_hypotenuse ( side_1, side_2, hypotenuse )
!
!  Purpose:
!    To calculate the hypotenuse of a right triangle from the two
!    other sides.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/18/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare calling parameter types & definitions
REAL, INTENT(IN) :: side_1        ! Length of side 1
REAL, INTENT(IN) :: side_2        ! Length of side 2
REAL, INTENT(OUT) :: hypotenuse   ! Length of hypotenuse

! Data dictionary: declare local variable types & definitions
REAL :: temp                      ! Temporary variable

! Calculate hypotenuse
temp = side_1**2 + side_2**2
hypotenuse = SQRT ( temp )

END SUBROUTINE calc_hypotenuse


SUBROUTINE polint(xa,ya,n,x,y,dy)
INTEGER*4 n,NMAX
REAL*8 dy,x,y,xa(n),ya(n)
PARAMETER (NMAX=10)
INTEGER*4 i,m,ns
REAL*8 den,dif,dift,ho,hp,w,c(NMAX),d(NMAX)
ns=1
dif=abs(x-xa(1))
do i=1,n
	dift=abs(x-xa(i))
	if (dift.lt.dif) then
          ns=i
          dif=dift
	endif
	c(i)=ya(i)
	d(i)=ya(i)
enddo
y=ya(ns)
ns=ns-1
do m=1,n-1
	do i=1,n-m
          ho=xa(i)-x
          hp=xa(i+m)-x
          w=c(i+1)-d(i)
          den=ho-hp
          if(den.eq.0.)pause 'failure in polint'
          den=w/den
          d(i)=hp*den
          c(i)=ho*den
	enddo
	if (2*ns.lt.n-m)then
          dy=c(ns+1)
  	else
          dy=d(ns)
          ns=ns-1
	endif
	y=y+dy
enddo
return
END


*=======================================================================
* RSORT - sort a list of integers by the Radix Sort algorithm
* Public domain.  This program may be used by any person for any purpose.
* Origin:  Herman Hollerith, 1887
*
*___Name____Type______In/Out____Description_____________________________
*   IX(N)   Integer   Both      Array to be sorted in increasing order
*   IW(N)   Integer   Neither   Workspace
*   N       Integer   In        Length of array
*
* ASSUMPTIONS:  Bits in an INTEGER is an even number.
*               Integers are represented by twos complement.
*
* NOTE THAT:  Radix sorting has an advantage when the input is known
*             to be less than some value, so that only a few bits need
*             to be compared.  This routine looks at all the bits,
*             and is thus slower than Quicksort.
*=======================================================================
      SUBROUTINE RSORT (IX, IW, N)
       IMPLICIT NONE
       INTEGER IX, IW, N
       DIMENSION IX(N), IW(N)

       INTEGER I,                        ! count bits
     $         ILIM,                     ! bits in an integer
     $         J,                        ! count array elements
     $         P1OLD, P0OLD, P1, P0,     ! indices to ones and zeros
     $         SWAP
       LOGICAL ODD                       ! even or odd bit position

*      IF (N < 2) RETURN      ! validate
*
        ILIM = Bit_size(i)    !Get the fixed number of bits
*=======================================================================
* Alternate between putting data into IW and into IX
*=======================================================================
       P1 = N+1
       P0 = N                ! read from 1, N on first pass thru
       ODD = .FALSE.
       DO I = 0, ILIM-2
         P1OLD = P1
         P0OLD = P0         ! save the value from previous bit
         P1 = N+1
         P0 = 0                 ! start a fresh count for next bit

         IF (ODD) THEN
           DO J = 1, P0OLD, +1             ! copy data from the zeros
             IF ( BTEST(IW(J), I) ) THEN
               P1 = P1 - 1
               IX(P1) = IW(J)
             ELSE
               P0 = P0 + 1
               IX(P0) = IW(J)
             END IF
           END DO
           DO J = N, P1OLD, -1             ! copy data from the ones
             IF ( BTEST(IW(J), I) ) THEN
               P1 = P1 - 1
               IX(P1) = IW(J)
             ELSE
               P0 = P0 + 1
              IX(P0) = IW(J)
             END IF
           END DO

         ELSE
           DO J = 1, P0OLD, +1             ! copy data from the zeros
             IF ( BTEST(IX(J), I) ) THEN
               P1 = P1 - 1
               IW(P1) = IX(J)
              ELSE
               P0 = P0 + 1
               IW(P0) = IX(J)
             END IF
           END DO
           DO J = N, P1OLD, -1            ! copy data from the ones
             IF ( BTEST(IX(J), I) ) THEN
               P1 = P1 - 1
               IW(P1) = IX(J)
             ELSE
               P0 = P0 + 1
               IW(P0) = IX(J)
             END IF
          END DO
         END IF  ! even or odd i

         ODD = .NOT. ODD
       END DO  ! next i

*=======================================================================
*        the sign bit
*=======================================================================
       P1OLD = P1
       P0OLD = P0
       P1 = N+1
       P0 = 0

*          if sign bit is set, send to the zero end
       DO J = 1, P0OLD, +1
         IF ( BTEST(IW(J), ILIM-1) ) THEN
           P0 = P0 + 1
           IX(P0) = IW(J)
         ELSE
           P1 = P1 - 1
           IX(P1) = IW(J)
         END IF
       END DO
       DO J = N, P1OLD, -1
         IF ( BTEST(IW(J), ILIM-1) ) THEN
           P0 = P0 + 1
           IX(P0) = IW(J)
         ELSE
           P1 = P1 - 1
           IX(P1) = IW(J)
         END IF
       END DO

*=======================================================================
*       Reverse the order of the greater value partition
*=======================================================================
       P1OLD = P1
       DO J = N, (P1OLD+N)/2+1, -1
         SWAP = IX(J)
         IX(J) = IX(P1)
         IX(P1) = SWAP
         P1 = P1 + 1
       END DO
       RETURN
      END ! of RSORT

***********************************************************************
*         test program
***********************************************************************
      PROGRAM t_sort
       IMPLICIT NONE
       INTEGER I, N
       PARAMETER (N = 11)
       INTEGER IX(N), IW(N)
       LOGICAL OK

       DATA IX / 2, 24, 45, 0, 66, 75, 170, -802, -90, 1066, 666 /

       PRINT *, 'before: ', IX
       CALL RSORT (IX, IW, N)
       PRINT *, 'after: ', IX

*              compare
       OK = .TRUE.
       DO I = 1, N-1
         IF (IX(I) > IX(I+1)) OK = .FALSE.
       END DO
       IF (OK) THEN
         PRINT *, 't_sort: successful test'
       ELSE
         PRINT *, 't_sort: failure!'
       END IF
      END ! of test program


      subroutine great_circle(alat1,alon1,alat2,alon2,gcdist,gcbearing)

!     http://www.dtcenter.org/met/users/docs/write_ups/gc_simple.pdf

!     solve for bearing of location 2 as seen from location 1
!     north/up is zero bearing with angles counted clockwise
!     angles are in radians

      hav(x) = sin(x/2.)**2
      hav_inv(x) = 2. * asin(sqrt(x))

      pi = 3.14159265
      rpd = pi / 180.

      phia = alat1 * rpd
      phib = alat2 * rpd
      deltal = (alon1 - alon2) * rpd

      s = cos(phib) * sin(deltal)
      c = cos(phia) * sin(phib) - sin(phia) * cos(phib) * cos(deltal)

      beta = atan2(s,c)
      gcbearing = beta / rpd

      hav_theta = hav(phia-phib) + cos(phia) * cos(phib) * hav(deltal)
      theta = hav_inv(hav_theta)
      gcdist = theta / rpd

      return
      end


SUBROUTINE loc_to_glob(local,global,gamma,coord)
!
! This subroutine transforms the local end reactions and
! moments into the global system (3-d).
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::local(:),gamma,coord(:,:)
 REAL(iwp),INTENT(OUT)::global(:)
 REAL(iwp)::t(12,12),r0(3,3),x1,x2,y1,y2,z1,z2,xl,yl,zl,pi,gamrad,cg,sg,  &
   den,ell,x,sum,zero=0.0_iwp,one=1.0_iwp,d180=180.0_iwp
 INTEGER::i,j,k
 x1=coord(1,1)
 y1=coord(1,2)
 z1=coord(1,3)
 x2=coord(2,1)
 y2=coord(2,2)
 z2=coord(2,3)
 xl=x2-x1
 yl=y2-y1
 zl=z2-z1
 ell=SQRT(xl*xl+yl*yl+zl*zl)
 t=zero
 pi=ACOS(-one)
 gamrad=gamma*pi/d180
 cg=COS(gamrad)
 sg=SIN(gamrad)
 den=ell*SQRT(xl*xl+zl*zl)
 IF(den/=zero)THEN
   r0(1,1)=xl/ell
   r0(2,1)=yl/ell
   r0(3,1)=zl/ell
   r0(1,2)=(-xl*yl*cg-ell*zl*sg)/den
   r0(2,2)=den*cg/(ell*ell)
   r0(3,2)=(-yl*zl*cg+ell*xl*sg)/den
   r0(1,3)=(xl*yl*sg-ell*zl*cg)/den
   r0(2,3)=-den*sg/(ell*ell)
   r0(3,3)=(yl*zl*sg+ell*xl*cg)/den
 ELSE
   r0(1,1)=zero
   r0(3,1)=zero
   r0(2,2)=zero
   r0(2,3)=zero
   r0(2,1)=one
   r0(1,2)=-cg
   r0(3,3)=cg
   r0(3,2)=sg
   r0(1,3)=sg
 END IF
 DO i=1,3
   DO j=1,3
     x=r0(i,j)
     DO k=0,9,3
       t(i+k,j+k)=x
     END DO
   END DO
 END DO
 DO i=1,12
   sum=zero
   DO j=1,12
     sum=sum+t(i,j)*local(j)
   END DO
   global(i)=sum
 END DO
RETURN
END SUBROUTINE loc_to_glob


module loglikelihood_module
    use utils_module, only: dp

    contains

    !> Upside down [Himmelblau function](http://en.wikipedia.org/wiki/Himmelblaus_function).
    !!
    !! \f[ -\log L(x, y) = (x^2+y-11)^2 + (x+y^2-7)^2 \f]
    !!
    !! Himmelblau's function is a multi-modal function, used to test the performance of
    !! optimization  algorithms.
    !! It has one local maximum at <math>x = -0.270845 \,</math> and <math>y =
    !! -0.923039 \,</math> where <math>f(x,y) = 181.617 \,</math>, and four
    !! identical local minima:
    !! * \f$ f(3.0, 2.0) = 0.0,            \f$
    !! * \f$ f(-2.805118, 3.131312) = 0.0, \f$
    !! * \f$ f(-3.779310, -3.283186) = 0.0,\f$
    !! * \f$ f(3.584428, -1.848126) = 0.0. \f$
    !!
    !! The locations of all the Maxima and minima can be found
    !! analytically. However, because they are roots of cubic polynomials, when
    !! written in terms of radicals, the expressions are somewhat
    !! complicated.
    !!
    !! The function is named after David Mautner Himmelblau (1924-2011), who
    !! introduced it.
    !!
    !! Note that this is a 2D function, and should hence only be used for settings%nDims=2
    !!
    function loglikelihood(theta,phi)
        implicit none
        real(dp), intent(in),  dimension(:) :: theta         !> Input parameters
        real(dp), intent(out), dimension(:) :: phi           !> Output derived parameters
        real(dp)                            :: loglikelihood ! loglikelihood value to output

        ! Normalisation
        loglikelihood = -log(0.4071069421432255d0)

        ! Evaluate
        loglikelihood =  loglikelihood  -  (theta(1)**2 + theta(2)- 11d0)**2    -   (theta(1)+theta(2)**2-7d0)**2

    end function loglikelihood

    subroutine setup_loglikelihood(settings)
        use settings_module,   only: program_settings
        implicit none
        type(program_settings), intent(in) :: settings

    end subroutine setup_loglikelihood

end module loglikelihood_module


!--------------------------------------------------
!..Homework 2 Bonus
!..Team 31
!..AE305 - Numerical Methods
!
!..This program calculates the chamber pressure,
!..burn rate and specific impulse for given rocket
!..using RK4 method with adaptive time step and
!..outputs results to a file.
!--------------------------------------------------
Module rocket_params_vars_bonus
  Implicit none
  integer, parameter :: no_eqs = 2
  real*8, parameter :: p_a = 101325.d0, &
                     rho_p = 1140.d0, &
                         n = 0.305d0, &
                         a = 0.0000555d0, &
                       r_0 = 0.05d0, &
                       r_f = 0.15d0, &
                         L = 1.25d0, &
                       T_c = 2810.d0, &
                     R_cst = 365.d0, &
                      gama = 1.25d0, &
                      grav = 9.81d0, &
                        pi = 4.*atan(1.d0)
  real*8 :: p_c, p_c_dot, &
          r, r_dot, &
          A_star

  contains

  Function m_n_dot(p_c_)
    ! calculate m_n dot to use in ODE
    real*8 :: m_n_dot, p_c_
    m_n_dot = p_c_*A_star*sqrt(gama/(R_cst*T_c))*((gama+1)/2)**(-(gama+1)/(2*(gama-1)))
    return
  End Function m_n_dot

  Function rho_c(p_c_)
    ! calculate rho_c to use in ODE
    real*8 :: rho_c, p_c_
    rho_c = p_c_/(R_cst*T_c)
    return
  End Function rho_c

  Function f_cor(rad)
   ! perimeter factor
   Implicit none
    real*8 :: f_cor, eta, rad
     eta = (r_f-rad)/(r_f-r_0)
     f_cor = 1.d0
     if( eta < 0 )then
         f_cor = 0
     else if (eta <= 0.15)then
         f_cor = 1-exp(-7*eta)
     end if
   return
  End Function f_cor

  Function I_sp(p_c_)
   ! specific impulse
   Implicit none
    real*8 :: I_sp, p_c_
    ! Here, absolute of value inside square root is taken because
    ! there is really small error caused by numerical computing makes
    ! value inside of the square root negative for some intervals
    ! which results in runtime error. This negative value is so small
    ! that its practically zero. Therefore, absolute can be used without
    ! effecting accuracy of result. Using abs solved the runtime error.
    I_sp = (1/grav)*sqrt(abs(((2*gama*R_cst*T_c)/(gama-1))*(1-((p_a/p_c_)**((gama-1)/gama)))))
    return
  End function I_sp

  Function ODEs( p_c_ , r_) result ( k )
   Implicit none
    real*8 :: p_c_, r_
    real*8, dimension( no_eqs ) :: k
     r_dot = a*p_c_**n
     k( 1 ) =  r_dot
     k( 2 ) =  R_cst*T_c*(((f_cor(r_)*2* a * p_c_ ** n)/r_)*(rho_p-rho_c(p_c_))-m_n_dot(p_c_)/(pi*L*r_**2))
   return
  End function

  Subroutine RK4( t, del_t )
    Implicit none
    integer, parameter :: no_stages = 4
    real*8 :: t, del_t
    real*8, dimension( no_eqs )  ::  result(no_eqs)

    ! RK4 has to be calculated such that after the calculation
    ! p_c shouldn't change. Because rk4 is used first while trying
    ! to determine the step size. If p_c changes while calculating
    ! step size, calculation will be wrong. Therefore, in the bonus
    ! part, RK4 must be calculated in a different function, which
    ! does not change the inputs value. This is why this part of
    ! code is different than the main code.
    result = RK4_(p_c,r,del_t)

    r = result(1) ! r is updated
    p_c = result(2) ! p_c is updated

    t = t + del_t !time is updated
  return
 End subroutine

  function RK2(p_c_,r_,del_t) result(res)
    implicit none
    integer, parameter :: no_stages = 2
    real*8 ::  p_c_, del_t ,r_
    real*8, dimension( no_eqs )  ::  k( no_stages, no_eqs ) , res(no_eqs)
    k(1,:) = ODEs(p_c_ , r_)

    res(1) = r_ + 0.5d0 * del_t * k(1,1)
    res(2) = p_c_ + 0.5d0 * del_t * k(1,2)

    k(2,:) = ODEs(res(2), res(1))
    res(1) = r_ + k(2,1) * del_t
    res(2) = p_c_ + k(2,2) * del_t
    return
  end function

  function RK4_(p_c_, r_, del_t) result(res)
    implicit none
    integer, parameter :: no_stages = 4
    real*8 ::  p_c_, del_t ,r_
    real*8, dimension( no_eqs )  ::  k( no_stages, no_eqs ), phi(no_eqs), res(no_eqs)

    k(1,:) = ODEs(p_c_, r_)

    res(2) = p_c_ + 0.5d0 * del_t *k(1,2)
    res(1) = r_ + 0.5d0 * del_t * k(1,1)

    k(2,:) = ODEs(res(2), res(1))

    res(2) = p_c_ + 0.5d0 * del_t * k(2,2)
    res(1) = r_ + 0.5d0 * del_t * k(2,1)

    k(3,:) = ODEs(res(2), res(1))

    res(2) = p_c_ + del_t * k(3,2)
    res(1) = r_ +  del_t * k(3,1)

    k(4,:) = ODEs(res(2), res(1))

    phi(:) = (1.0/6)* (k(1, : )+2*k(2, : )+2*k(3, : )+k(4, : ))

    res(2) = p_c_ + phi(2) * del_t
    res(1) = r_ + phi(1) * del_t

    return
  end function
End module

Program Rocket_Perf
 Use rocket_params_vars_bonus
 Implicit none
 character*40 :: fname
 real*8 ::  dt, time, isp
 integer :: nstep = 0
 real*8 :: th_radius

 ! Variables for the bonus part
 real*8, parameter :: E_allowed = 0.0001 ! Allowed error for adaptive stepsize
 real*8 :: E_o
 real*8, dimension(no_eqs) :: dummyRK4(no_eqs), dummyRK2(no_eqs)

 write(*,'(a)') 'Enter throat radius in centimeters :'
 write(*,'(a)',advance='no') ':> '
 read*, th_radius

A_star = pi * (th_radius/100)**2

 print*,'enter the initial time step size, dt [s] : '
 read*, dt

!.. initial params
  p_c =  p_a    ! chamber pressure
  r = r_0      ! chamber radius
  isp = I_sp(p_c) ! Specific Impulse

  write(*,'(a)',advance='no')' Enter the output file name [rocket.dat]:>'
  read(*,'(a)') fname
  if( fname .eq. ' ') fname = 'rocket.dat'
  open(1 ,file=fname, form='formatted')
  write(1,*)' "t [s]" "p_c [MPa]" "I_sp[s]" "r_dot[m/s]"'

  time = 0.d0
  nstep = 0

  do while( p_c >= p_a )
    nstep = nstep + 1

    ! Dummy variables to hold temporary solutions for step size calculation
    dummyRK4 = RK4_(p_c,r,dt)
    dummyRK2 = RK2(p_c,r,dt)

    ! Calculate local truncation error
    E_o = (dummyRK4(2) - dummyRK2(2))/dummyRK4(2)

    ! Step size is updated
    dt = dt * (abs(E_allowed / E_o))**0.20d0

    ! update solution and time
    call RK4(time, dt)

    ! calculate isp
    isp = I_sp(p_c)

    ! print on screen and store soln
    if( nstep == 1 .or. mod(nstep,5)==0) &
      write(1,'(8(4x,e12.6))') time, p_c*1.d-6 ,isp, r_dot
      write(*,'(8(a,e9.3))')' t = ',time,' s,   p_c = ', p_c*1d-6,' MPa, I_sp = ', isp, ' s r_dot = ',r_dot,' m/s'
  enddo

  ! Print the interval number for bonus part
  write(*,*) 'Number of time intervals needed = ', nstep
  close(1)

  stop
End


module spline
  !
  ! Spline implementation according to Sormann,
  ! https://itp.tugraz.at/LV/sormann/NumPhysik/

  implicit none
  save

contains

    function spline_coeff(x, y)
    !
    ! returns spline coefficients
    !
    !! Input
    real(8) :: x(:), y(:)
    !! Output
    real(8) :: spline_coeff(size(x)-1,5)
    !! Variables
    integer :: n, info
    real(8) :: r(size(x)-1), h(size(x)-1),&
         dl(size(x)-3), d(size(x)-2), c(size(x)-2)

    n = size(x)

    h = x(2:) - x(1:n-1)
    r = y(2:) - y(1:n-1)

    dl = h(2:n-2)
    d = 2d0*(h(1:n-2)+h(2:))

    !print *,dl
    !print *,d

    c = 3d0*(r(2:)/h(2:)-r(1:n-2)/h(1:n-2))

    call dptsv(n-2, 1, d, dl, c, n-2, info)

    spline_coeff = 0d0
    spline_coeff(:,1)     = x(1:n-1)
    spline_coeff(:,2)     = y(1:n-1)
    spline_coeff(1,3)     = r(1)/h(1) - h(1)/3d0*c(1)
    spline_coeff(2:n-2,3) = r(2:n-2)/h(2:n-2)-h(2:n-2)/3d0*(c(2:n-2)+2*c(1:n-3))
    spline_coeff(n-1,3)   = r(n-1)/h(n-1)-h(n-1)/3d0*(2*c(n-2))
    spline_coeff(1,4)     = 0
    spline_coeff(2:,4)    = c
    spline_coeff(1,5)     = 1/(3*h(1))*c(1)
    spline_coeff(2:n-2,5) = 1/(3*h(2:n-2))*(c(2:n-2)-c(1:n-3))
    spline_coeff(n-1,5)   = 1/(3*h(n-1))*(-c(n-2))
  end function spline_coeff

  function spline_val_0(coeff, x)
    !
    ! returns spline values
    !
    !! Input
    real(8) :: x, coeff(:,:)
    !! Output
    real(8) :: spline_val_0(3)
    !! Variables
    real(8) :: z
    integer :: n, ju, jl, jm, j

    n = size(coeff,1)+1
    jl = 0
    ju = n

    do while (ju-jl > 1)
       jm = (jl+ju)/2
       if (x > coeff(jm,1)) then
          jl = jm
       else
          ju = jm
       end if
    end do

    j = jl
    if (j==0) j=1
    if (j==n) j=n-1

    z = x - coeff(j,1)
    spline_val_0(1) = ((coeff(j,5)*z+coeff(j,4))*z+coeff(j,3))*z+coeff(j,2)
    spline_val_0(2) = (3d0*coeff(j,5)*z+2d0*coeff(j,4))*z+coeff(j,3)
    spline_val_0(3) = 6d0*coeff(j,5)*z+2d0*coeff(j,4)
  end function spline_val_0

  function spline_val(coeff, x)
    !
    ! returns spline coefficients
    !
    !! Input
    real(8) :: x(:), coeff(:,:)
    !! Output
    real(8) :: spline_val(size(x),3)
    !! Variables
    integer :: k

    ! TODO: make this more efficient
    do k=1,size(x)
       spline_val(k,:) = spline_val_0(coeff, x(k))
    end do

  end function spline_val

end module spline


module distributions
  use nrtype
contains
  pure function radial_sine_dist(radius,angle)
    implicit none
    real(dp), intent(in), optional :: radius
    real(dp), intent(in), optional :: angle
    real(dp) radial_sine_dist
    radial_sine_dist = sin(radius)**2./radius**3.
  end function radial_sine_dist

  pure function radial_sine_cos_dist(radius,angle)
    implicit none
    real(dp), intent(in), optional :: radius
    real(dp), intent(in), optional :: angle
    real(dp) radial_sine_cos_dist
    radial_sine_cos_dist = sin(radius)**2.*cos(radius)**2./radius**3.
  end function radial_sine_cos_dist

  pure function radial_exp_decay_cos(radius,angle)
    implicit none
    real(dp), intent(in), optional :: radius
    real(dp), intent(in), optional :: angle
    real(dp) radial_exp_decay_cos
    radial_exp_decay_cos = cos(radius)**2.*exp(-radius)
  end function radial_exp_decay_cos

  pure function bivariate_gaussian(x, aux)
    implicit none
    real(dp), intent(in), optional :: x(:), aux(:)

    real(dp) :: bivariate_gaussian
    real(dp) :: sig_x_y, rho_fact, d_x_mu_x, d_y_mu_y

    ! Equivalence.
    ! x = x(1)
    ! y = x(2)
    ! rho = aux(1)
    ! mu_x = aux(2)
    ! mu_y = aux(3)
    ! sig_x = aux(4)
    ! sig_y = aux(5)

    sig_x_y = 1./aux(4)*aux(5)
    rho_fact = 1./(1-aux(1)**2.)
    d_x_mu_x = x(1)-aux(2)
    d_y_mu_y = x(2)-aux(3)

    bivariate_gaussian = 1./tau * sig_x_y * sqrt(rho_fact) * &
    exp( &
    - 0.5 * rho_fact * &
    ( &
      d_x_mu_x ** 2. / aux(4) ** 2. &
    + d_y_mu_y ** 2. / aux(5) ** 2. &
    - 2. * aux(1) * d_x_mu_x * d_y_mu_y / ( aux(4) * aux(5) ) &
    ) &
    )
  end function bivariate_gaussian
end module distributions