	FUNCTION PR_KNMH  ( sknt )
C************************************************************************
C* PR_KNMH								*
C*									*
C* This function computes SMPH from SKNT.  The following equation is	*
C* used:								*
C*									*
C*               SMPH = SKNT / 0.868976					*
C*									*
C* REAL PR_KNMH  ( SKNT )						*
C*									*
C* Input parameters:							*
C*	SKNT		REAL		Speed in knots			*
C*									*
C* Output parameters:							*
C*	PR_KNMH		REAL		Speed in miles/hour		*
C**									*
C* A. Hardy/GSC		 8/99		Copied from PR_KNMS		*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*      Check for missing data.
C
	IF  ( ERMISS ( sknt ) )  THEN
	    PR_KNMH = RMISSD
	  ELSE
	    PR_KNMH = sknt / 0.868976
	END IF
C*
	RETURN
	END


FUNCTION rnorm() RESULT( fn_val )

!   Generate a random normal deviate using the polar method.
!   Reference: Marsaglia,G. & Bray,T.A. 'A convenient method for generating
!              normal variables', Siam Rev., vol.6, 260-264, 1964.

IMPLICIT NONE
REAL  :: fn_val

! Local variables

REAL            :: u, sum
REAL, SAVE      :: v, sln
LOGICAL, SAVE   :: second = .FALSE.
REAL, PARAMETER :: one = 1.0, vsmall = TINY( one )

IF (second) THEN
! If second, use the second random number generated on last call

  second = .false.
  fn_val = v*sln

ELSE
! First call; generate a pair of random normals

  second = .true.
  DO
    CALL RANDOM_NUMBER( u )
    CALL RANDOM_NUMBER( v )
    u = SCALE( u, 1 ) - one
    v = SCALE( v, 1 ) - one
    sum = u*u + v*v + vsmall         ! vsmall added to prevent LOG(zero) / zero
    IF(sum < one) EXIT
  END DO
  sln = SQRT(- SCALE( LOG(sum), 1 ) / sum)
  fn_val = u*sln
END IF

RETURN
END FUNCTION rnorm


! computes using Simpson's method
program CompSimp
implicit none
double precision x0,xn,x,h,Simp,exact,diff,f
integer j,n,m
write(*,*) 'enter n (must be even)'
read(*,*) n
m=n/2
x0=0.d0
xn=1.d0
h=(xn-x0)/dfloat(n)
Simp=f(x0)+f(xn)
do j=1,m-1
  x=x0+dfloat(2*j)*h
  Simp=Simp+2.d0*f(x)
enddo
do j=1,m
  x=x0+dfloat(2*j-1)*h
  Simp=Simp+4.d0*f(x)
enddo
Simp=h/3.d0 *Simp
exact=0.528408
diff=dabs(Simp-exact)
write(*,*)'exact=',exact
write(*,*)'Simp=',Simp
write(*,*)'|Simp-exact|=',diff
stop
end program CompSimp

!!!! 0.63629436111989061883446424291635313615100026

function f(x)
double precision x,f
f=x**(-1/4) *dsin(x)
return
end function f


PROGRAM main

  USE mo_kind,          ONLY: i4, dp, sp
  USE mo_utils,         ONLY: ne
  USE mo_distributions, ONLY: laplace, laplace01, normal, normal01
  USE mo_distributions, ONLY: ep, ep01, sep, sep01
  USE mo_distributions, ONLY: st, st01, t, t01
  USE mo_distributions, ONLY: beta_den, gamma_pdf, weibull_pdf
  USE mo_functions,     ONLY: gamm
  use mo_ansi_colors,   only: color, c_red, c_green

  IMPLICIT NONE

  ! data
  INTEGER(i4), PARAMETER  :: nn = 10000

  REAL(dp)                :: out0, iloc, isig, ddat, ddat_beta, ddat_gamma, ddat_weibull
  REAL(dp), DIMENSION(nn) :: dat, dat_beta, dat_gamma, dat_weibull, out
  REAL(dp)                :: loc, sca, sig, xi, beta, nu
  REAL(dp)                :: dmean, dvar, dstd

  REAL(sp)                :: isloc, issig, dsat, dsat_beta, dsat_gamma, dsat_weibull
  REAL(sp), DIMENSION(nn) :: sat, sat_beta, sat_gamma, sat_weibull, sout
  REAL(sp)                :: sloc, ssca, ssig, sxi, sbeta, snu
  REAL(dp)                :: smean, svar, sstd

  INTEGER(i4) :: i
  LOGICAL     :: isgood, allgood

  Write(*,*) ''
  Write(*,*) 'Test mo_distributions.f90'

  allgood = .true.

  ! DP
  forall(i=1:nn) dat(i) = real(i,dp)/real(nn,dp)*300.0_dp - 150.0_dp
  ddat = dat(2)-dat(1)
  forall(i=1:nn) dat_beta(i) = real(i,dp)/real(nn,dp)
  ddat_beta = dat_beta(2)-dat_beta(1)
  forall(i=1:nn) dat_gamma(i) = real(i,dp)/real(nn,dp) * 20._dp
  ddat_gamma = dat_gamma(2)-dat_gamma(1)
  forall(i=1:nn) dat_weibull(i) = real(i,dp)/real(nn,dp) * 5._dp
  ddat_weibull = dat_weibull(2)-dat_weibull(1)

  loc  = 1.1_dp
  sca  = 2.2_dp
  sig  = 2.2_dp
  xi   = 3.3_dp
  beta = 0.5_dp
  nu   = 4.4_dp

  ! integral
  do i=1, 15
     isgood = .true.
     select case(i)
     case(1) ! Exponential Power
        iloc = loc
        isig = sig
        out = ep(dat, loc, beta=beta, sig=sig)
     case(2)
        iloc = 0.0_dp
        isig = 1.0_dp
        out = ep01(dat, beta)
     case(3)! Laplace
        iloc = loc
        isig = sig
        out = laplace(dat, loc, sig=sig)
     case(4)
        iloc = 0.0_dp
        isig = sqrt(2.0_dp)
        out = laplace01(dat)
     case(5) ! Normal
        iloc = loc
        isig = sig
        out = normal(dat, loc, sig=sig)
     case(6)
        iloc = 0.0_dp
        isig = 1.0_dp
        out = normal01(dat)
     case(7) ! Skew Exponential Power
        iloc = loc
        isig = sig
        out = sep(dat, loc, xi=xi, beta=beta, sig=sig)
     case(8)
        iloc = 0.0_dp
        isig = 1.0_dp
        out = sep01(dat, xi, beta)
     case(9) ! Skewed Student t
        iloc = loc
        isig = sig
        out = st(dat, nu, loc, xi=xi, sig=sig)
     case(10)
        iloc = 0.0_dp
        isig = sqrt(nu/(nu-2.0_dp))
        out = st01(dat, nu, xi)
     case(11) ! Student t
        iloc = loc
        isig = sig
        out = t(dat, nu, loc, sig=sig)
     case(12)
        iloc = 0.0_dp
        isig = sqrt(nu/(nu-2.0_dp))
        out = t01(dat, nu)
     case(13) ! beta distribution
        iloc = 0.5_dp
        isig = 0.1507556722888821_dp
        out = beta_den(dat_beta, a=5._dp, b=5._dp, l=0._dp, s=1._dp)
     case(14) ! gamma distribution
        iloc = 0.75_dp * 2._dp
        isig = sqrt(0.75_dp * 2._dp**2._dp)
        out = gamma_pdf(dat_gamma, c=0.75_dp, l=0._dp, s=2._dp)
     case(15) ! weibull distribution
        iloc = 1._dp * gamm(1._dp + 1._dp / 5._dp)
        isig = 1._dp * sqrt(gamm(1._dp + 2._dp / 5._dp) - gamm(1._dp + 1._dp / 5._dp)**2._dp )
        out = weibull_pdf(dat_weibull, c=5._dp, l=0._dp, s=1._dp)
     case default
        continue
     end select
     if (i .eq. 13) then
        dmean = sum(dat_beta * out * ddat_beta)
        dvar  = sum((dat_beta-dmean)**2 * out * ddat_beta)
     else if (i .eq. 14) then
        dmean = sum(dat_gamma * out * ddat_gamma)
        dvar  = sum((dat_gamma-dmean)**2 * out * ddat_gamma)
     else if (i .eq. 15) then
        dmean = sum(dat_weibull * out * ddat_weibull)
        dvar  = sum((dat_weibull-dmean)**2 * out * ddat_weibull)
     else
        dmean = sum(dat * out * ddat)
        dvar  = sum((dat-dmean)**2 * out * ddat)
     end if
     dstd  = sqrt(dvar)
     if (abs(dmean-iloc) > 1.0e-2_dp) isgood = .false.
     if (abs(dstd-isig) > 1.0e-2_dp) isgood = .false.
     allgood = allgood .and. isgood
     if (.not. isgood) write(*,*) 'mo_distributions integral DP failed: ', i, iloc, dmean, isig, dstd
  enddo

  ! normal vs normal01
  do i=1, 6
     isgood = .true.
     select case(i)
     case(1)
        out = ep(dat, beta=beta) - ep01(dat, beta)
     case(2)
        out = laplace(dat, 0.0_dp) - laplace01(dat)
     case(3)
        out = normal(dat, 0.0_dp, 1.0_dp) - normal01(dat)
     case(4)
        out = sep(dat, 0.0_dp, 1.0_dp, xi, beta) - sep01(dat, xi, beta)
     case(5)
        out = st(dat, nu, xi=xi) - st01(dat, nu, xi)
     case(6)
        out = t(dat, nu, sca=1.0_dp) - t01(dat, nu)
     case default
        continue
     end select
     if (any(ne(out, 0.0_dp))) isgood = .false.
     allgood = allgood .and. isgood
     if (.not. isgood) write(*,*) 'mo_distributions comparison 01 versions failed: ', i, out
  enddo

  ! transformation
  do i=1, 6
     isgood = .true.
     select case(i)
     case(1)
        out = ep(dat, loc, sca, beta) - ep((dat-loc)/sca, beta=beta)/sca
     case(2)
        out = laplace(dat, loc, sca) - laplace((dat-loc)/sca)/sca
     case(3)
        out = normal(dat, loc, sca) - normal((dat-loc)/sca)/sca
     case(4)
        out = sep(dat, loc, sca, xi=xi, beta=beta) - sep((dat-loc)/sca, xi=xi, beta=beta)/sca
     case(5)
        out = st(dat, nu, loc, sca, xi=xi) - st((dat-loc)/sca, nu, xi=xi)/sca
     case(6)
        out = t(dat, nu, loc, sca) - t((dat-loc)/sca, nu)/sca
     case default
        continue
     end select
     ! if (any(ne(out, 0.0_dp))) isgood = .false.
     if (any(abs(out) > 1.0e-15_dp)) isgood = .false.
     allgood = allgood .and. isgood
     if (.not. isgood) write(*,*) 'mo_distributions transformation 1D failed: ', i, maxval(abs(out))
  enddo

  ! transformation 0D
  do i=1, 6
     isgood = .true.
     select case(i)
     case(1)
        out0 = ep(0.5_dp, loc, sca, beta=beta) - ep((0.5_dp-loc)/sca, beta=beta)/sca
     case(2)
        out0 = laplace(0.5_dp, loc, sca) - laplace((0.5_dp-loc)/sca)/sca
     case(3)
        out0 = normal(0.5_dp, loc, sca) - normal((0.5_dp-loc)/sca)/sca
     case(4)
        out0 = sep(0.5_dp, loc, sca, xi=xi, beta=beta) - sep((0.5_dp-loc)/sca, xi=xi, beta=beta)/sca
     case(5)
        out0 = st(0.5_dp, nu, loc, sca, xi=xi) - st((0.5_dp-loc)/sca, nu, xi=xi)/sca
     case(6)
        out0 = t(0.5_dp, nu, loc, sca) - t((0.5_dp-loc)/sca, nu)/sca
     case default
        continue
     end select
     ! if (ne(out0, 0.0_dp)) isgood = .false.
     if (abs(out0) > 1.0e-15_dp) isgood = .false.
     allgood = allgood .and. isgood
     if (.not. isgood) write(*,*) 'mo_distributions transformation 0D failed: ', i, out0
  enddo

  ! ep/sep vs normal/laplace
  do i=1, 9
     isgood = .true.
     select case(i)
     case(1)
        out = ep(dat, 0.0_dp, 1.0_dp, 0.0_dp) - normal(dat, 0.0_dp, 1.0_dp)
     case(2)
        out = ep01(dat, beta=0.0_dp) - normal01(dat)
     case(3)
        out = sep(dat, 0.0_dp, 1.0_dp, 1.0_dp, 0.0_dp) - normal(dat, 0.0_dp, 1.0_dp)
     case(4)
        out = sep01(dat) - normal01(dat)
     case(5)
        out = ep(dat, 0.0_dp, 1.0_dp, 1.0_dp) - laplace(dat, 0.0_dp, sig=1.0_dp)
     case(6)
        out = ep(dat, 0.0_dp, 1.0_dp, 1.0_dp) - laplace(dat, 0.0_dp, 1.0_dp/sqrt(2.0_dp))
     case(7)
        out = ep(dat, 0.0_dp, sqrt(2.0_dp), 1.0_dp) - laplace(dat, 0.0_dp, 1.0_dp)
     case(8)
        out = sep(dat, 0.0_dp, 1.0_dp, 1.0_dp, 1.0_dp) - laplace(dat, 0.0_dp, sig=1.0_dp)
     case(9)
        out = sep(dat, 0.0_dp, sqrt(2.0_dp), 1.0_dp, 1.0_dp) - laplace(dat, 0.0_dp, 1.0_dp)
     case default
        continue
     end select
     if (any(abs(out) > 1.0e-10)) isgood = .false.
     allgood = allgood .and. isgood
     if (.not. isgood) write(*,*) 'mo_distributions ep/sep comparison to normal/laplace failed: ', i, out
  enddo

  ! skewed vs unskewed
  do i=1, 2
     isgood = .true.
     select case(i)
     case(1)
        out = sep(dat, loc, sca, 1.0_dp, beta) - ep(dat, loc, sca, beta)
     case(2)
        out = st(dat, nu, loc, sca, 1.0_dp) - t(dat, nu, loc, sca)
     case default
        continue
     end select
     if (any(abs(out) > 1.0e-10)) isgood = .false.
     allgood = allgood .and. isgood
     if (.not. isgood) write(*,*) 'mo_distributions skewed vs non-skewed failed: ', i, out
  enddo

  ! SP
  forall(i=1:nn) sat(i) = real(i,sp)/real(nn,sp)*300.0_sp - 150.0_sp
  dsat = sat(2)-sat(1)
  forall(i=1:nn) sat_beta(i) = real(i,sp)/real(nn,sp)
  dsat_beta = sat_beta(2)-sat_beta(1)
  forall(i=1:nn) sat_gamma(i) = real(i,sp)/real(nn,sp) * 20._sp
  dsat_gamma = sat_gamma(2)-sat_gamma(1)
  forall(i=1:nn) sat_weibull(i) = real(i,sp)/real(nn,sp) * 5._sp
  dsat_weibull = sat_weibull(2)-sat_weibull(1)

  sloc  = 1.1_sp
  ssca  = 2.2_sp
  ssig  = 2.2_sp
  sxi   = 3.3_sp
  sbeta = 0.5_sp
  snu   = 4.4_sp

  ! integral
  do i=1, 15
     isgood = .true.
     select case(i)
     case(1) ! Exponential Power
        isloc = sloc
        issig = ssig
        sout = ep(sat, sloc, beta=sbeta, sig=ssig)
     case(2)
        isloc = 0.0_sp
        issig = 1.0_sp
        sout = ep01(sat, sbeta)
     case(3)! Laplace
        isloc = sloc
        issig = ssig
        sout = laplace(sat, sloc, sig=ssig)
     case(4)
        isloc = 0.0_sp
        issig = sqrt(2.0_sp)
        sout = laplace01(sat)
     case(5) ! Normal
        isloc = sloc
        issig = ssig
        sout = normal(sat, sloc, ssca)
     case(6)
        isloc = 0.0_sp
        issig = 1.0_sp
        sout = normal01(sat)
     case(7) ! Skew Exponential Power
        isloc = sloc
        issig = ssig
        sout = sep(sat, sloc, xi=sxi, beta=sbeta, sig=ssig)
     case(8)
        isloc = 0.0_sp
        issig = 1.0_sp
        sout = sep01(sat, sxi, sbeta)
     case(9) ! Skewed Student t
        isloc = sloc
        issig = ssig
        sout = st(sat, snu, sloc, xi=sxi, sig=ssig)
     case(10)
        isloc = 0.0_sp
        issig = sqrt(snu/(snu-2.0_sp))
        sout = st01(sat, snu, sxi)
     case(11) ! Student t
        isloc = sloc
        issig = ssig
        sout = t(sat, snu, sloc, sig=ssig)
     case(12)
        isloc = 0.0_sp
        issig = sqrt(snu/(snu-2.0_sp))
        sout = t01(sat, snu)
     case(13) ! beta distribution
        isloc = 0.5_sp
        issig = 0.1507556722888821_sp
        sout = beta_den(sat_beta, a=5._sp, b=5._sp, l=0._sp, s=1._sp)
     case(14) ! gamma distribution
        isloc = 0.75_sp * 2._sp
        issig = sqrt(0.75_sp * 2._sp**2._sp)
        sout = gamma_pdf(sat_gamma, c=0.75_sp, l=0._sp, s=2._sp)
     case(15) ! weibull distribution
        isloc = 1._sp * gamm(1._sp + 1._sp / 5._sp)
        issig = 1._sp * sqrt(gamm(1._sp + 2._sp / 5._sp) - gamm(1._sp + 1._sp / 5._sp)**2._sp )
        sout = weibull_pdf(sat_weibull, c=5._sp, l=0._sp, s=1._sp)
     case default
        continue
     end select
     if (i .eq. 15) then
        smean = sum(sat_weibull * sout * dsat_weibull)
        svar  = sum((sat_weibull-smean)**2 * sout * dsat_weibull)
     else if (i .eq. 14) then
        smean = sum(sat_gamma * sout * dsat_gamma)
        svar  = sum((sat_gamma-smean)**2 * sout * dsat_gamma)
     else if (i .eq. 13) then
        smean = sum(sat_beta * sout * dsat_beta)
        svar  = sum((sat_beta-smean)**2 * sout * dsat_beta)
     else
        smean = sum(sat * sout * dsat)
        svar  = sum((sat-smean)**2 * sout * dsat)
     end if
     sstd  = sqrt(svar)
     if (abs(smean-isloc) > 1.0e-2_sp) isgood = .false.
     if (abs(sstd-issig) > 1.0e-2_sp) isgood = .false.
     allgood = allgood .and. isgood
     if (.not. isgood) write(*,*) 'mo_distributions integral SP failed: ', i, isloc, smean, issig, sstd
  enddo

  ! Finish
  allgood = allgood .and. isgood
  if (allgood) then
     write(*,*) 'mo_distributions ', color('o.k.', c_green)
  else
     write(*,*) 'mo_distributions ', color('failed!', c_red)
  endif

END PROGRAM main


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


	   subroutine est_orfdim(desdis,dia,cd)

   !!	This program estimates orifice dimensions based on
   !!	design discharge at different stages

       implicit none

	   real, intent(in) :: cd            !          |
       real, intent(in) :: desdis        !          |
	   real, intent(out) :: dia          !          |
	   real :: tempvar                   !          |
       real :: pi                        !          |

	   pi = 3.14159
	   tempvar = 0.6 * cd * pi * sqrt(9.81)
	   dia = (4.0 * desdis / tempvar) ** 0.4

	   return
	   end subroutine est_orfdim


!
!
!
 SUBROUTINE HARMO(LMAX, LON, LAT, ARMOY)
 USE SHTOOLS
 IMPLICIT NONE
!INTEGER, PARAMETER :: LLMAX=512, JJMAX=(LLMAX+1)*(LLMAX+2)/2
 INTEGER J, MJ, J_INDEX, LMAX
 COMPLEX*16 ARMOY(*)
 REAL*8 LON, LAT
 REAL*8, ALLOCATABLE :: PLM(:)
 REAL*8 COSDD, SINDD
 INTEGER :: JMAX
!
!
! Given longitude LON and latitude LAT  - in degrees - this routine computes
! *all* the 4-pi normalized complex harmonics $\cal Y_{lm}(\theta,\lambda)$,
! with \theta=colatitude and \lambda=longitude, to degree LMAX given. Uses
! the (modified) SHTOOLS Legendre functions by PlmBar (see Sbr PLMBAR_MOD).
! - Last modified by GS 12-14-2007 -
! - Modified by DM Apr 2019 -- dynamically allocate PLM
!
!
! ---- Tests the longitude and latitude bounds
!
  If(abs(lat)>90.) then
 	        Write(88,*) "Error in Sbr. HARMO: Latitude is out of range"
	 	Write(88,*) "The program will STOP ----------------"
 	        Write(* ,*) "Error in Sbr. HARMO: Latitude is out of range"
	 	Write(* ,*) "The program will STOP ----------------"
                call stop_config
	        Stop 1
  elseif (lon<0.or.lon>360.) then
 	        Write(88,*) "Error in Sbr. HARMO: Longitude is out of range"
	 	Write(88,*) "The program will STOP ----------------"
 	        Write(* ,*) "Error in Sbr. HARMO: Longitude is out of range"
	 	Write(* ,*) "The program will STOP ----------------"
                call stop_config
	        Stop 2
  Endif
!
!
! ---- Allocate temporary arrays
!
   JMAX=(LMAX+1)*(LMAX+2)/2
   ALLOCATE( PLM(JMAX) )
!
!
! ---- Builds the SHTOOLS Legendre functions, with Condon-Shortley phase
!
    CALL PLMBAR_MOD(LMAX, LAT, PLM)
!
!
! ---- Computes the 4-pi normalized Spherical Harmonics up to degree LMAX
!
    do j=1, j_index(lmax,lmax)
       	armoy(j) = plm(j)*cmplx(cosdd(float(mj(j))*lon),sindd(float(mj(j))*lon))
    enddo
!
!
! ---- Release memory
!
    DEALLOCATE( PLM )
!
END SUBROUTINE HARMO
!
!
!


module kinddefs
  integer, parameter :: doub_prec = kind(1.d0)
end module kinddefs
MODULE helpers
  use kinddefs
contains
  !deck @(#)gaussq.f 1.1 9/9/91
  ! Code converted using TO_F90 by Alan Miller
  ! Date: 2000-11-02  Time: 11:45:58
  SUBROUTINE gaussq(ckind, n, alpha, beta, kpts, endpts, b, t, w)
    !           this set of routines computes the nodes x(i) and weights
    !        c(i) for gaussian-type quadrature rules with pre-assigned
    !        nodes.  these are used when one wishes to approximate

    !                 integral (from a to b)  f(x) w(x) dx

    !                              n
    !        by                   sum c  f(x )
    !                             i=1  i    i

    !        here w(x) is one of six possible non-negative weight
    !        functions (listed below), and f(x) is the
    !        function to be integrated.  gaussian quadrature is particularly
    !        useful on infinite intervals (with appropriate weight
    !        functions), since then other techniques often fail.

    !           associated with each weight function w(x) is a set of
    !        orthogonal polynomials.  the nodes x(i) are just the zeroes
    !        of the proper n-th degree polynomial.

    !     input parameters

    !        ikind     an integer between 0 and 6 giving the type of
    !                 quadrature rule

    !        ikind = 0=  simpson's rule w(x) = 1 on (-1, 1) n must be odd.
    !        ikind = 1=  legendre quadrature, w(x) = 1 on (-1, 1)
    !        ikind = 2=  chebyshev quadrature of the first ikind
    !                   w(x) = 1/dsqrt(1 - x*x) on (-1, +1)
    !        ikind = 3=  chebyshev quadrature of the second ikind
    !                   w(x) = dsqrt(1 - x*x) on (-1, 1)
    !        ikind = 4=  hermite quadrature, w(x) = exp(-x*x) on
    !                   (-infinity, +infinity)
    !        ikind = 5=  jacobi quadrature, w(x) = (1-x)**alpha * (1+x)**
    !                   beta on (-1, 1), alpha, beta .gt. -1.
    !                   note= ikind=2 and 3 are a special case of this.
    !        ikind = 6=  generalized laguerre quadrature, w(x) = exp(-x)*
    !                   x**alpha on (0, +infinity), alpha .gt. -1

    !        n        the number of points used for the quadrature rule
    !        alpha    real(doub_prec) parameter used only for gauss-jacobi and gauss-
    !                 laguerre quadrature (otherwise use 0.).
    !        beta     real(doub_prec) parameter used only for gauss-jacobi quadrature--
    !                 (otherwise use 0.).
    !        kpts     (integer) normally 0, unless the left or right end-
    !                 point (or both) of the interval is required to be a
    !                 node (this is called gauss-radau or gauss-lobatto
    !                 quadrature).  then kpts is the number of fixed
    !                 endpoints (1 or 2).
    !        endpts   real(doub_prec) array of length 2.  contains the values of
    !                 any fixed endpoints, if kpts = 1 or 2.
    !        b        real(doub_prec) scratch array of length n

    !     output parameters (both arrays of length n)

    !        t        will contain the desired nodes x(1),,,x(n)
    !        w        will contain the desired weights c(1),,,c(n)

    !     subroutines required

    !        gbslve, classpol, and gbtql2 are provided. underflow may sometimes
    !        occur, but it is harmless if the underflow interrupts are
    !        turned off as they are on this machine.

    !     accuracy

    !        the routine was tested up to n = 512 for legendre quadrature,
    !        up to n = 136 for hermite, up to n = 68 for laguerre, and up
    !        to n = 10 or 20 in other cases.  in all but two instances,
    !        comparison with tables in ref. 3 showed 12 or more significant
    !        digits of accuracy.  the two exceptions were the weights for
    !        hermite and laguerre quadrature, where underflow caused some
    !        very small weights to be set to zero.  this is, of course,
    !        completely harmless.

    !     method

    !           the coefficients of the three-term recurrence relation
    !        for the corresponding set of orthogonal polynomials are
    !        used to form a symmetric tridiagonal matrix, whose
    !        eigenvalues (determined by the implicit ql-method with
    !        shifts) are just the desired nodes.  the first components of
    !        the orthonormalized eigenvectors, when properly scaled,
    !        yield the weights.  this technique is much faster than using a
    !        root-finder to locate the zeroes of the orthogonal polynomial.
    !        for further details, see ref. 1.  ref. 2 contains details of
    !        gauss-radau and gauss-lobatto quadrature only.

    !     references

    !        1.  golub, g. h., and welsch, j. h.,  calculation of gaussian
    !            quadrature rules,  mathematics of computation 23 (april,
    !            1969), pp. 221-230.
    !        2.  golub, g. h.,  some modified matrix eigenvalue problems,
    !            siam review 15 (april, 1973), pp. 318-334 (section 7).
    !        3.  stroud and secrest, gaussian quadrature formulas, prentice-
    !            hall, englewood cliffs, n.j., 1966.

    !     ..................................................................

    IMPLICIT REAL(DOUB_PREC) (a-h,o-z)
    CHARACTER (LEN=*), INTENT(IN)            :: ckind
    INTEGER, INTENT(IN)                      :: n
    REAL(DOUB_PREC), INTENT(IN)                     :: alpha
    REAL(DOUB_PREC), INTENT(IN)                     :: beta
    INTEGER, INTENT(IN)                      :: kpts
    REAL(DOUB_PREC), INTENT(IN)                         :: endpts(2)
    REAL(DOUB_PREC), INTENT(IN OUT)                     :: b(n)
    REAL(DOUB_PREC), INTENT(OUT)                        :: t(n)
    REAL(DOUB_PREC), INTENT(OUT)                        :: w(n)
    REAL(DOUB_PREC) :: muzero

    IF (ckind == 'simpson') THEN
       ikind=0
    ELSE IF(ckind == 'legendre') THEN
       ikind=1
    ELSE IF(ckind == 'chebyshev-1') THEN
       ikind=2
    ELSE IF(ckind == 'chebyshev-2') THEN
       ikind=3
    ELSE IF(ckind == 'hermite') THEN
       ikind=4
    ELSE IF(ckind == 'jacobi') THEN
       ikind=5
    ELSE IF(ckind == 'laguerre') THEN
       ikind=6
    ELSE
       stop
       !  CALL lnkerr('error in quadrature type')
    END IF
    IF(ikind == 0) THEN
       IF(2*(n/2) == n) THEN
          stop
          !    CALL lnkerr('n must be odd for simpson rule')
       END IF
       IF(n <= 1) THEN
          t(1) = 0.d+00
          w(1) = 2.d+00
          RETURN
       END IF
       h = 2.d+00/(n-1)
       t(1) = -1.d+00
       t(n) = 1.d+00
       w(1) = h/3.d+00
       w(n) = h/3.d+00
       nm1 = n-1
       DO  i=2,nm1
          t(i) = t(i-1) + h
          w(i) = 4.d+00 - 2.d+00*(i-2*(i/2))
          w(i) = w(i)*h/3.d+00
       END DO
       RETURN
    END IF

    CALL classpol (ikind, n, alpha, beta, b, t, muzero)

    !           the matrix of coefficients is assumed to be symmetric.
    !           the array t contains the diagonal elements, the array
    !           b the off-diagonal elements.
    !           make appropriate changes in the lower right 2 by 2
    !           submatrix.

    IF (kpts == 0)  GO TO 100
    IF (kpts == 2)  GO TO  50

    !           if kpts=1, only t(n) must be changed

    t(n) =gbslve(endpts(1), n, t, b)*b(n-1)**2 + endpts(1)
    GO TO 100

    !           if kpts=2, t(n) and b(n-1) must be recomputed

50  gam =gbslve(endpts(1), n, t, b)
    t1 = ((endpts(1) - endpts(2))/(gbslve(endpts(2), n, t, b) - gam))
    b(n-1) =  SQRT(t1)
    t(n) = endpts(1) + gam*t1

    !           note that the indices of the elements of b run from 1 to n-1
    !           and thus the value of b(n) is arbitrary.
    !           now compute the eigenvalues of the symmetric tridiagonal
    !           matrix, which has been modified as necessary.
    !           the method used is a ql-type method with origin shifting

100 w(1) = 1.0D0
    DO  i = 2, n
       w(i) = 0.0D0
    END DO

    CALL gbtql2 (n, t, b, w, ierr)
    DO  i = 1, n
       w(i) = muzero * w(i) * w(i)
    END DO

    RETURN
  END SUBROUTINE gaussq

  !deck @(#)classpol.f 1.1 9/9/91
  ! Code converted using TO_F90 by Alan Miller
  ! Date: 2000-11-02  Time: 11:46:10
  SUBROUTINE classpol(ikind, n, alpha, beta, b, a, muzero)

    !           this procedure supplies the coefficients a(j), b(j) of the
    !        recurrence relation

    !             b p (x) = (x - a ) p   (x) - b   p   (x)
    !              j j            j   j-1       j-1 j-2

    !        for the various classical (normalized) orthogonal polynomials,
    !        and the zero-th moment

    !             muzero = integral w(x) dx

    !        of the given polynomial   weight function w(x).  since the
    !        polynomials are orthonormalized, the tridiagonal matrix is
    !        guaranteed to be symmetric.

    !           the input parameter alpha is used only for laguerre and
    !        jacobi polynomials, and the parameter beta is used only for
    !        jacobi polynomials.  the laguerre and jacobi polynomials
    !        require the gamma function.

    !     ..................................................................

    IMPLICIT REAL(DOUB_PREC) (a-h,o-z)
    INTEGER, INTENT(IN OUT)                  :: ikind
    INTEGER, INTENT(IN)                      :: n
    REAL(DOUB_PREC), INTENT(IN)                         :: alpha
    REAL(DOUB_PREC), INTENT(IN)                         :: beta
    REAL(DOUB_PREC), INTENT(OUT)                        :: b(n)
    REAL(DOUB_PREC), INTENT(OUT)                        :: a(n)
    REAL(DOUB_PREC), INTENT(OUT)                      :: muzero

    DATA pi / 3.141592653589793D0  /

    nm1 = n - 1
    SELECT CASE ( ikind )
    CASE (    1)
       GO TO 10
    CASE (    2)
       GO TO  20
    CASE (    3)
       GO TO  30
    CASE (    4)
       GO TO  40
    CASE (    5)
       GO TO  50
    CASE (    6)
       GO TO  60
    END SELECT

    !              ikind = 1=  legendre polynomials p(x)
    !              on (-1, +1), w(x) = 1.

10  muzero = 2.0D0
    DO  i = 1, nm1
       a(i) = 0.0D0
       abi = i
       b(i) = abi/ SQRT(4.d0*abi*abi - 1.0D0  )
    END DO
    a(n) = 0.0D0
    RETURN

    !              ikind = 2=  chebyshev polynomials of the first ikind t(x)
    !              on (-1, +1), w(x) = 1 / sqrt(1 - x*x)

20  muzero = pi
    DO  i = 1, nm1
       a(i) = 0.0D0
       b(i) = 0.5D0
    END DO
    b(1) =  SQRT(0.5D0  )
    a(n) = 0.0D0
    RETURN

    !              ikind = 3=  chebyshev polynomials of the second ikind u(x)
    !              on (-1, +1), w(x) = sqrt(1 - x*x)

30  muzero = pi/2.0D0
    DO  i = 1, nm1
       a(i) = 0.0D0
       b(i) = 0.5D0
    END DO
    a(n) = 0.0D0
    RETURN

    !              ikind = 4=  hermite polynomials h(x) on (-infinity,
    !              +infinity), w(x) = exp(-x**2)

40  muzero =  SQRT(pi)
    DO  i = 1, nm1
       a(i) = 0.0D0
       b(i) =  SQRT(i/2.0D0  )
    END DO
    a(n) = 0.0D0
    RETURN

    !              ikind = 5=  jacobi polynomials p(alpha, beta)(x) on
    !              (-1, +1), w(x) = (1-x)**alpha + (1+x)**beta, alpha and
    !              beta greater than -1

50  ab = alpha + beta
    abi = 2.0D0   + ab
    muzero = 2.0D0   ** (ab + 1.0D0  ) * gamma(alpha + 1.0D0  ) * gamma(  &
         beta + 1.0D0  ) / gamma(abi)
    a(1) = (beta - alpha)/abi
    b(1) =  SQRT(4.0D0  *(1.0D0  + alpha)*(1.0D0   + beta)/((abi + 1.0D0  )*  &
         abi*abi))
    a2b2 = beta*beta - alpha*alpha
    DO  i = 2, nm1
       abi = 2.0D0  *i + ab
       a(i) = a2b2/((abi - 2.0D0  )*abi)
       b(i) =  SQRT (4.0D0  *i*(i + alpha)*(i + beta)*(i + ab)/  &
            ((abi*abi - 1)*abi*abi))
    END DO
    abi = 2.0D0  *n + ab
    a(n) = a2b2/((abi - 2.0D0  )*abi)
    RETURN

    !              ikind = 6=  laguerre polynomials l(alpha)(x) on
    !              (0, +infinity), w(x) = exp(-x) * x**alpha, alpha greater
    !              than -1.

60  muzero = gamma(alpha + 1.0D0)
    DO  i = 1, nm1
       a(i) = 2.0D0  *i - 1.0D0   + alpha
       b(i) =  SQRT(i*(i + alpha))
    END DO
    a(n) = 2.0D0  *n - 1 + alpha
    RETURN
  END SUBROUTINE classpol

  !deck @(#)gbslve.f 1.1 9/9/91
  ! Code converted using TO_F90 by Alan Miller
  ! Date: 2000-11-02  Time: 11:46:27
  FUNCTION gbslve(shift, n, a, b)
    !       this procedure performs elimination to solve for the
    !       n-th component of the solution delta to the equation

    !             (jn - shift*identity) * delta  = en,

    !       where en is the vector of all zeroes except for 1 in
    !       the n-th position.

    !       the matrix jn is symmetric tridiagonal, with diagonal
    !       elements a(i), off-diagonal elements b(i).  this equation
    !       must be solved to obtain the appropriate changes in the lower
    !       2 by 2 submatrix of coefficients for orthogonal polynomials.

    IMPLICIT REAL(DOUB_PREC) (a-h,o-z)
    REAL(DOUB_PREC), INTENT(IN)                         :: shift
    INTEGER, INTENT(IN)                        :: n
    REAL(DOUB_PREC), INTENT(IN)                         :: a(n)
    REAL(DOUB_PREC), INTENT(IN)                         :: b(n)

    alpha = a(1) - shift
    nm1 = n - 1
    DO  i = 2, nm1
       alpha = a(i) - shift - b(i-1)**2/alpha
    END DO
    gbslve = 1.0D0  /alpha
    RETURN
  END FUNCTION gbslve

  !deck @(#)gbtql2.f 1.1 9/9/91

  ! Code converted using TO_F90 by Alan Miller
  ! Date: 2000-11-02  Time: 11:46:57

  SUBROUTINE gbtql2(n, d, e, z, ierr)

    !     this subroutine is a translation of the algol procedure imtql2,
    !     num. math. 12, 377-383(1968) by martin and wilkinson,
    !     as modified in num. math. 15, 450(1970) by dubrulle.
    !     handbook for auto. comp., vol.ii-linear algebra, 241-248(1971).

    !     this subroutine finds the eigenvalues and first components of the
    !     eigenvectors of a symmetric tridiagonal matrix by the implicit ql
    !     method, and is adapted from the eispak routine imtql2

    !     on input=

    !        n is the order of the matrix;

    !        d contains the diagonal elements of the input matrix;

    !        e contains the subdiagonal elements of the input matrix
    !          in its first n-1 positions.  e(n) is arbitrary;

    !        z contains the first row of the identity matrix.

    !      on output=

    !        d contains the eigenvalues in ascending order.  if an
    !          error exit is made, the eigenvalues are correct but
    !          unordered for indices 1, 2, ..., ierr-1;

    !        e has been destroyed;

    !        z contains the first components of the orthonormal eigenvectors
    !          of the symmetric tridiagonal matrix.  if an error exit is
    !          made, z contains the eigenvectors associated with the stored
    !          eigenvalues;

    !        ierr is set to

    !        ierr is set to
    !          zero       for normal return,
    !          j          if the j-th eigenvalue has not been
    !                     determined after 30 iterations.

    !     ------------------------------------------------------------------

    IMPLICIT REAL(DOUB_PREC) (a-h,o-z)
    INTEGER, INTENT(IN)                      :: n
    REAL(DOUB_PREC), INTENT(IN OUT)                     :: d(n)
    REAL(DOUB_PREC), INTENT(IN OUT)                     :: e(n)
    REAL(DOUB_PREC), INTENT(IN OUT)                     :: z(n)
    INTEGER, INTENT(OUT)                     :: ierr
    INTEGER :: i, j, k, l, m, ii, mml
    REAL(DOUB_PREC)  machep

    !     ========== machep is a machine dependent parameter specifying
    !                the relative precision of floating point arithmetic.
    !                machep = 16.0d0**(-13) for long form arithmetic
    !                on s360 ==========
    machep=1.0E-14

    ierr = 0
    IF (n == 1) GO TO 1001

    e(n) = 0.0D0
    DO  l = 1, n
       j = 0
       !     ========== look for small sub-diagonal element ==========
105    DO  m = l, n
          IF (m == n) GO TO 120
          IF ( ABS(e(m)) <= machep * ( ABS(d(m)) +  ABS(d(m+1)))) GO TO 120
       END DO

120    p = d(l)
       IF (m == l) CYCLE
       IF (j == 30) GO TO 1000
       j = j + 1
       !     ========== form shift ==========
       g = (d(l+1) - p) / (2.0D0   * e(l))
       r =  SQRT(g*g+1.0D0  )
       g = d(m) - p + e(l) / (g +  SIGN(r, g))
       s = 1.0D0
       c = 1.0D0
       p = 0.0D0
       mml = m - l
       !     ========== for i=m-1 step -1 until l do -- ==========
       DO  ii = 1, mml
          i = m - ii
          f = s * e(i)
          b = c * e(i)
          IF ( ABS(f) <  ABS(g)) GO TO 150
          c = g / f
          r =  SQRT(c*c+1.0D0  )
          e(i+1) = f * r
          s = 1.0D0   / r
          c = c * s
          GO TO 160
150       s = f / g
          r =  SQRT(s*s+1.0D0  )
          e(i+1) = g * r
          c = 1.0D0   / r
          s = s * c
160       g = d(i+1) - p
          r = (d(i) - g) * s + 2.0D0   * c * b
          p = s * r
          d(i+1) = g + p
          g = c * r - b
          !     ========== form first component of vector ==========
          f = z(i+1)
          z(i+1) = s * z(i) + c * f
          z(i) = c * z(i) - s * f

       END DO

       d(l) = d(l) - p
       e(l) = g
       e(m) = 0.0D0
       GO TO 105
    END DO
    !     ========== order eigenvalues and eigenvectors ==========
    DO  ii = 2, n
       i = ii - 1
       k = i
       p = d(i)

       DO  j = ii, n
          IF (d(j) >= p) CYCLE
          k = j
          p = d(j)
       END DO

       IF (k == i) CYCLE
       d(k) = d(i)
       d(i) = p

       p = z(i)
       z(i) = z(k)
       z(k) = p

    END DO

    GO TO 1001
    !     ========== set error -- no convergence to an
    !                eigenvalue after 30 iterations ==========
1000 ierr = l
1001 RETURN
    !     ========== last card of gbtql2 ==========
  END SUBROUTINE gbtql2

  subroutine lnkerr(message)
    CHARACTER (LEN=*), INTENT(IN) :: message
    write(6,*) message
    stop
  end subroutine lnkerr

  !============================================================
  ! Finds Lagrange interpolating polynomials
  ! of function of x and their first and second
  ! derivatives on an arbitrary grid y.
  !============================================================
  !deck lgngr
  ! Code converted using TO_F90 by Alan Miller
  ! Date: 2000-12-06  Time: 11:11:54
  SUBROUTINE lgngr(p,dp,ddp,x,y,nx,ny,drctv)
    !***begin prologue     lgrply
    !***date written       940504   (yymmdd)
    !***revision date               (yymmdd)
    !***keywords
    !***author             schneider, barry (nsf)
    !***source             %W% %G%
    !***purpose            lagrange polynomials at arbitrary points.
    !***description
    !***

    !***references

    !***routines called

    !***end prologue       lgngr

    IMPLICIT INTEGER (a-z)
    REAL(DOUB_PREC), INTENT(OUT)                      :: p(ny,nx)
    REAL(DOUB_PREC), INTENT(OUT)                      :: dp(ny,nx)
    REAL(DOUB_PREC), INTENT(OUT)                      :: ddp(ny,nx)
    REAL(DOUB_PREC), INTENT(IN)                       :: x(nx)
    REAL(DOUB_PREC), INTENT(IN)                       :: y(ny)
    INTEGER, INTENT(IN)                      :: nx
    INTEGER, INTENT(IN)                      :: ny
    CHARACTER (LEN=*), INTENT(IN)            :: drctv

    REAL(DOUB_PREC) sn, ssn, fac

    !     generate polynomials and derivatives with respect to x

    DO  i=1,ny
       zerfac = 0
       DO  j=1,nx
          fac =  y(i) - x(j)
          IF(ABS(fac) <= 1.d-10) THEN
             zerfac = j
          END IF
       END DO
       DO  j=1,nx
          p(i,j) = 1.d0
          DO  k=1,j-1
             p(i,j) = p(i,j)*( y(i) - x(k) ) / ( x(j) - x(k) )
          END DO
          DO  k=j+1,nx
             p(i,j) = p(i,j)*( y(i) - x(k) ) / ( x(j) - x(k) )
          END DO
          IF(drctv /= 'functions-only') THEN
             IF(ABS(p(i,j)) > 1.d-10) THEN
                sn = 0.d0
                ssn = 0.d0
                DO  k=1,j-1
                   fac = 1.d0/( y(i) - x(k) )
                   sn = sn + fac
                   ssn = ssn + fac*fac
                END DO
                DO  k=j+1,nx
                   fac = 1.d0/( y(i) - x(k) )
                   sn = sn + fac
                   ssn = ssn + fac*fac
                END DO
                dp(i,j) = sn*p(i,j)
                ddp(i,j) = sn*dp(i,j) - ssn*p(i,j)
             ELSE
                first=j
                second=zerfac
                IF(first > second) THEN
                   first=zerfac
                   second=j
                END IF
                sn = 1.d0
                ssn = 0.d0
                DO  k=1,first-1
                   fac = 1.d0/( x(j) - x(k) )
                   sn = sn*fac*( y(i) - x(k) )
                   ssn = ssn + 1.d0/(y(i) - x(k))
                END DO
                DO  k=first+1,second-1
                   fac = 1.d0/( x(j) - x(k) )
                   sn = sn*fac*( y(i) - x(k) )
                   ssn = ssn + 1.d0/( y(i) - x(k) )
                END DO
                DO  k=second+1,nx
                   fac = 1.d0/( x(j) - x(k) )
                   sn = sn*fac*( y(i) - x(k) )
                   ssn = ssn + 1.d0/( y(i) - x(k) )
                END DO
                dp(i,j) = sn/( x(j) - x(zerfac) )
                ddp(i,j) = 2.d0*ssn*dp(i,j)
             END IF
          END IF
       END DO

    END DO

  END SUBROUTINE lgngr
END MODULE helpers

! ------------------------------------------------------------------------
subroutine DVR_reg(nfun,xbounds,pt,wt,df,eddf,ke_mat)
  ! ------------------------------------------------------------------------
  use kinddefs
  use helpers
  implicit NONE
  !------External subroutines:
  !--------"gaussq", "lgngr"------------------

  integer, INTENT(IN)   :: nfun
  real(doub_prec), dimension(1:2), INTENT(IN)  :: xbounds
  real(doub_prec), dimension(1:nfun), INTENT(OUT) :: pt
  real(doub_prec), dimension(1:nfun), INTENT(OUT) :: wt
  real(doub_prec), dimension(1:nfun,1:nfun), INTENT(OUT) :: ke_mat, df, eddf

  integer :: i,j,k
  real(doub_prec), dimension(1:2) :: endpoints
  real(doub_prec) :: xmin, xmax
  real(doub_prec), dimension(1:nfun)         :: scratch
  real(doub_prec), dimension(1:nfun)         :: gauss_weights
  real(doub_prec), dimension(1:nfun)         :: roots
  real(doub_prec), dimension(1:nfun,1:nfun)  :: f, ddf
  real(doub_prec) :: A,B

  !--------------------------------------------------------------------
  ! Endpoint of the interval for the region
  !--------------------------------------------------------------------

  !write(0,*) 'DVR_reg called with:'
  !write(0,*) 'nfun = ', nfun
  !write(0,*) 'xbounds = ', xbounds

  xmax=xbounds(2)
  xmin=xbounds(1)

  !--------------------------------------------------------------------
  ! Standard interval for Legendre quadrature
  !--------------------------------------------------------------------

  endpoints(1)=-1.d0
  endpoints(2)=1.d0

  !--------------------------------------------------------------------
  ! Find zeros of nfun'th order Legendre quadrature (Gauss-Lobatto)
  !--------------------------------------------------------------------

  call gaussq('legendre',nfun,0.d0,0.d0,2,endpoints,scratch,roots,gauss_weights)

  !--------------------------------------------------------------------
  ! Set up rescaled position grid
  !--------------------------------------------------------------------

  A=dabs(xmax-xmin)/2.d0
  B=(xmax+xmin)/2.d0
  do k=1,nfun
     pt(k)=A*roots(k)+B
     wt(k)=A*gauss_weights(k)
  end do

  !--------------------------------------------------------------------
  ! Generate Lagrange interpolating polynomials and their first
  ! and second derivatives
  !--------------------------------------------------------------------

  call lgngr(f,df,ddf,pt,pt,nfun,nfun,'all')

  !--------------------------------------------------------------------
  !--------------------------------------------------------------------
  ! Set up kinetic energy matrix (not normalized!)
  !--------------------------------------------------------------------
  !--------------------------------------------------------------------

  !-------------------------j=function index; i=point index----------------

  ke_mat(:,:)=0.d0
  eddf(:,:)=0.d0

  do j=1,nfun
     !******************adding the bloch contributions*******************
     ke_mat(1,j)=f(1,1)*df(1,j)
     ke_mat(nfun,j)=-f(nfun,nfun)*df(nfun,j)

     !      eddf(1,j)=f(1,1)*df(1,j)
     !      eddf(nfun,j)=-f(nfun,nfun)*df(nfun,j)
     !*****************
     do i=1,nfun
        ke_mat(i,j)=ke_mat(i,j)+ddf(i,j)*wt(i)
        eddf(i,j)=eddf(i,j)+ddf(i,j)
     end do

  end do

  !--------------------------------------------------------------------
  ! Factor of -1/2
  !--------------------------------------------------------------------
  do i=1, nfun
     do j=1, nfun
        ke_mat(i,j)=-0.5d0*ke_mat(i,j)
     end do
  end do
end subroutine DVR_reg


program rk4_error
    implicit none
    integer :: i, N, k
    real(8) :: t, h
    real(8), dimension(2) :: x, k1, k2, k3, k4

    do k=0,10
        N = 2**k
        h = 1. / N

        ! Runge-Kutta 4th order method
        x = (/ 1., 0. /)
        do i=1,N
            t = (i - 1) * h
            k1 = f(x, t)
            k2 = f(x + h / 2. * k1, t + h / 2.)
            k3 = f(x + h / 2. * k2, t + h / 2.)
            k4 = f(x + h * k3, t + h)
            x = x + h /6. * (k1 + 2. * k2 + 2. * k3 + k4)
        end do
        write(*,*)h,abs(x - dcos(1d0))
    end do

contains

    function f(x, t)
        implicit none
        real(8), intent(in), dimension(2) :: x
        real(8), intent(in) :: t
        real(8), dimension(2) :: f

        f(1) = x(2)
        f(2) = - x(1)
    end function
end program


REAL*8 function iFactorial(j)
  IMPLICIT NONE
  INTEGER, intent(in) :: j
  INTEGER :: i
  REAL*8 :: x
  if (j<0) print *, "iFactorial defined only for non-negative numbers!"
  x=1
  iFactorial = x
  if (j.eq.1) return
  DO i=2,j
     x = x*i
  END DO
  iFactorial = x
  return
end function iFactorial

REAL*8 function dFactorial(x)
  IMPLICIT NONE
  REAL*8, intent(in) :: x
  REAL*8, PARAMETER :: spi2 = 0.8862269254527579
  REAL*8 :: y, r
  r=1
  y=x
  DO WHILE(y.gt.1.0)
     r = r * y
     y = y -1.
  ENDDO
  IF (abs(y-0.5).LT.1e-10) r = r*spi2
  dFactorial = r
  return
END function dFactorial

REAL*8 function mone(i)
  INTEGER, intent(in) :: i
  mone = 1 - 2*MOD(abs(i),2)
  return
end function mone

REAL*8 function Delta(j1, j2, j)
  IMPLICIT NONE
  REAL*8, intent(in) :: j1, j2, j
  ! function calls
  REAL*8 :: dFactorial
  Delta = sqrt(dFactorial(j1+j2-j)*dFactorial(j1-j2+j)*dFactorial(-j1+j2+j)/dFactorial(j1+j2+j+1))
  return
END function Delta

REAL*8 function ClebschG(j,m,j1,m1,j2,m2)
  IMPLICIT NONE
  REAL*8, intent(in) :: j,m,j1,m1,j2,m2
  INTEGER            :: tmin, tmax, t
  REAL*8             :: sum, v1, v2
  ! function calls
  REAL*8             :: iFactorial
  REAL*8             :: dFactorial
  REAL*8             :: mone
  REAL*8             :: Delta

  ClebschG = 0
  IF (m1+m2 .NE. m) return
  tmin = INT(max(max(0.0,j2-j-m1),j1-j+m2)+1e-14)
  tmax = INT(min(min(j1+j2-j,j1-m1),j2+m2)+1e-14)
  sum=0;
  DO t=tmin, tmax
     v1 = sqrt((2*j+1)*dFactorial(j1+m1)*dFactorial(j1-m1)*dFactorial(j2+m2)*dFactorial(j2-m2)*dFactorial(j+m)*dFactorial(j-m))
     v2 = iFactorial(t)*dFactorial(j1+j2-j-t)*dFactorial(j1-m1-t)*dFactorial(j2+m2-t)*dFactorial(j-j2+m1+t)*dFactorial(j-j1-m2+t)
     sum = sum + mone(t)*v1/v2
  END DO
  ClebschG = sum*Delta(j1,j2,j)
  return
END function ClebschG

REAL*8 function f6j(j1, j2, j3, m1, m2, m3)
  IMPLICIT NONE
  REAL*8, intent(in) :: j1, j2, j3, m1, m2, m3
  INTEGER            :: tmin, tmax, t
  REAL*8             :: sum, v1, v2
  ! function calls
  REAL*8             :: dFactorial
  REAL*8             :: iFactorial
  REAL*8             :: Delta
  REAL*8             :: mone
  tmin = INT(max(max(max(j1+j2+j3,j1+m2+m3),m1+j2+m3),m1+m2+j3)+1e-14)
  tmax = INT(min(min(j1+j2+m1+m2,j1+j3+m1+m3),j2+j3+m2+m3)+1e-14)
  sum=0
  DO t=tmin, tmax
     v1 = dFactorial(t-j1-j2-j3)*dFactorial(t-j1-m2-m3)*dFactorial(t-m1-j2-m3)*dFactorial(t-m1-m2-j3)
     v2 = dFactorial(j1+j2+m1+m2-t)*dFactorial(j1+j3+m1+m3-t)*dFactorial(j2+j3+m2+m3-t)
     sum = sum + mone(t)*iFactorial(t+1)/(v1*v2)
  END DO
  f6j = Delta(j1,j2,j3)*Delta(j1,m2,m3)*Delta(m1,m2,j3)*sum;
  return
END function f6j

REAL*8 function f3j(j1, m1, j2, m2, j3, m3)
  IMPLICIT NONE
  REAL*8, intent(in) :: j1, j2, j3, m1, m2, m3
  INTEGER            :: tmin, tmax, t
  REAL*8             :: sum, v1, v2, dn
  ! function calls
  REAL*8             :: dFactorial
  REAL*8             :: iFactorial
  REAL*8             :: Delta
  REAL*8             :: mone
  f3j=0
  IF (abs(m1+m2+m3) .GT. 1e-10) return
  IF (abs(j1-j2)-1e-14 .GT. j3 .OR. j3 .GT. j1+j2+1e-14) return
  if (abs(m1) .GT. j1 .OR. abs(m2) .GT. j2 .OR. abs(m3) .GT. j3) return
  tmin = INT(max(max(0.0,j2-j3-m1),j1-j3+m2)+1e-14)
  tmax = INT(min(min(j1+j2-j3,j1-m1),j2+m2)+1e-14)
  sum=0
  DO t=tmin, tmax
     v1 = dFactorial(j3-j2+m1+t)*dFactorial(j3-j1-m2+t)
     v2 = dFactorial(j1+j2-j3-t)*dFactorial(j1-m1-t)*dFactorial(j2+m2-t)
     sum = sum + mone(t)/(iFactorial(t)*v1*v2)
  END DO
  dn = dFactorial(j1+m1)*dFactorial(j1-m1)*dFactorial(j2+m2)*dFactorial(j2-m2)*dFactorial(j3+m3)*dFactorial(j3-m3)
  f3j = mone(INT(j1-j2-m3))*Delta(j1,j2,j3)*sqrt(dn)*sum
  return
END function f3j

REAL*8 function Gaunt(l1, m1, l2, m2, l3, m3)
  IMPLICIT NONE
  INTEGER, intent(in) :: l1, m1, l2, m2, l3, m3
  REAL*8, PARAMETER   :: pi = 3.14159265358979d0
  REAL*8 :: l1_, l2_, l3_, mm1_, m2_, m3_, zero
  ! function calls
  REAL*8             :: f3j
  REAL*8             :: mone
  l1_ = l1;   l2_ = l2;   l3_ = l3
  mm1_ = -m1; m2_ = m2; m3_ = m3
  zero = 0
  ! Calculates <Y_{l1m1}|Y_{l2m2}|Y_{l3m3}>
  if (l1.LT.0 .OR. l2.LT.0 .OR. l3.LT.0) print *, "Quantum number l must be non-negative!"
  Gaunt = mone(m1)*sqrt((2*l1+1)*(2*l2+1)*(2*l3+1)/(4*pi))*f3j(l1_,zero,l2_,zero,l3_,zero)*f3j(l1_,mm1_,l2_,m2_,l3_,m3_)
  return
END function Gaunt


!
! wavy - A spectral ocean wave modeling and development framework
! Copyright (c) 2017, Wavebit Scientific LLC
! All rights reserved.
!
! Licensed under the BSD-3 clause license. See LICENSE for details.

module mod_gravity

use mod_precision,only:rk => realkind

implicit none

private

public :: gravityClairaut
public :: gravitational_constant

real(kind=rk),parameter :: gravitational_constant = 6.67408e-11_rk

!===============================================================================
contains

!-------------------------------------------------------------------------------
pure elemental real(kind=rk)&
  function gravityClairaut(latitude) result(grav)
  !! Returns the gravitational acceleration at the Earth's surface as function
  !! of latitude, based on Clairaut's formula.
  !!
  !! TODO Reference
  real(kind=rk),intent(in) :: latitude !! Latitude [rad]
  grav = 9.780327_rk*(1.0026454_rk                &
                     -0.0026512_rk*cos(2*latitude)&
                     +0.0000058_rk*cos(2*latitude)**2)
endfunction gravityClairaut
!-------------------------------------------------------------------------------
endmodule mod_gravity


SUBROUTINE matrix_Rr (r1,r2 , r3)

! ----------------------------------------------------------------------
! SUBROUTINE: matrix_Rr.f90
! ----------------------------------------------------------------------
! Purpose:
!  Multiply 2 arrays : 3x3 multiply 3x1
! ----------------------------------------------------------------------
! Input arguments:
! - r1 : Array 1 with dimensions 3x3
! - r2 : Array 2 with dimensions 3x1
!
! Output arguments:
! - r3 : Array obtained from multiplying r1 * r2
! ----------------------------------------------------------------------
! Dr. Thomas Papanikolaou, Geoscience Australia            26 April 2016
! ----------------------------------------------------------------------

      USE mdl_precision
      IMPLICIT NONE

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

      r3(1) = r1(1,1) * r2(1) + r1(1,2) * r2(2) + r1(1,3) * r2(3)
      r3(2) = r1(2,1) * r2(1) + r1(2,2) * r2(2) + r1(2,3) * r2(3)
      r3(3) = r1(3,1) * r2(1) + r1(3,2) * r2(2) + r1(3,3) * r2(3)

END


module pes_module
   use precision_module, only : wp
   use input_module
   implicit none
   public

contains
!-------------------------------------------------------------------
function poly_high(x)
   real(wp) :: x, poly_high

   poly_high=hs4*x**4.0d0+hs3*x**3.0d0+hs2*x**2.0d0+hs1*x+hs0
!   poly_high=hs(1)*x**3.0d0+hs(2)*x**2.0d0+hs(3)*x+hs(4)
end function poly_high
!-------------------------------------------------------------------

function poly_low(x)
   real(wp) :: x, poly_low

   poly_low=ls4*x**4.0d0+ls3*x**3.0d0+ls2*x**2.0d0+ls1*x+ls0
!   poly_low=ls(1)*x**3.0d0+ls(2)*x**2.0d0+ls(3)*x+ls(4)
end function poly_low

!-------------------------------------------------------------------

function f_inertX(coef,k)
   real(wp) ::  f_inertX, coef(3)
   integer          ::  k

   f_inertX=coef(1)*dble(k)**2.0d0+coef(2)*dble(k)+coef(3)
   f_inertX=f_inertX*amutoau
!PRINT *,'HERE',f_inertX
end function f_inertX

!-------------------------------------------------------------------
end module pes_module


program print_02
implicit none
integer :: x
character(len=5) :: f = "(5i3)"
x = (2+3)*5
print "(5i3)", x, 1, 3, x, (2+3)*5+x
write(*,"(5i3)") x, 1, 3, x, (2+3)*5+x

print f, x, 1, 3, x, (2+3)*5+x
write(*,f) x, 1, 3, x, (2+3)*5+x
end program


c     ==================================
      double precision function qtrue(x,y,t)
c     ==================================
      implicit double precision (a-h,o-z)
      common /cparam/ ubar,vbar

      x0 = x - ubar*t
      y0 = y - vbar*t

c     # evaluate desired initial data at (x0,y0):

!--      r = dsqrt((x0+0.2d0)**2 + (y0-0.4d0)**2)
!--      if (r <= 0.3d0) then
!--          qtrue = 1.d0
!--        else
!--          qtrue = 0.d0
!--        endif
!--
!--      r = dsqrt((x0-0.3d0)**2 + (y0-0.1d0)**2)
!--      qtrue = qtrue - dexp(-15.d0*r**2)

c linear test function to see if ghost cell interpolation exact
      qtrue = 2.d0*x0 + 1.0d0*y0
      !qtrue = 1.d0*x0 + 1.0d0*y0

      return
      end


    Program dgesvdx_example

!     DGESVDX Example Program Text

!     Copyright (c) 2018, Numerical Algorithms Group (NAG Ltd.)
!     For licence see
!       https://github.com/numericalalgorithmsgroup/LAPACK_Examples/blob/master/LICENCE.md

!     .. Use Statements ..
      Use lapack_interfaces, Only: dgesvdx
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=dp) :: vl, vu
      Integer :: i, il, info, iu, lda, ldu, ldvt, lwork, m, n, ns
      Character (1) :: range
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: a(:, :), a_copy(:, :), b(:), s(:), &
        u(:, :), vt(:, :), work(:)
      Real (Kind=dp) :: dummy(1, 1)
      Integer, Allocatable :: iwork(:)
!     .. Intrinsic Procedures ..
      Intrinsic :: nint
!     .. Executable Statements ..
      Write (nout, *) 'DGESVDX Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) m, n
      lda = m
      ldu = m
      ldvt = n
      Allocate (a(lda,n), a_copy(m,n), s(n), vt(ldvt,n), u(ldu,m), b(m), &
        iwork(12*m))

!     Read the m by n matrix A from data file
      Read (nin, *)(a(i,1:n), i=1, m)

!     Read the right hand side of the linear system
      Read (nin, *) b(1:m)

!     Read range for selected singular values
      Read (nin, *) range

      If (range=='I' .Or. range=='i') Then
        Read (nin, *) il, iu
      Else If (range=='V' .Or. range=='v') Then
        Read (nin, *) vl, vu
      End If

      a_copy(1:m, 1:n) = a(1:m, 1:n)

!     Use routine workspace query to get optimal workspace.
      lwork = -1
      Call dgesvdx('V', 'V', range, m, n, a, lda, vl, vu, il, iu, ns, s, u, &
        ldu, vt, ldvt, dummy, lwork, iwork, info)

!     Make sure that there is enough workspace for block size nb.
      lwork = nint(dummy(1,1))
      Allocate (work(lwork))

!     Compute the singular values and left and right singular vectors
!     of A.

      Call dgesvdx('V', 'V', range, m, n, a, lda, vl, vu, il, iu, ns, s, u, &
        ldu, vt, ldvt, work, lwork, iwork, info)

      If (info/=0) Then
        Write (nout, 100) 'Failure in DGESVDX. INFO =', info
100     Format (1X, A, I4)
        Go To 120
      End If

!     Print the selected singular values of A

      Write (nout, *) 'Singular values of A:'
      Write (nout, 110) s(1:ns)
110   Format (1X, 4(3X,F11.4))

      Call compute_error_bounds(m, ns, s)

      If (m>n .And. ns==n) Then
!       Compute V*Inv(S)*U^T * b to get least squares solution.
        Call compute_least_squares(m, n, a_copy, m, u, ldu, vt, ldvt, s, b)
      End If

120   Continue

    Contains
      Subroutine compute_least_squares(m, n, a, lda, u, ldu, vt, ldvt, s, b)

!       .. Use Statements ..
        Use blas_interfaces, Only: dgemv, dnrm2
!       .. Implicit None Statement ..
        Implicit None
!       .. Scalar Arguments ..
        Integer, Intent (In) :: lda, ldu, ldvt, m, n
!       .. Array Arguments ..
        Real (Kind=dp), Intent (In) :: a(lda, n), s(n), u(ldu, m), vt(ldvt, n)
        Real (Kind=dp), Intent (Inout) :: b(m)
!       .. Local Scalars ..
        Real (Kind=dp) :: alpha, beta, norm
!       .. Local Arrays ..
        Real (Kind=dp), Allocatable :: x(:), y(:)
!       .. Intrinsic Procedures ..
        Intrinsic :: allocated
!       .. Executable Statements ..
        Allocate (x(n), y(n))

!       Compute V*Inv(S)*U^T * b to get least squares solution.

!       y = U^T b
        alpha = 1._dp
        beta = 0._dp
        Call dgemv('T', m, n, alpha, u, ldu, b, 1, beta, y, 1)

        y(1:n) = y(1:n)/s(1:n)

!       x = V y
        Call dgemv('T', n, n, alpha, vt, ldvt, y, 1, beta, x, 1)

        Write (nout, *)
        Write (nout, *) 'Least squares solution:'
        Write (nout, 100) x(1:n)

!       Find norm of residual ||b-Ax||.
        alpha = -1._dp
        beta = 1._dp
        Call dgemv('N', m, n, alpha, a, lda, x, 1, beta, b, 1)

        norm = dnrm2(m, b, 1)

        Write (nout, *)
        Write (nout, *) 'Norm of Residual:'
        Write (nout, 100) norm

        If (allocated(x)) Then
          Deallocate (x)
        End If
        If (allocated(y)) Then
          Deallocate (y)
        End If

100     Format (1X, 4(3X,F11.4))

      End Subroutine

      Subroutine compute_error_bounds(m, n, s)

!       Error estimates for singular values and vectors is computed
!       and printed here.

!       .. Use Statements ..
        Use lapack_interfaces, Only: ddisna
        Use lapack_precision, Only: dp
!       .. Implicit None Statement ..
        Implicit None
!       .. Scalar Arguments ..
        Integer, Intent (In) :: m, n
!       .. Array Arguments ..
        Real (Kind=dp), Intent (In) :: s(n)
!       .. Local Scalars ..
        Real (Kind=dp) :: eps, serrbd
        Integer :: i, info
!       .. Local Arrays ..
        Real (Kind=dp), Allocatable :: rcondu(:), rcondv(:), uerrbd(:), &
          verrbd(:)
!       .. Intrinsic Procedures ..
        Intrinsic :: epsilon
!       .. Executable Statements ..
        Allocate (rcondu(n), rcondv(n), uerrbd(n), verrbd(n))

!       Get the machine precision, EPS and compute the approximate
!       error bound for the computed singular values.  Note that for
!       the 2-norm, S(1) = norm(A)

        eps = epsilon(1.0E0_dp)
        serrbd = eps*s(1)

!       Call DDISNA to estimate reciprocal condition
!       numbers for the singular vectors

        Call ddisna('Left', m, n, s, rcondu, info)
        Call ddisna('Right', m, n, s, rcondv, info)

!       Compute the error estimates for the singular vectors

        Do i = 1, n
          uerrbd(i) = serrbd/rcondu(i)
          verrbd(i) = serrbd/rcondv(i)
        End Do

!       Print the approximate error bounds for the singular values
!       and vectors

        Write (nout, *)
        Write (nout, *) 'Estimates given as multiples of machine precision'
        Write (nout, *) 'Error estimate for the singular values'
        Write (nout, 100) nint(serrbd/epsilon(1.0E0_dp))
        Write (nout, *)
        Write (nout, *) 'Error estimates for the left singular vectors'
        Write (nout, 100) nint(uerrbd(1:n)/epsilon(1.0E0_dp))
        Write (nout, *)
        Write (nout, *) 'Error estimates for the right singular vectors'
        Write (nout, 100) nint(verrbd(1:n)/epsilon(1.0E0_dp))

100     Format (4X, 6I11)

      End Subroutine

    End Program


program trap_method
  implicit none

integer :: i, n,a,b
real :: sumation, mean, height, f(i), integral

 !  value of the integral using the trapezium rule

 ! integral = (b - a)*((f(a) +f(b))/2 + sumation_1_n-1 )/n
write (*,*) "type the limits a, b and the number of intervals"
     read *, a, b, n

    height = (b - a)/n
        mean = (f(a) + f(b))/2
sumation = 0

do i = 1, n-1
    sumation = sumation + f(i)
end do

      integral = height*(mean + sumation)
  write (*,*) "the value of the integral using the trapezoidal method is", integral

     end program

function f(x)
  real :: f(x)
  integer :: (x)

      f(x) = EXP(x)

end function


c
c Implemented to date
c ===================
c  I1, I2, I3  -> tensor invariants
c  A2S         -> obtain deviatoric component of tensor
c  J1, J2, J3  -> deviatoric invariants
c  L4_EL       -> determine elastic tensor using E,v
c  C4_EL       -> determine compilance tensor using E,v
c  KD          -> returns Kronecker's delta
c  IDN4        -> returns 4th order identity tensor
c  SYM4	       -> returns symmetric identity tensor
c  ANT4        -> returns antisymmetric identity tensor
c  VOL4        -> returns volumetric identity tensor
c  DEV4        -> returns deviatoric identity tensor
c  SEQ         -> find von Mises stress of a tensor
c  CH          -> converts 2nd order tensor into principal space
c  VMS         -> calculate von Mises stress
c  F2C         -> find right green-lagrange tensor from def. grad
c  F2B         -> find left green-lagrange tensor from def. grad
c  SYM2        -> get symmetric component of a second order tensor
c  SKEW2       -> get skew component of a second order tensor
c  PD          -> get R,U,V from F using Hoger & Carlson method
c
       subroutine I1 (A2,x)
c
        implicit none
        double precision, intent (in) :: A2(9)
        double precision, intent (out) :: x
c
        x = A2(1) + A2(5) + A2(9)
        return
c
       end subroutine I1
c
c
c
       subroutine I2 (A2,x)
c
        implicit none
        double precision, intent (in) :: A2(9)
        double precision, intent (out) :: x
        double precision :: trA, trASQ, ASQ(9)
c
        call tc_2s2(A2,A2,ASQ)
        call I1(A2,trA)
        call I1(ASQ,trASQ)
c
        x = 0.5_8*trA*trA-0.5_8*trASQ
        return
c
       end subroutine I2
c
c
       subroutine I3 (A2,x)
c
        implicit none
        double precision, intent (in) :: A2(9)
        double precision, intent (out) :: x
c
        call det(A2,x)
        return
c
       end subroutine I3
c
c
c
       subroutine A2S (A2,S2)
c
        implicit none
        double precision, intent (in) :: A2(9)
        double precision, intent (out) :: S2(9)
        double precision :: trA, P
c
        call I1(A2,trA)
        P = trA / 3.0_8
        S2(1) = A2(1) - P
        S2(2) = A2(2)
        S2(3) = A2(3)
        S2(4) = A2(4)
        S2(5) = A2(5) - P
        S2(6) = A2(6)
        S2(7) = A2(7)
        S2(8) = A2(8)
        S2(9) = A2(9) - P
        return
c
       end subroutine A2S
c
c
c
       subroutine J1 (A2,x)
c
        implicit none
        double precision, intent (in) :: A2(9)
        double precision, intent (out) :: x
        double precision :: S2(9)
c
        call A2S (A2,S2)
        call I1 (S2,x)
        return
c
       end subroutine J1
c
c
c
       subroutine J2 (A2,x)
c
        implicit none
        double precision, intent (in) :: A2(9)
        double precision, intent (out) :: x
        double precision :: S2(9)
c
        call A2S (A2,S2)
        call I2 (S2,x)
        return
c
       end subroutine J2
c
c
c
       subroutine J3 (A2,x)
c
        implicit none
        double precision, intent (in) :: A2(9)
        double precision, intent (out) :: x
        double precision :: S2(9)
c
        call A2S (A2,S2)
        call I3 (S2,x)
        return
c
       end subroutine J3
c
c
c
       subroutine L4_EL (E,v,L4)
c
        implicit none
        double precision, intent (in) :: E,v
        double precision, intent (out) :: L4(9,9)
        double precision :: G,K,LAME
        double precision :: eye(9)
        double precision :: B4(9,9)
c
        G = 0.5_8*E/(1+v)
        K = E/3.0_8/(1-2*v)
        LAME = K-2.0_8*G/3.0_8
c
c    Lel = LAME*(IXI)+2*G*I
c
        call KD(eye)
        call tp_2dy2(eye,eye,L4)
        call scale4 (L4,L4,LAME)
        call SYM4(B4)
        call scale4(B4,B4,2*G)
        L4 = L4 + B4
c
        return
c
       end subroutine L4_EL
c
       subroutine C4_EL (E,v,C4)
c
        implicit none
        double precision, intent (in) :: E,v
        double precision, intent (out) :: C4(9,9)
        double precision :: G,K,LAME,alp
        double precision :: eye(9)
        double precision :: B4(9,9)
c
        G = 0.5_8*E/(1+v)
        K = E/3.0_8/(1-2*v)
        LAME = K-2.0_8*G/3.0_8
        alp = -LAME/2/G/(3*LAME+2*G)
c
        call KD(eye)
        call tp_2dy2(eye,eye,C4)
        call scale4 (C4,C4,alp)
        call SYM4(B4)
        call scale4(B4,B4,0.5_8/G)
        C4 = C4 + B4
c
        return
c
       end subroutine C4_EL
c
       subroutine KD (del)
c
        implicit none
        double precision, intent (out) :: del (9)
c
        del = (/ 1.0, 0.0, 0.0,
     &           0.0, 1.0, 0.0,
     &           0.0, 0.0, 1.0  /)
c
        return
c
       end subroutine KD
c
       subroutine IDN4 (I)
c
        implicit none
        double precision, intent (out) :: I (9,9)
c
        I = 0.0_8
        I(1,1) = 1.0_8
        I(2,2) = 1.0_8
        I(3,3) = 1.0_8
        I(4,4) = 1.0_8
        I(5,5) = 1.0_8
        I(6,6) = 1.0_8
        I(7,7) = 1.0_8
        I(8,8) = 1.0_8
        I(9,9) = 1.0_8
c
        return
c
       end subroutine IDN4
c
       subroutine SYM4 (I)
c
        implicit none
        double precision, intent (out) :: I(9,9)
        integer x,ji(9)
c
        ji = (/ 1,4,7,2,5,8,3,6,9 /)
c
        I = 0.0_8
c
        do x=1,9
         I(x,x) = 0.5_8
         I(x,ji(x)) = 0.5_8
        end do
c
        I(1,1)= 1.0_8
        I(5,5)= 1.0_8
        I(9,9)= 1.0_8
c
        return
c
       end subroutine SYM4
c
       subroutine ANT4 (I)
c
        implicit none
        double precision, intent (out) :: I(9,9)
        integer x,ji(9)
c
        ji = (/ 1,4,7,2,5,8,3,6,9 /)
c
        I = 0.0_8
c
        do x=1,9
         I(x,x) = 0.5_8
         I(x,ji(x)) = -0.5_8
        end do
c
        I(1,1) = 0.0_8
        I(5,5) = 0.0_8
        I(9,9) = 0.0_8
c
        return
c
       end subroutine ANT4
c
       subroutine VOL4 (I)
c
        implicit none
        double precision, intent (out) :: I(9,9)
c
        I = 0.0_8
        I(1,1) = 1.0_8/3
        I(1,5) = 1.0_8/3
        I(1,9) = 1.0_8/3
        I(5,1) = 1.0_8/3
        I(5,5) = 1.0_8/3
        I(5,9) = 1.0_8/3
        I(9,1) = 1.0_8/3
        I(9,5) = 1.0_8/3
        I(9,9) = 1.0_8/3
c
        return
c
       end subroutine VOL4
c
       subroutine DEV4 (I)
c
        implicit none
        double precision, intent (out) :: I(9,9)
        double precision :: eye4(9,9)
c
        call VOL4(I)
        call IDN4(eye4)
        I = eye4-I
        return
c
       end subroutine DEV4
c
c      THIS IS A REALLY SLOW WAY OF FINDING VON MISES
c      DO NOT USE UNLESS ABSOLUTELY NECESSESARY. USE VMS
c
       subroutine SEQ (A,vm)
c
        implicit none
        double precision, intent (in) :: A(9)
        double precision, intent (out) :: vm
        double precision :: DEV(9,9), S(9), J2
c
c
        call DEV4(DEV)
        call tc_4d2(DEV,A,S)
        call tc_2d2 (S,S,vm)
        vm = SQRT(1.5_8*vm)
c
        return
c
       end subroutine SEQ
c
c      Caley-Hamilton Theorem to find principal values
c
       subroutine CH (A,B)
c
        double precision, intent (in) :: A(9)
        double precision, intent (out) :: B(9)
        double precision :: H1, H2, H3, p, q, th, tol,
     &                      pie
c
        call PI(pie)
        tol = 1.0e-8_8
c
        H1 = A(1)/3.0_8+A(5)/3.0_8+A(9)/3.0_8
        H2 = (A(2)*A(2)+A(7)*A(7)+A(6)*A(6)
     &       -A(1)*A(5)-A(5)*A(9)-A(9)*A(1))/3.0_8
        H3 =       A(6)*A(7)*A(2)+0.5_8*A(1)*A(5)*A(9)
     &      -0.5_8*A(1)*A(6)*A(6)-0.5_8*A(5)*A(7)*A(7)
     &      -0.5_8*A(9)*A(2)*A(2)
c
        p = H1*H1+H2
c
c       check whether p is close to zero to avoid
c       entering inf. into arccos...
c
        if (ABS(p).LT.tol) then
           p = tol
        end if
        q = H1*H1*H1+1.5_8*H1*H2+H3
c
        th = q/p**1.5_8
c
c       check whether q/p**1.5 surpasses -1/1
c       due to numerical round off
c
        if (th.GT.1.0_8) then
          th = 1.0_8
        else if (th.LT.-1.0_8) then
          th = -1.0_8
        end if
        th = ACOS (th) / 3.0_8
c
c       define intermediates to speed things up
c
        alp = 2.0_8*SQRT(H1*H1+H2)
        bet = pie / 3.0_8
        B = 0.0_8
        B(1) = alp*COS(th)+H1
        B(5) = alp*COS(th+4.0_8*bet)+H1
        B(9) = alp*COS(th+2.0_8*bet)+H1
c
        return
c
       end subroutine CH
c
       subroutine VMS (A,vm)
c
        double precision, intent (in) :: A(9)
        double precision, intent (out) :: vm
c
        vm = SQRT(A(1)*A(1)+A(5)*A(5)+A(9)*A(9)
     &      -A(1)*A(5)-A(5)*A(9)-A(9)*A(1)
     &      +3.0_8*A(6)*A(6)+3.0_8*A(7)*A(7)+3.0_8*A(2)*A(2))
c
        return
c
       end subroutine VMS
c
       subroutine F2C (F,C)
c
        double precision, intent (in) :: F(9)
        double precision, intent (out) :: C(9)
        double precision :: Ft (9)
c
        call tpose (F,Ft)
        call tc_2s2(Ft,F,C)
c
        return
c
       end subroutine F2C
c
       subroutine F2B (F,B)
c
        double precision, intent (in) :: F(9)
        double precision, intent (out) :: B(9)
        double precision :: Ft (9)
c
        call tpose (F,Ft)
        call tc_2s2(F,Ft,B)
c
        return
c
       end subroutine F2B
c
       subroutine SYM2 (A,B)
c
        double precision, intent (in) :: A(9)
        double precision, intent (out) :: B(9)
        double precision :: At(9)
c
        call tpose (A,At)
        B = 0.5_8*A+0.5_8*At
c
        return
c
       end subroutine SYM2
c
       subroutine SKEW2 (A,B)
c
        double precision, intent (in) :: A(9)
        double precision, intent (out) :: B(9)
        double precision :: At(9)
c
        call tpose (A,At)
        B = 0.5_8*A-0.5_8*At
c
        return
c
       end subroutine SKEW2
c
c      Perform a polar decomposition of F into
c      R,U and V using the Hoger&Carlson method
c
c                     F=RU=VR.
c
c      You are an abomination. Yes you are...
c
c
       subroutine PD (F,R,U,V)
c
        double precision, intent (in) :: F(9)
        double precision, intent (out) :: R(9),U(9),V(9)
        double precision :: I1C, I2C, I3C
        double precision :: I1U, I2U, I3U
        complex (8) :: a1, a2, a3
        double precision :: k1, k2,k3, th
        double precision :: C(9) ,UINV(9),Ft(9)
        double precision :: alp(9), ainv(9), bet(9), de(9)
        double precision :: eye(9)
c
        eye = (/ 1.0_8,0.0_8,0.0_8,
     &           0.0_8,1.0_8,0.0_8,
     &           0.0_8,0.0_8,1.0_8 /)
        call F2C (F,C)
c
        call I1 (C,I1C)
        call I2 (C,I2C)
        call I3 (C,I3C)
c
        k1 = 32.0_8/27.0_8
        k2 = 1024.0_8/27.0_8
        th = 1.0_8/3.0_8
        a1 = k1*2*I1C**3-k1*9*I1C*I2C+k1*27*I3C
        a2 = k2*(4*I2C**3
     &      -I1C*I1C*I2C*I2C
     &      +4*I1C**3*I3C
     &      -18*I1C*I2C*I3C
     &      +27*I3C*I3C)
        a3 =-2.0_8/3.0_8*I1C
     &      +(a1+SQRT(a2))**th
     &      +(a1-SQRT(a2))**th
c
c         a3 =(a1+SQRT(a2))**th

c
        if (a3.EQ.-2.0_8*I1C) then
          I1U = SQRT(ABS(I1C+2.0_8*SQRT(ABS(I2C))))
        else
          k3 = SQRT(ABS(2.0_8*I1C+a3))
          I1U = 0.5_8*(k3+
     &                 SQRT(ABS(2.0_8*I1C-a3+
     &                 16.0_8*SQRT(ABS(I3C))/k3)))
        end if
c
        I2U = 0.5_8*I1U*I1U-0.5_8*I1C
        I3U = SQRT (ABS(I3C))
c        print *,
c        call t2print (C)
c        print *,
c        print *,"INV OF C:"
c        print "(3e12.4)",I1C,I2C,I3C
c        print *,
c        print *,"INV OF U:"
c        print "(3e12.4)",I1U,I2U,I3U
c        print *,
c        print *,"INTERMEDIATE VALUES:"
c        print "(2e12.4)",a1,a2,a3
c        print *,
c
        alp = C+I2U*eye
        call invert (alp, ainv)
        bet = I1U*C+I3U*eye
        call tc_2s2 (ainv,bet,U)
        call invert (U,UINV)
        call tc_2s2 (F,UINV,R)
        call tpose (F,Ft)
        call tc_2s2 (UINV,Ft,de)
        call tc_2s2 (F,de,V)
c
        return
c
       end subroutine PD
c
       subroutine kindef (F0, F1, b, dF, Fb, lb, Db, Wb)
c
         double precision, intent(in) :: F0(9), F1(9)
         double precision, intent(in) :: b
         double precision, intent(out) :: dF(9), Fb(9),lb(9),Db(9),Wb(9)
         double precision :: Finv(9)
c
         dF = F1-F0
c
c        Fb (b=0,0.5,1 for backward, midpoint, and forward)
c
         Fb = F0-b*F0+b*F1
         call invert (Fb,Finv)
         call tc_2s2 (dF,Finv,lb)
         call SYM2 (lb,Db)
         call SKEW2 (lb,Wb)
         return
c
       end subroutine kindef
c
c
c
       subroutine kindefgen (F,alp,flag)
c
        implicit none
        double precision, intent (inout) :: F(9)
        double precision, intent (in) :: alp
        integer, intent (in) :: flag
c
        F = 0.0_8
c
        if (flag.eq.1) then
c
c          Simple shear deformation gradient
c
           F = (/ 1.0_8,   alp,  0.0_8,
     &            0.0_8, 1.0_8,  0.0_8,
     &            0.0_8, 0.0_8,  1.0_8 /)
c
        else if (flag.eq.2) then
        else
        end if
c
c
       end subroutine kindefgen


SUBROUTINE matrix_RxR

! ----------------------------------------------------------------------
! SUBROUTINE: matrix_RxR.f90
! ----------------------------------------------------------------------
! Purpose:
!  Multiply 2 arrays
! ----------------------------------------------------------------------
! Input arguments:
! - R1 : Array 1 with dimensions ixj
! - R1 : Array 2 with dimensions nxm
!
! Output arguments:
! - R3 : Array ixm obtained from multiplication R1*R2
! ----------------------------------------------------------------------
! Note:
! Input and Output arguments are allocatable arrays and are declared
! through module mdl_arr.f90
! ----------------------------------------------------------------------
! Thomas D. Papanikolaou, Geoscience Australia              29 June 2016
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_arr
      IMPLICIT NONE

! ---------------------------------------------------------------------------
! Dummy arguments declaration
! ---------------------------------------------------------------------------
! IN
!      R1(i,j), R2(n,m) : Allocatable arrays via module mdl_arr.f90
! OUT
!      R3(i,m) : : Allocatable array via module mdl_arr.f90
! ---------------------------------------------------------------------------

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

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

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

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

END


Module hd_structure
	Use math_constants
	Use quadratures
	Implicit None
	contains

	!Function that calculates the direct correlation function of a Hard Disk Function
	!using Rosenfeld Fundamental Measure Theory structure
	Function ck_HD_ros(phi,k) result(ck)
		Implicit None
		Real * 8, intent(in) :: phi, k
		Real * 8 :: ck
		Real * 8 :: a0,b0,g0,k2
		Real * 8 ::  phip, phim, J10, J00,J11
		phip = 1.d0 + phi
		phim = 1.d0 - phi
		a0 = 1.d0 + ( (2.d0 * phi - 1.d0) * phip / (phim ** 3) ) + (2.d0 * phi/phim)
		a0 = a0 / phi
		b0 = (phip / (phim ** 2)) -1.d0 - (3.d0 * phi / phim)
		b0 = b0 / phi
		g0 = 1.d0 / phim
		k2 = k * k
		If (k>0.075d0) Then
			J10 = BESSEL_JN(1,k/2.d0)
			J11 = BESSEL_JN(1,k)
			J00 = BESSEL_JN(0,k/2.d0)
			ck = (4.d0 * a0 * J10 * J10/ k2) + (2.d0 * b0 * J00 * J10 / k) + (2.d0 * g0 * J11 / k)
		Else
      ck = a0 * ( (0.25d0 - k2 / 64.d0) ) + b0 * (0.5d0 - 3.d0 * k2 / 64.d0) + g0 * (1.d0 - k2 / 8.d0)
		End If
		ck = - pi * ck
		return
	End Function

	!Function that calculates the inverse of the structure factor of a Hard Disk Function
	!using Rosenfeld Fundamental Measure Theory structure
	Function isk_HD_ros(phi,k) result(isk)
		Implicit None
		Real * 8, intent(in) :: phi, k
		Real * 8 :: isk
		Real * 8 :: rho
		rho = 4.d0 * phi / pi
		isk = 1.d0 - rho * ck_HD_ros(phi,k)
		return
	End Function

	!Function that calculates the structure factor of a Hard Disk Function
	!using Rosenfeld Fundamental Measure Theory structure
	Function sk_HD_ros(phi,k) result(sk)
		Implicit None
		Real * 8, intent(in) :: phi, k
		Real * 8 :: sk
		sk = 1.d0 / isk_HD_ros(phi,k)
		return
	End Function

	!Auxiliary Function for the Baus-Colot direct correlation function
	Function aux_F_BC(q) result(F)
		Implicit None
		Real * 8, intent(in) :: q
		Real * 8 :: F
		If (q>0.075d0) Then
			F = 2.d0 * BESSEL_JN(1,q) / q
		Else
			F = 1.d0 - (q * q / 8.d0)
		End If
	End Function

	!Function that calculates the direct correlation function of a Hard Disk Function
	!using the Modified Baus-Colot structure by Guo and Riebel
	Function ck_HD_BCGR(phi,k) result(ck)
		Implicit None
		Real * 8, intent(in) :: phi, k
		Real * 8 :: ck
		Real * 8 :: c0, a, d, h, Fq, a2, x2, aqx, f2ak2, phi2,phi3,phi4
		Integer, parameter :: n_integrand = 2**10
		Real * 8, dimension(n_integrand) :: h_integrand, xp, xw
		Integer :: i1
		phi2 = phi * phi
		phi3 = phi2 * phi
		phi4 = phi2 * phi2
		d = 0.98946d0
		a = 0.3699d0 * phi4 - 1.2511d0 * phi3 + 2.0199d0 * phi2 - 2.2373d0 * phi + 2.1d0
		c0 = - (1.d0 - d * phi2) / ((1.d0 - 2.d0 * phi + d * phi2) ** 2)
		call Clenshaw_Curtis_quadrature(n_integrand,xp,xw)
		call rescale_OW(n_integrand,xp,xw,-1.d0,1.d0,1.d0/a,1.d0)
		Fq = aux_F_BC(k)
		a2 = a * a
		Do i1 = 1, n_integrand
			x2 = xp(i1) * xp(i1)
			aqx = a * k * xp(i1)
			h_integrand(i1) = sqrt( 1.d0 - x2 ) * ( Fq - a2 * x2 * aux_F_BC(aqx) )
		End Do
		h = 16.d0 * sum(h_integrand * xw) / pi
		f2ak2 = aux_F_BC(a * k / 2.d0)
		f2ak2 = f2ak2 * f2ak2
		ck = (4.d0 * (1.d0 - a2 * phi) * Fq) + (a2 * phi * (f2ak2 + h))
		ck = pi * c0 * ck / 4.d0
		return
	End Function

	!Function that calculates the inverse of the structure factor of a Hard Disk Function
	!using the Modified Baus-Colot structure by Guo and Riebel
	Function isk_HD_BCGR(phi,k) result(isk)
		Implicit None
		Real * 8, intent(in) :: phi, k
		Real * 8 :: isk
		Real * 8 :: rho
		rho = 4.d0 * phi / pi
		isk = 1.d0 - rho * ck_HD_BCGR(phi,k)
		return
	End Function

	!Function that calculates the structure factor of a Hard Disk Function
	!using the Modified Baus-Colot structure by Guo and Riebel
	Function sk_HD_BCGR(phi,k) result(sk)
		Implicit None
		Real * 8, intent(in) :: phi, k
		Real * 8 :: sk
		sk = 1.d0 / isk_HD_BCGR(phi,k)
		return
	End Function

	!This subroutine writes down the parameters related with structural calculation for
	!a Hard Disk system
	Subroutine writting_hd_p(sys_cond,approx,i_unit)
		Real * 8, dimension(:), intent(in) :: sys_cond
		Integer :: i_unit
		Character(*), intent(in) :: approx
		Real * 8 :: phi, T, lambda
		Integer :: i1
		!System conditions
		phi = sys_cond(1)
		Write(i_unit,*) "### Hard Disk ###"
		Write(i_unit,*) "Area Fraction phi = ", phi
		Write(i_unit,*) "###############################"
		Write(i_unit,*) "### Structure Approximation ###"
		Select case (approx)
		case ("ROSF")
			Write(i_unit,*) "				Rosenfeld Fundamental Measure Theory"
		case ("BCGR")
			Write(i_unit,*) "				Modified Baus-Colot structure by Guo and Riebel"
		case Default
			Write(i_unit,*) "				"//approx
		End Select
    Write(i_unit,*) "###############################"
	End Subroutine

End Module


C ================================================================
      real Function sqrEdge(xy1, xy2)
C ================================================================
C Routine computes sqruare distance between two points
C ================================================================
      real xy1(2), xy2(2)

      sqrEdge = (xy1(1) - xy2(1)) ** 2 + (xy1(2) - xy2(2)) ** 2
      Return
      End

C ================================================================
      real Function calEdge(xy1, xy2)
C ================================================================
C Routine computes distance between two points
C ================================================================
      real xy1(2), xy2(2)

      calEdge = sqrt((xy1(1) - xy2(1)) ** 2 +
     &                (xy1(2) - xy2(2)) ** 2)
      Return
      End

C ================================================================
      real Function calNorm(xy1)
C ================================================================
C Routine calculates norm of vector xy1
C ================================================================
      real xy1(2)

      calNorm = sqrt(xy1(1) ** 2 + xy1(2) ** 2)
      Return
      End

C ================================================================
      Subroutine extNormal(xy1, xy2, xy3, xyn)
C ================================================================
C Routines compute external normal vector to the edge {xy1, xy2}
C of triangle {xy1, xy2, xy3}
C ================================================================
      real xy1(2), xy2(2), xy3(2), xyn(2)
      real x, y, d

      x = xy2(1) - xy1(1)
      y = xy2(2) - xy1(2)

      d = sqrt(x * x + y * y)

      xyn(1) = -y / d
      xyn(2) =  x / d

c ... orientation
      x = xy3(1) - xy1(1)
      y = xy3(2) - xy1(2)

      If( x*xyn(1) + y*xyn(2).GT.0D0 ) Then
         xyn(1) = -xyn(1)
         xyn(2) = -xyn(2)
      End if

      Return
      End

C ================================================================
      Subroutine calNormal(xy1, xy2, xyn)
C ================================================================
C Routines compute a normal vector to the edge {xy1, xy2}
C ================================================================
      real xy1(2), xy2(2), xyn(2)
      real x, y, d

      x = xy2(1) - xy1(1)
      y = xy2(2) - xy1(2)

      d = sqrt(x * x + y * y)

      xyn(1) = -y / d
      xyn(2) =  x / d

      Return
      End

C ================================================================
      real Function DotMul(a, b)
C ================================================================
C Routine computes scalar product of two vectors
C ================================================================
      real a(2), b(2)

      DotMul = a(1) * b(1) + a(2) * b(2)
      Return
      End

C ================================================================
      real Function VecMul(a, b)
C ================================================================
C Routine computes vector product a x b which is a number in 2D.
C ================================================================
      real a(2), b(2)

      VecMul = a(1) * b(2) - a(2) * b(1)
      Return
      End

C ================================================================
      Logical Function check1j(i1, j)
C ================================================================
C check1j = TRUE if i1 belongs to the set j(3).
C ================================================================
      Integer j(3)

      check1j = .TRUE.
      If(i1.EQ.j(1)) goto 1000
      If(i1.EQ.j(2)) goto 1000
      If(i1.EQ.j(3)) goto 1000

      check1j = .FALSE.
 1000 Return
      End

C ================================================================
      Logical Function check12(i1, j1, j2)
C ================================================================
C check12 = TRUE if i1 belongs to the set {j1, j2}.
C ================================================================
      check12 = .TRUE.
      If(i1.EQ.j1) goto 1000
      If(i1.EQ.j2) goto 1000

      check12 = .FALSE.
 1000 Return
      End

C ================================================================
      Logical Function check22(i1, i2, j1, j2)
C ================================================================
C check22 = TRUE if pair {i1, i2} coinsides with {j1, j2}.
C ================================================================
      check22 = .FALSE.
      If(i1.NE.j1 .AND. i1.NE.j2) goto 1000
      If(i2.NE.j1 .AND. i2.NE.j2) goto 1000

      check22 = .TRUE.
 1000 Return
      End

C ================================================================
      Subroutine swapii(i1, i2)
C ================================================================
C Routine swaps two integers
C ================================================================
      i  = i1
      i1 = i2
      i2 = i

      Return
      End

C ================================================================
      Subroutine swapdd(d1, d2)
C ================================================================
C Routine swaps two real numbers
C ================================================================
      real d, d1, d2
      d  = d1
      d1 = d2
      d2 = d

      Return
      End


c
c
c =========================================================
       subroutine qinit(maxmx,meqn,mbc,mx,xlower,dx,q,maux,aux)
c =========================================================
c
c     # Set initial conditions for q.
c
      implicit double precision (a-h,o-z)
      dimension q(1-mbc:maxmx+mbc, meqn)
      dimension aux(1-mbc:maxmx+mbc, *)
      common /comrp/ grav
c
c
c      # data in middle state:
       h2 = 2.d0
       u2 = 0.d0
       hu2 = h2*u2
c
c      # data in left state:
       h1 = 4.d0
       u1 = dsqrt(0.5d0*grav*(h2/h1 - h1/h2) * (h2-h1))
       hu1 = h1*u1
c
c      # data in right state:
       h3 = 0.8d0
       u3 = -dsqrt(0.5d0*grav*(h2/h3 - h3/h2) * (h2-h3))
       hu3 = h3*u3
c
c
       s12 = (hu2-hu1) / (h2-h1)
       s23 = (hu2-hu3) / (h2-h3)
       write(6,*) 'shock speeds:', s12, s23

       do 150 i=1,mx
	     xedge = xlower + (i-1)*dx
	     if (xedge .lt. -4.0d0) then
		 q(i,1) = h1
		 q(i,2) = hu1
		else if (xedge .lt. -2.5d0) then
		 q(i,1) = h2
		 q(i,2) = hu2
		else
		 q(i,1) = h3
		 q(i,2) = hu3
		endif
  150        continue
c
      return
      end


subroutine croutsim(a, deter)
  real, dimension(:,:), intent(inout) :: a
  real, intent(out) :: deter

  integer :: n, i, j, k

  n = size(a(:,1))

  do i=2,n
    a(i,1) = a(i,1) / a(1,1)
  end do

  deter = a(1,1)

  do j = 2, n
    do k=1, j-1
      a(j,j) = a(j,j) - a(j,k)*a(j,k)*a(k,k)
    end do

    deter = deter*a(j,j)

    do i= j+1, n
      do k=1, j-1
        a(i,j) = a(i,j) - a(i,k)*a(k,k)*a(j,k)
      end do

      a(i,j) = a(i,j)/a(j,j)
    end do
  end do

end subroutine


module linalg
  !!********************************************************
  !*
  !*    DESCRIPTION: collection of matrix/vector linear algebra functions
  !*
  !*    FUNCTION LIST: dot, matvec, lincomb, unitvec
  !*
  !!*********************************************************
  implicit none
contains

  real*8 function dot(r_v,r_w)
    !c****************************************************************
    !c**
    !c** FILE NAME: dot.f
    !c**
    !c** DATE WRITTEN:7/15/90
    !c**
    !c** PROGRAMMER:Scott Hensley
    !c**
    !c** FUNCTIONAL DESCRIPTION: This routine computes the dot product of
    !c** two 3 vectors as a function.
    !c**
    !c** ROUTINES CALLED:none
    !c**
    !c** NOTES: none
    !c**
    !c** UPDATE LOG:
    !c**
    !c*****************************************************************

    !c INPUT VARIABLES:
    real*8, intent(in) :: r_v(3),r_w(3) !3x1 vectors

    !c compute dot product of two 3-vectors
    dot = r_v(1)*r_w(1) + r_v(2)*r_w(2) + r_v(3)*r_w(3)
  end function dot

  subroutine matvec(r_t,r_v,r_w)

    !c****************************************************************
    !c**
    !c**	FILE NAME: matvec.for
    !c**
    !c**     DATE WRITTEN: 7/20/90
    !c**
    !c**     PROGRAMMER:Scott Hensley
    !c**
    !c** 	FUNCTIONAL DESCRIPTION: The subroutine takes a 3x3 matrix
    !c**     and a 3x1 vector a multiplies them to return another 3x1
    !c**	vector.
    !c**
    !c**     ROUTINES CALLED:none
    !c**
    !c**     NOTES: none
    !c**
    !c**     UPDATE LOG:
    !c**
    !c****************************************************************

    !c	INPUT VARIABLES:
    real*8, intent(in) :: r_t(3,3)                            !3x3 matrix
    real*8, intent(in) :: r_v(3)                              !3x1 vector

    !c   	OUTPUT VARIABLES:
    real*8, intent(out) :: r_w(3)                              !3x1 vector

    !c  	PROCESSING STEPS:

    !c       compute matrix product
    r_w(1) = r_t(1,1)*r_v(1) + r_t(1,2)*r_v(2) + r_t(1,3)*r_v(3)
    r_w(2) = r_t(2,1)*r_v(1) + r_t(2,2)*r_v(2) + r_t(2,3)*r_v(3)
    r_w(3) = r_t(3,1)*r_v(1) + r_t(3,2)*r_v(2) + r_t(3,3)*r_v(3)

  end subroutine matvec

  subroutine lincomb(r_k1,r_u,r_k2,r_v,r_w)

    !c****************************************************************
    !c**
    !c**	FILE NAME: lincomb.for
    !c**
    !c**     DATE WRITTEN: 8/3/90
    !c**
    !c**     PROGRAMMER:Scott Hensley
    !c**
    !c** 	FUNCTIONAL DESCRIPTION: The subroutine forms the linear combination
    !c**	of two vectors.
    !c**
    !c**     ROUTINES CALLED:none
    !c**
    !c**     NOTES: none
    !c**
    !c**     UPDATE LOG:
    !c**
    !c*****************************************************************

    !c	INPUT VARIABLES:
    real*8, intent(in), dimension(3) :: r_u                              !3x1 vector
    real*8, intent(in), dimension(3) ::  r_v                              !3x1 vector
    real*8, intent(in) ::  r_k1				 !scalar
    real*8, intent(in) ::  r_k2				 !scalar

    !c   	OUTPUT VARIABLES:
    real*8, intent(out) ::  r_w(3)                              !3x1 vector

    !c  	PROCESSING STEPS:

    !c       compute linear combination

    r_w(1) = r_k1*r_u(1) + r_k2*r_v(1)
    r_w(2) = r_k1*r_u(2) + r_k2*r_v(2)
    r_w(3) = r_k1*r_u(3) + r_k2*r_v(3)

  end subroutine lincomb

  !c*****************************************************************

  subroutine unitvec(r_v,r_u)

    !c****************************************************************
    !c**
    !c**	FILE NAME: unitvec.for
    !c**
    !c**     DATE WRITTEN: 8/3/90
    !c**
    !c**     PROGRAMMER:Scott Hensley
    !c**
    !c** 	FUNCTIONAL DESCRIPTION: The subroutine takes vector and returns
    !c**     a unit vector.
    !c**
    !c**     ROUTINES CALLED:none
    !c**
    !c**     NOTES: none
    !c**
    !c**     UPDATE LOG:
    !c**
    !c*****************************************************************

    implicit none

    !c	INPUT VARIABLES:
    real*8, intent(in), dimension(3) ::  r_v                              !3x1 vector

    !c   	OUTPUT VARIABLES:
    real*8, intent(out), dimension(3) ::  r_u                              !3x1 vector

    !c	LOCAL VARIABLES:
    real*8 r_n

    !c  	PROCESSING STEPS:

    !c       compute vector norm

    r_n = sqrt(r_v(1)**2 + r_v(2)**2 + r_v(3)**2)

    if(r_n .ne. 0)then
       r_u(1) = r_v(1)/r_n
       r_u(2) = r_v(2)/r_n
       r_u(3) = r_v(3)/r_n
    endif

  end  subroutine unitvec

!c****************************************************************

        function norm(r_v)

!c****************************************************************
!c**
!c**    FILE NAME: norm.for
!c**
!c**     DATE WRITTEN: 8/3/90
!c**
!c**     PROGRAMMER:Scott Hensley
!c**
!c**    FUNCTIONAL DESCRIPTION: The subroutine takes vector and returns
!c**     its norm.
!c**
!c**     ROUTINES CALLED:none
!c**
!c**     NOTES: none
!c**
!c**     UPDATE LOG:
!c**
!c*****************************************************************

!c      INPUT VARIABLES:
        real*8 r_v(3)                              !3x1 vector

!c      OUTPUT VARIABLES:see input

!c      LOCAL VARIABLES:
        real*8 norm

!c      PROCESSING STEPS:

!c       compute vector norm

        norm = sqrt(r_v(1)**2 + r_v(2)**2 + r_v(3)**2)

        end function norm

end module linalg