      SUBROUTINE SHTCC (MODE,LPIVOT,L1,M,U,  UPARAM,C,LDC,NVC)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 SHTCC  Krogh   Added external statement.
C>> 1994-11-11 SHTCC  Krogh   Declared all vars.
C>> 1994-10-20 SHTCC  Krogh  Changes to use M77CON
C>> 1987-08-19 SHTCC  Lawson  Initial code.
c--S replaces "?": ?HTCC, ?NRM2
c
C        Construction and/or application of a single Householder
C     transformation..     Q = I + U*(U**T)/b
c     where I is the MxM identity matrix, b is a scalar, and U is an
c     M-dimensional Householder vector.
c        All vectors are M-vectors but only the components in positions
c     LPIVOT, and L1 through M, will be referenced.
c        This version, identified by CC at the end of its name, is
c     specialized for the Column-Column case, i.e. U() is a vector or
c     a column of a matrix and C() is regarded a containing a set
c     of column vectors to which transformations will be applied.
c     ------------------------------------------------------------------
C                         Subroutine arguments
c
C     MODE  [in]  = 1 OR 2   When MODE = 1 this subr determines the
c           parameters for a Householder transformation and applies
c           the transformation to NVC vectors.  When MODE = 2 this
c           subr applies a previously determined Householder
c           transformation.
C     LPIVOT  [in]  The index of the pivot element.
C     L1,M  [in]  If L1 .le. M  elements LPIVOT and L1 through M will
c           be referenced.  If L1 .gt. M the subroutine returns
c           immediately.  This may be regarded
c           as performing an identity transformation.
C     U()  [inout]  Contains an M-dimensional vector with storage
c           spacing of 1 between elements.
c           When MODE = 1 this is the vector from which Householder
c           parameters are to be determined.
c           When MODE = 2 this is the result from previous computation
c           with MODE = 1.
c     UPARAM  [inout]  Holds a value that supplements the
c           contents of U() to complete the definition of a
c           Householder transformation.  Computed when MODE = 1 and
c           reused when MODE = 2.
c           UPARAM is the pivot component of the Householder U-vector.
C     C()  [inout]  On entry contains a set of NVC M-vectors to which a
c          Householder transformation is to be applied.
c          On exit contains the set of transformed vectors.
C          These vectors are the columns of an M x NVC matrix in C(,).
C     LDC  [in]  Leading dimension of C(,).  Require LDC .ge. M.
C     NVC  [in]  Number of vectors in C(,) to be transformed.
c           If NVC .le. 0 no reference will be made to the array C(,).
c     ------------------------------------------------------------------
c     Subprograms referenced: SNRM2
c     ------------------------------------------------------------------
c          This code was originally developed by Charles L. Lawson and
c     Richard J. Hanson at Jet Propulsion Laboratory in 1973.  The
c     original code was described and listed in the book,
c
c                  Solving Least Squares Problems
c                  C. L. Lawson and R. J. Hanson
c                  Prentice-Hall, 1974
c
c     Feb, 1985, C. L. Lawson & S. Y. Chan, JPL.  Adapted code from the
c     Lawson & Hanson book to Fortran 77 for use in the JPL MATH77
c     library.
c     Prefixing subprogram names with S or D for s.p. or d.p. versions.
c     Using generic names for intrinsic functions.
c     Adding calls to BLAS and MATH77 error processing subrs in some
c     program units.
c     July, 1987. CLL.  Changed user interface so method of specifying
c     column/row storage options is more language-independent.
C     ------------------------------------------------------------------
      external SNRM2
      real             U(*), UPARAM, C(*), SNRM2
      real             B, FAC, HOLD, VNORM, ONE, ZERO, SUM, BINV
      integer MODE, LPIVOT, L1, M, LDC, NVC
      integer JCBASE, JCPIV, IUL0, J, I
      parameter (ONE = 1.0E0, ZERO = 0.0E0)
C     ------------------------------------------------------------------
      if (0.ge.LPIVOT .or. LPIVOT.ge.L1 .or. L1.gt.M) return
      if( MODE .eq. 1) then
C                            ****** CONSTRUCT THE TRANSFORMATION. ******
         IUL0 = L1 - 1
         if(IUL0 .eq. LPIVOT) then
            VNORM = SNRM2(M-L1+2, U(IUL0), 1)
         else
            HOLD = U(IUL0)
            U(IUL0) = U(LPIVOT)
            VNORM = SNRM2(M-L1+2, U(IUL0), 1)
            U(IUL0) = HOLD
         endif
c
         if (U(LPIVOT) .gt. ZERO) VNORM = -VNORM
         UPARAM = U(LPIVOT)-VNORM
         U(LPIVOT) = VNORM
      endif
C            ****** Apply the transformation  I + U*(U**T)/B  to C. ****
C
      if (NVC .le. 0) return
      B = UPARAM * U(LPIVOT)
C                                 Here B .le. 0.  If B  =  0., return.
      if (B .eq. ZERO) return
      BINV = ONE / B
      JCBASE = 0
c
      do 120 J = 1,NVC
         JCPIV = JCBASE + LPIVOT
         SUM = C(JCPIV) * UPARAM
         do 90 I = L1, M
            SUM = SUM + C(JCBASE+I)*U(I)
   90    continue
         if (SUM .NE. ZERO) then
            FAC = SUM * BINV
            C(JCPIV) = C(JCPIV) + FAC*UPARAM
            do 110 I =  L1, M
               C(JCBASE+I) = C(JCBASE+I) + FAC*U(I)
  110       continue
         endif
         JCBASE = JCBASE + LDC
  120 continue
      return
      end


program log_det_test
  use m_util
  implicit none

  real(dp), dimension(3,3) :: A
  real(dp) :: expected

  A = reshape((/ 1.0_dp, 5.0_dp, 20.0_dp, -2.0_dp, -0.5_dp, 8.0_dp, 7.0_dp, 1.0_dp, 0.0_dp /), (/ 3, 3 /))

  expected = 5.71042701737487_dp
  if (abs(logdet(A)-expected) > 1.0d-10) stop 1

end program log_det_test


Module hard_sphere_structure_module
  Implicit None
  Real * 8, Dimension(:), Allocatable :: Int_absci_1, Int_weight_1
  Integer, Parameter :: Int_points=100
  Real * 8, Dimension(:) , Allocatable :: musj
  Contains

  !Function for the calculation of the structure factor for a Hard Sphere System
  Real * 8 Function Sk_HS_py(vw_option,phi_val,k_val)
    Implicit None
    Logical, Intent(in) :: vw_option  !Logical variable for Verlet-Weiss correction if True
    Real * 8, Intent(in) :: phi_val !Volume fraction value
    Real * 8, Intent (in) :: k_val !Value of the wave vector
    Real * 8 :: k_vw,k_func,ckdum,phi_vw,dum1,dum2,dum3,dum4,dumsin,dumcos
    Real * 8 :: k_vw2,k_vw3,k_vw4,k_vw6
    If (vw_option .EQV. .TRUE.) Then
      !Verlet-Weiss correction for the volume fraction
      phi_vw=phi_val*(1.d0 - (phi_val / 16.d0))
      !Verlet-Weiss correction for the wave-vector
      k_vw= k_val * ( ( phi_vw / phi_val ) ** ( 1.d0 / 3.d0 ) )
    Else
      phi_vw=phi_val
      k_vw= k_val
    End If
    dum1= - ( ( 1.d0 + 2.d0 * phi_vw ) ** 2 )
    dum2= 6.d0 * phi_vw * ( ( 1.d0 + ( phi_vw / 2.d0 ) ) ** 2 )
    dum3= - 0.5d0 * phi_vw * ( ( 1.d0 + ( 2.d0 * phi_vw ) ) ** 2 )
    dum4= ( 1.d0 - phi_vw )
    dum4= dum4 ** 4
    dum1= dum1 / dum4
    dum2= dum2 / dum4
    dum3= dum3 / dum4
    k_vw2=k_vw * k_vw
    If (k_vw > 0.075d0 ) Then
      dumsin= sin( k_vw )
      dumcos= cos( k_vw )
      k_vw3=k_vw2 * k_vw
      k_vw4=k_vw3 * k_vw
      k_vw6=k_vw4 * k_vw2
      ckdum= ( dum1 * ( dumsin - k_vw * dumcos ) / ( k_vw3 ) ) + &
      & ( dum2 * ( ( ( 2.d0 * k_vw ) * dumsin ) + ( ( - ( k_vw2 ) + 2.d0 ) * dumcos ) - 2.d0 ) / &
      & ( k_vw4 ) ) + ( dum3 * ( ( ( 4.d0 * ( k_vw3 ) - 24.d0 * k_vw ) * dumsin )&
      & + ( ( - ( k_vw4 ) + 12.d0 * ( k_vw2 ) - 24.d0 ) * dumcos ) + 24.d0 ) / ( k_vw6 ))
    Else
      ckdum = dum1 * ( (1.d0 / 3.d0) - ( k_vw2 / 30.d0 ) ) + dum2 * ( 0.25d0 -  ( k_vw2 / 36.d0 ) ) &
      & + dum3 * ( ( 1.d0 / 6.d0 ) - ( k_vw2 / 48.d0 ) )
    End If
    ckdum =  24.d0 * phi_vw * ckdum
    Sk_HS_py = 1.d0 / ( 1.d0 - ckdum )
    return
    !*********!
  End Function

  !Subroutine for the calculation of the Structure factor of a Hard Sphere System
  !for an array of wave vectors "k_val" of dimension "k_points" that goes into
  !a predefined array "sk_val"
  !vw_option Logical value, True for Verlet-Weiss Correction, False Otherwise
  Subroutine Calc_Sk_HS_py_mono(vw_option,phi_val,k_points,k_val,sk_val)
    Implicit None
    Logical, Intent(in) :: vw_option  !Logical variable for activating Verlet-Weiss correction if True
    Real * 8, Intent(in) :: phi_val !Volume fraction of the system
    Real * 8, Dimension(:), Intent(in) :: k_val !Wave vector array
    Real * 8, Dimension(:), Intent(out) :: sk_val !Structure factor array
    Integer, Intent(in) :: k_points
    Integer :: i1
    Do i1=1, k_points
      sk_val(i1)=Sk_HS_py(vw_option,phi_val,k_val(i1))
    End Do
  End Subroutine

  !Function for the calculation of the structure factor of Hard Disk System using Rosenfeld Approximation
  Real * 8 Function Sk_HD_ros(phi_val,k_val)
    Implicit None
    Real * 8, Intent(in) :: phi_val
    Real * 8, Intent(in) :: k_val
    Integer :: i1
    Real * 8 :: A,B,G,J0,J1,J12,Z1,Z2,X, phi_val2, phi_val3, phi_val4,dum1
    Real * 8 :: k_val2
    phi_val2=phi_val * phi_val
    phi_val3=phi_val2 * phi_val
    phi_val4=phi_val3 * phi_val
    Z1= ( 1.d0 + 0.128d0 * ( phi_val2 ) + 0.027d0 * ( phi_val3 ) + 0.06d0 * &
    & ( phi_val4 ) ) / ( 1.d0 - phi_val ) ** 2
    Z2= ( ( 2.d0 * 0.128d0 * phi_val ) + ( 3.d0 * 0.027d0 * ( phi_val2 ) ) + &
    & ( 4.d0 * 0.06d0 * ( phi_val3 ) ) ) * ( ( 1.d0 - phi_val ) ** 2 )
    Z2= ( Z2 / ( 1.d0 - phi_val ) ** 4 ) + ( 2.d0 * ( Z1 / ( 1.d0 - phi_val ) ) )
    !Z1=1.0d0/(1.d0-eta(1))**2.d0
    !Z2=2.0d0/(1.d0-eta(1))**3.d0
    X= Z1 + phi_val * Z2
    G= Sqrt( Z2 / 2.d0 )
    A= ( 1.d0 + ( ( 2.d0 * phi_val - 1.d0 ) * X ) + ( 2.d0 * phi_val * G ) ) / phi_val
    B= ( ( ( 1.d0 - phi_val ) * X ) - 1.d0 - ( 3.d0 * phi_val * G ) ) / phi_val
    If ( k_val > 0.075d0 ) Then
    	J0= BESSEL_JN ( 0 , k_val/ 2.d0 )
    	J1= BESSEL_JN ( 1 , k_val/ 2.d0 )
    	J12= BESSEL_JN ( 1 , k_val )
      dum1= A * ( ( 2.d0 * J1 / k_val ) ** 2 ) + ( B * 2.d0 * J0 * J1 /k_val ) + G * 2.d0 * J12 /k_val
    Else
      k_val2= k_val * k_val
      dum1= A * ( ( 0.25d0 - k_val2 / 64.d0 ) ) + ( B  * ( 0.5d0 - 3.d0 * k_val2 / 64.d0 )  ) &
      & + G * ( 1.d0 - k_val2 / 8.d0  )
    End If
    dum1=  dum1 * 4.d0 * phi_val
    Sk_HD_ros= 1.d0 / ( 1.d0 + dum1 )
    return
  End Function

  !Subroutine for the calculation of the Structure factor of a Hard Disk System
  !for an array of wave vectors "k_val" of dimension "k_points" that goes into
  !a predefined array "sk_val" using the approximation derived by Rosenfeld
  Subroutine Calc_Sk_hd_ros_mono(phi_val,k_points,k_val,sk_val)
    Implicit None
    Real * 8, Intent(in) :: phi_val !Volume fraction of the system
    Real * 8, Dimension(:), Intent(in) :: k_val !Wave vector array
    Real * 8, Dimension(:), Intent(out) :: sk_val !Structure factor array
    Integer, Intent(in) :: k_points
    Integer :: i1
    Do i1=1, k_points
      sk_val(i1)=Sk_HD_ros(phi_val,k_val(i1))
    End Do
  End Subroutine

  !!Function that calculates the structure factor of a HARD Sphere + Atractive Yukawa
  !System with particle size equal to the unit using Sharma Sharma approximation
  Real * 8 Function  Sk_HSAY(vw_option,phi_val,Temp_val,z_yuk,k_val)
    Implicit None
    Logical, Intent(in) :: vw_option  !Logical variable for Verlet-Weiss correction if True
    Real * 8, Intent (in) :: phi_val !Volume fraction value
    Real * 8, Intent (in) :: k_val !Value of the wave vector
    Real * 8, Intent (in) :: Temp_val !Value of the Temperature
    Real * 8, Intent (in) :: z_yuk !Value of the screening constant
    Real * 8 :: dum1,ck_dum
    ck_dum= ( 1.d0 / Sk_HS_py(vw_option,phi_val,k_val) )
    If ( k_val > 0.075d0 ) Then
      dum1= 24.d0 * phi_val * ( ( k_val * cos(k_val) ) + ( z_yuk * sin(k_val) ) ) &
      & / ( Temp_val * k_val * ( ( k_val ** 2 ) + ( z_yuk ** 2) ) )
    Else
      dum1= 24.d0 * phi_val * ( ( 1.d0 - 0.5d0 * k_val ** 2 ) + ( z_yuk * ( 1.d0 - &
      & k_val ** 2 / 6.d0 ) ) ) / ( Temp_val * ( ( k_val ** 2 ) + ( z_yuk ** 2) ) )
    End If
    ck_dum= ck_dum-dum1
    sk_HSAY= 1.d0 / ck_dum
    return
  End Function

  !Subroutine for the calculation of the Structure factor of a Hard Sphere + Atractive
  !Yukawa System for an array of wave vectors "k_val" of dimension "k_points" that goes into
  !a predefined array "sk_val", with "vw_option" Logical value which for True selects Verlet-Weiss Correction
  Subroutine Calc_Sk_HSAY_sh_sh(vw_option,phi_val,Temp_val,z_yuk,k_points,k_val,sk_val)
    Implicit None
    Logical, Intent(in) :: vw_option  !Logical variable for activating Verlet-Weiss correction if True
    Real * 8, Intent(in) :: phi_val !Volume fraction of the system
    Real * 8, Intent(in) :: Temp_val !Value of the temperature
    Real * 8, Intent(in) :: z_yuk !Value of the Yukawa screening reach
    Real * 8, Dimension(:), Intent(in) :: k_val !Wave vector array
    Real * 8, Dimension(:), Intent(out) :: sk_val !Structure factor array
    Integer, Intent(in) :: k_points
    Integer :: i1
    Do i1=1, k_points
      sk_val(i1)=Sk_HSAY(vw_option,phi_val,Temp_val,z_yuk,k_val(i1))
    End Do
  End Subroutine

  !Function that calculates the structure factor of a HARD Disk + Atractive Yukawa
  !System with particle size equal to the unit using Sharma Sharma approximation
  Real * 8 Function  Sk_HDAY(phi_val,Temp_val,z_yuk,k_val)
    Implicit None
    Real * 8, Intent (in) :: phi_val !Volume fraction value
    Real * 8, Intent (in) :: k_val !Value of the wave vector
    Real * 8, Intent (in) :: Temp_val !Value of the Temperature
    Real * 8, Intent (in) :: z_yuk !Value of the screening constant
    Real * 8 :: dum1,ck_dum,y, J0
    Real * 8, Parameter :: dy=1.d-5
    ck_dum= ( 1.d0 / Sk_HD_ros(phi_val,k_val) )
    !FOURIER TRANSFORM OF beta u(r)
    y= 1.d0 !initial value of integration -> Particle size =1.d0
    dum1= 0.d0
    Do While ( exp(- z_yuk * y ) > dy )
    	J0= BESSEl_JN(0, k_val * y)
    	dum1= dum1 + J0 * exp(- y * z_yuk  )
    	y= y + dy
    End Do
    dum1 = 8.d0 * phi_val * dum1 * ( dy ) * exp( z_yuk ) / Temp_val !!!!!!!!!!!!!!!!!!!!!!!!!!!rho beta u
    ck_dum=ck_dum-dum1
    sk_HDAY= 1.d0 / ck_dum
    return
  End Function

  !Function that calculates the structure factor of a HARD Disk + Atractive Yukawa
  !System with particle size equal to the unit using Sharma Sharma approximation
  Real * 8 Function  Sk_HDAY2(phi_val,Temp_val,z_yuk,k_val)
    Implicit None
    Real * 8, Intent (in) :: phi_val !Volume fraction value
    Real * 8, Intent (in) :: k_val !Value of the wave vector
    Real * 8, Intent (in) :: Temp_val !Value of the Temperature
    Real * 8, Intent (in) :: z_yuk !Value of the screening constant
    Real * 8 :: dum1,ck_dum,y, J0, weight
    Integer :: EOFint,i1
    ck_dum= ( 1.d0 / Sk_HD_ros(phi_val,k_val) )
    !FOURIER TRANSFORM OF beta u(r)
    dum1= 0.d0
    EOFint=0
    i1=0
    Do i1=1,Int_points
      y= Int_absci_1(i1)
      weight=Int_weight_1(i1)
      J0= BESSEl_JN(0, k_val * y)
    	dum1= dum1 + weight *J0 * exp(- y * z_yuk  )
    End Do
    dum1 = 8.d0 * phi_val * ( 1.d0 / ( SQRT( z_yuk ** 2 + k_val ** 2) ) - dum1  ) * exp( z_yuk ) / Temp_val !!!!!!!!!!!!!!!!!!!!!!!!!!!rho beta u
    ck_dum=ck_dum-dum1
    sk_HDAY2= 1.d0 / ck_dum
    return
  End Function

  !Obtention of the abscissas and weights for the integral used in Sk_HDAY2
  Subroutine Sk_HDAY2_integral_constants(Allocation)
    Implicit None
    Integer :: EOFint,i1
    Logical, Intent(in) :: Allocation
    If (Allocation .eqv. .True.) Then
      Allocate(Int_absci_1(Int_points))
      Allocate(Int_weight_1(Int_points))
      Open(unit=33, File="./source_code/operations/Integral_method1_abscisas_weights.dat", Status="Old" )
      Do i1=1,Int_points
        Read (33, *, IOSTAT=EOFint) Int_absci_1(i1), Int_weight_1(i1)
      End Do
      Close(33)
    Else
      Deallocate(Int_absci_1)
      Deallocate(Int_weight_1)
    End If
  End Subroutine

  !Subroutine for the calculation of the Structure factor of a Hard Disk + Atractive
  !Yukawa System for an array of wave vectors "k_val" of dimension "k_points" that goes into
  !a predefined array "sk_val", with "vw_option" Logical value which for True selects Verlet-Weiss Correction
  Subroutine Calc_Sk_HDAY_sh_sh(phi_val,Temp_val,z_yuk,k_points,k_val,sk_val)
    Implicit None
    Real * 8, Intent(in) :: phi_val !Volume fraction of the system
    Real * 8, Intent(in) :: Temp_val !Value of the temperature
    Real * 8, Intent(in) :: z_yuk !Value of the Yukawa screening reach
    Real * 8, Dimension(:), Intent(in) :: k_val !Wave vector array
    Real * 8, Dimension(:), Intent(out) :: sk_val !Structure factor array
    Integer, Intent(in) :: k_points
    Integer :: i1
    Do i1=1, k_points
      !sk_val(i1)=Sk_HDAY(phi_val,Temp_val,z_yuk,k_val(i1))
      sk_val(i1)=Sk_HDAY2(phi_val,Temp_val,z_yuk,k_val(i1))
    End Do
  End Subroutine

  Real * 8 Function spinodal_T_HDAY(phi_val,z_yuk)
    Implicit None
    Real * 8, Intent(in) :: phi_val, z_yuk
    spinodal_T_HDAY= 8.d0 * phi_val * Sk_HD_ros(phi_val,0.d0) / z_yuk
  End

  Real * 8 Function spinodal_T_HSAY(phi_val,z_yuk,vw_option)
    Implicit None
    Real * 8, Intent(in) :: phi_val, z_yuk
    Logical, intent(in) :: vw_option
    Real * 8 :: phi_dum
    if (vw_option .eqv. .true. ) then
      phi_dum = phi_val*(1.d0 - (phi_val / 16.d0))
    else
      phi_dum = phi_val
    end if
    spinodal_T_HSAY = 24.d0 * phi_dum * (z_yuk + 1.d0) * Sk_HS_py(vw_option,phi_val,0.d0) / (z_yuk ** 2)
  end

  Real * 8 Function blip_TLJ(Temp_val,dimension,nu_val)
    Use integration_module
    Implicit None
    Real * 8, Intent(in) :: Temp_val,dimension,nu_val
    Real * 8 :: dx, x
    Real * 8, Dimension(:), Allocatable :: Integrand
    Integer :: nx, i1
    dx=1.d-6
    nx= Int(1.d0/dx)
    Allocate(Integrand(nx))
    Do i1=1, nx
      x=i1*dx
      Integrand(i1) = ( (x) ** (dimension-1.d0) ) * exp(- ( (x ** - (2 * nu_val ) ) &
      &- 2.d0 * (x ** (-nu_val)) + 1.d0) / Temp_val )
    End Do
    blip_TLJ=1.d0 - dimension * DIntegral_simpson_3_8(Integrand,nx,dx)
    blip_TLJ=blip_TLJ**( 1.d0 / dimension )
    Deallocate(Integrand)
  End

  Subroutine Calc_gr_HDAY(grs,rs,kmax_val, phi_val, Temp_val, z_yuk, np, k)
    Implicit None
    Real * 8, Dimension(:), Intent(out) :: grs
    Real * 8, Dimension(:), Intent(out) :: rs
    Real * 8, Intent(in) :: kmax_val
    REal * 8, Intent(in) :: phi_val, Temp_val, z_yuk
    Real * 8, Dimension(:), Intent(out) :: k
    Integer, Intent(in) :: np
    Real * 8 :: K_max, R_max, ri,kj, J0,J1
    Integer :: i1, i2
    Do i1=1, np
      k(i1)= musj(i1) * kmax_val /musj(np)
      rs(i1) = musj(i1) / kmax_val
    End Do

    Do i1=1,np
      grs(i1)=0.d0
      Do i2=1,np-1
        J0=BESSEl_JN(0,(k(i2)*rs(i1)))
        J1=BESSEl_JN(1,(k(i2)*rs(np)))
        J1= J1 * J1
        grs(i1)= grs(i1) + (Sk_HDAY2(phi_val,Temp_val,z_yuk,k(i1)) * J0 / J1 )
      End Do
      grs(i1) = grs(i1) / (4.d0 * Atan(1.d0) * rs(np) * rs(np) )
    End Do
  End Subroutine

  Subroutine Calc_Sk_HDAY_low_rho(np,musj,rs,ks, R_max, phi_val, Temp_val, Z_yuk, grV, SkV)
    Implicit None
    Real * 8, Dimension(:), Intent(out) :: grV, SkV
    Real * 8, Dimension(:) :: rs, ks
    Real * 8, Dimension(:), Intent(in) :: musj
    Real * 8, Intent(in) :: phi_val, Temp_val, Z_yuk
    Integer, Intent(in) :: np
    Real * 8 :: R_max, J0 , J1, kn, delta_rho
    Integer :: i1, i2

    !Calculation of the wave vectors, radial distances and radial distribution
    Do i1=1, np
      ks(i1) = musj(i1) / R_max
      rs(i1) = musj(i1) * R_max / musj(np)
      grV(i1) = low_rho_gr_HDAY(rs(i1), Temp_val, Z_yuk)
    End Do
    kn = ks(np)
    !Calculation of the structure factor for each wave vector
    !S(k) = 1 + (ρ4π/k) ∫ g(r) Sin(kr) dr
    Do i1=1,np
      SkV(i1) = 0.d0
      !J0=rs(1)*grV(1)*BESSEl_JN(0,(ks(i1) * rs(1)))
      Do i2=2,np!-1
        delta_rho= rs(i2) - rs(i2-1)
        J0=BESSEl_JN(0,(ks(i1) * rs(i2)))
        J1=BESSEl_JN(1,(kn * rs(i2)))
        J1= J1 * J1
        SkV(i1) = SkV(i1) + ( (grV(i2)-1.d0) * J0 / J1 )
        !J1=rs(i2)*(grV(i2)-1.d0)*BESSEl_JN(0,(ks(i1) * rs(i2)))
        !SkV(i1) = SkV(i1) + 0.5d0 * delta_rho * (J0+J1)
        !J0=J1
      End Do
      SkV(i1) = 1.d0 + (16.d0 * phi_val * SkV(i1) / (kn * kn ))
      !SkV(i1) = 1.d0 + (8.d0 * phi_val * SkV(i1))
    End Do

  End Subroutine

 Real * 8 Function low_rho_gr_HDAY(X_val,Temp_val,Z_val)
   Implicit None
   Real * 8 :: X_val, Temp_val, Z_val
   If (X_val < 1.d0 ) Then
     low_rho_gr_HDAY =0.d0
   Else
     low_rho_gr_HDAY = exp( exp(- Z_val * (X_val-1) ) / (Temp_val * X_val) )
   End If
 End

 Subroutine Calc_hk_ck(Sk_val,knp_val,rho_val,hk_v,ck_v)
    Implicit None
    Real * 8, Dimension(:), Intent(in) :: Sk_val
    Real * 8, Dimension(:), Intent(out) :: hk_v, ck_v
    Integer, Intent(in) :: knp_val
    Real * 8 :: rho_val
    hk_v = (Sk_val - 1.d0 ) / rho_val
    ck_v = (1.d0 - (1.d0 / Sk_val)  )/rho_val
  End Subroutine

  Subroutine Calc_FT_2D_radial(rnp,Fr,Fk,rv,kv)
    Implicit None
    Real * 8, Dimension(:) :: Fr, Fk, rv, kv
    Integer :: rnp
    Integer :: i1,i2
    Real * 8 :: kn,kn2, int_const, J0, J1
    kn=kv(rnp)
    kn2=kn*kn
    int_const =  4.d0* 4.d0 * Atan(1.d0) / kn2
    Do i1=1,rnp
      Fk(i1) = 0.d0
      Do i2=1,rnp-1
        J0=BESSEl_JN(0,(kv(i1) * rv(i2)))
        J1=BESSEl_JN(1,(kn * rv(i2)))
        J1= J1 * J1
        Fk(i1) = Fk(i1) + ( (Fr(i2)) * J0 / J1 )
      End Do
      Fk(i1) = int_const * Fk(i1)
    End Do

  End Subroutine

  Subroutine Calc_IFT_2D_radial(rnp,Fr,Fk,rv,kv)
    Implicit None
    Real * 8, Dimension(:) :: Fr, Fk, rv, kv
    Integer :: rnp
    Integer :: i1,i2
    Real * 8 :: rn,rn2, int_const, J0, J1
    rn=rv(rnp)
    rn2=rn*rn
    int_const = 1.d0 / (rn2 * 4.d0 * Atan(1.d0))
    Do i1=1,rnp
      Fr(i1) = 0.d0
      Do i2=1,rnp-1
        J0=BESSEl_JN(0,(kv(i2) * rv(i1)))
        J1=BESSEl_JN(1,(rn * kv(i2)))
        J1= J1 * J1
        Fr(i1) = Fr(i1) + ( (Fk(i2)) * J0 / J1 )
      End Do
      Fr(i1) = int_const * Fr(i1)
    End Do

  End Subroutine

  Subroutine Calc_sk_HDAY_Sharma_Sharma_V2(knp_val,rv,kv, phi_val, Temp_val, Z_yuk, grV, SkV)
   Implicit None
   Real * 8, Dimension(:) :: grV, SkV
   Real * 8, Dimension(:) :: rv, kv
   Real * 8, Intent(in) :: phi_val, Temp_val, Z_yuk
   Integer, Intent(in) :: knp_val
   Real * 8, Dimension(:), Allocatable :: ck_v, hk_v, cr_v, hr_v, Sk_aux, Yk_v,Yr_v
   Real * 8 :: rho_val,dum1
   Integer :: i1, i2
   Allocate(ck_v(knp_val))
   Allocate(hk_v(knp_val))
   Allocate(cr_v(knp_val))
   Allocate(hr_v(knp_val))
   Allocate(Sk_aux(knp_val))
   rho_val= phi_val / Atan(1.d0)
   Call Calc_Sk_hd_ros_mono(phi_val, knp_val,kv,SkV)
   Call Calc_hk_ck(Skv,knp_val,rho_val,hk_v,ck_v)
   cr_v=0.d0
   Do i1=1, knp_val
     if( rv(i1) >= 1.d0 ) cr_v(i1) = exp(exp(-Z_yuk * (rv(i1) - 1.d0) ) / (Temp_val*rv(i1))) - 1.d0
   End Do
   Call Calc_FT_2D_radial(knp_val,cr_v,Sk_aux,rv,kv)
   ck_v = ck_v + Sk_aux
   SkV= 1.d0 / (1.d0 - rho_val * ck_v)
   !Open(unit=10, file="ck_PY.dat", Status="Replace")
   !Do i1=1, knp_val
   ! Write(10,*), kv(i1), ck_v(i1), Sk_aux(i1)
   !End Do
   !Close(10)
   Deallocate(ck_v)
   Deallocate(hk_v)
   Deallocate(cr_v)
   Deallocate(hr_v)
   Deallocate(Sk_aux)
 End Subroutine

End Module


    subroutine fcn(me,x,y,f)
    !! subroutine computing the value of \(dy/dx=f(x,y)\)

    use iso_fortran_env,    only: wp => real64

    use easydop853_module

    implicit none

    class(dop853_class),intent(inout) :: me
    !! dop853_class object
    real(wp),intent(in)               :: x
    !! independent variable \(x\)
    real(wp),dimension(:),intent(in)  :: y
    !! state vector \(y(x)\)
    real(wp),dimension(:),intent(out) :: f
    !! derivative vector \(f(x,y)=dy/dx\)

    f(1:3)=y(4:6)
    f(4:6)=-y(1:3)/sum(y(1:3)**2.0_wp)**1.5_wp

    end subroutine fcn


module example_eigen

use phaml
implicit none

private
public setup_example_eigen

real(my_real), save :: prob_param=25.0_my_real

contains

subroutine setup_example_eigen()
use pde_pointers
call set_pde_pointers(pdecoefs, bconds, iconds, trues, truexs, trueys)
end subroutine

subroutine pdecoefs(x,y,cxx,cxy,cyy,cx,cy,c,rs)
real(my_real), intent(in) :: x,y
real(my_real), intent(out) :: cxx(:,:),cxy(:,:),cyy(:,:),cx(:,:),cy(:,:), &
                              c(:,:),rs(:)
cxx(1,1) = 1.0_my_real
cyy(1,1) = 1.0_my_real
c(1,1) = 0.5_my_real*prob_param*(x*x+3.0_my_real*y*y)
rs(1) = 1.0_my_real

cxy=0; cx=0; cy=0
end subroutine pdecoefs

subroutine bconds(x,y,bmark,itype,c,rs)
real(my_real), intent(in) :: x,y
integer, intent(in) :: bmark
integer, intent(out) :: itype(:)
real(my_real), intent(out) :: c(:,:),rs(:)
itype = DIRICHLET
c = 0.0_my_real
rs(1) = 0.0_my_real
end subroutine bconds

function iconds(x,y,comp,eigen)
real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real(my_real) :: iconds
iconds = 0.0_my_real
end function iconds

function trues(x,y,comp,eigen) ! real (my_real)
real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real (my_real) :: trues
real (my_real) :: xmax,ymax,tmax,d,sq3
sq3 = sqrt(3.0_my_real)
d = sqrt(prob_param/8)

select case (eigen)

case(1)

   trues = exp(-d*(x*x+sq3*y*y))

! Eigenvectors are unique up to a multiplicative constant, and are scaled to
! have M-norm 1.0; this is approximately the scaling factor for this solution

!   trues = 1.217006012276_my_real * trues

! TEMP disabling the 2nd and 3rd true solutions because 1) the scale factor
!      seems to be slightly off, 2) can't determine the sign of the scale factor

case(2)

   trues = huge(0.0_my_real)
!   xmax = sqrt(1/(2*d))
!   tmax = xmax*exp(-d*xmax**2)
!   trues = x*exp(-d*(x*x+sq3*y*y))
!   trues = 1.04009347278_my_real * trues / tmax

case(3)

   trues = huge(0.0_my_real)
!   ymax = sqrt(1/(2*sq3*d))
!   tmax = ymax*exp(-d*sq3*ymax**2)
!   trues = y*exp(-d*(x*x+sq3*y*y))
!   trues = 1.038366656409_my_real * trues / tmax

case default

   trues = huge(0.0_my_real)

end select

end function trues

function truexs(x,y,comp,eigen) ! real (my_real)
real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real (my_real) :: truexs

real (my_real) :: xmax,ymax,tmax,d,sq3
sq3 = sqrt(3.0_my_real)
d = sqrt(prob_param/8)

select case (eigen)

case(1)

   truexs = exp(-d*(x*x+sq3*y*y))
   truexs = -2*d*x*truexs
!   truexs = 1.217006012276_my_real * truexs

! TEMP disabling the 2nd and 3rd true solutions because 1) the scale factor
!      seems to be slightly off, 2) can't determine the sign of the scale factor

case(2)

   truexs = huge(0.0_my_real)
!   xmax = sqrt(1/(2*d))
!   tmax = xmax*exp(-d*xmax**2)
!   truexs = exp(-d*(x*x+sq3*y*y))
!   truexs = (1-2*d*x*x)*truexs
!   truexs = 1.04009347278_my_real * truexs / tmax

case(3)

   truexs = huge(0.0_my_real)
!   ymax = sqrt(1/(2*sq3*d))
!   tmax = ymax*exp(-d*sq3*ymax**2)
!   truexs = exp(-d*(x*x+sq3*y*y))
!   truexs = -2*d*x*y*truexs
!   truexs = 1.038366656409_my_real * truexs / tmax

case default

   truexs = huge(0.0_my_real)

end select

end function truexs

function trueys(x,y,comp,eigen) ! real (my_real)
real(my_real), intent(in) :: x,y
integer, intent(in) :: comp,eigen
real (my_real) :: trueys

real (my_real) :: xmax,ymax,tmax,d,sq3

sq3 = sqrt(3.0_my_real)
d = sqrt(prob_param/8)

select case (eigen)

case(1)

   trueys = exp(-d*(x*x+sq3*y*y))
   trueys = -2*sq3*d*y*trueys
!   trueys = 1.217006012276_my_real * trueys

! TEMP disabling the 2nd and 3rd true solutions because 1) the scale factor
!      seems to be slightly off, 2) can't determine the sign of the scale factor

case(2)

   trueys = huge(0.0_my_real)
!   xmax = sqrt(1/(2*d))
!   tmax = xmax*exp(-d*xmax**2)
!   trueys = exp(-d*(x*x+sq3*y*y))
!   trueys = -2*sq3*d*y*x*trueys
!   trueys = 1.04009347278_my_real * trueys / tmax

case(3)

   trueys = huge(0.0_my_real)
!   ymax = sqrt(1/(2*sq3*d))
!   tmax = ymax*exp(-d*sq3*ymax**2)
!   trueys = exp(-d*(x*x+sq3*y*y))
!   trueys = (1-2*d*sq3*y**2)*trueys
!   trueys = 1.038366656409_my_real * trueys / tmax

case default

   trueys = huge(0.0_my_real)

end select

end function trueys

end module


      double precision function DPQUAD(KORDER, NPC, XI, PC, X1, X2)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1994-10-20 DPQUAD Krogh  Changes to use M77CON
c>> 1992-11-12 DPQUAD C. L. Lawson, JPL  Saving IL1 and IL2.
c>> 1992-10-27 C. L. Lawson, JPL
c>> 1988-03-16 C. L. Lawson, JPL
C
C   This subroutine computes the integral over [X1,X2] of a
c   piecewise polynomial using the piecewise Power
c   representation given by [XI, PC, NPC, KORDER].
c   The degrees of the polynomial pieces are KORDER-1.
c   Require  2 .le. KORDER .le. 20.
c   Permits X1 .le. X2 or X1 gt. X2.
C   The "proper interpolation interval" is from XI(1) to XI(NPC+1).
c   For most reliable results, X1 and X2 should lie in this
c   interval, however this subr will give a result even if this
c   is not the case by use of extrapolation.
c     ------------------------------------------------------------------
C  DESCRIPTION OF ARGUMENTS
C  INPUT:
c    KORDER   [in]  Order of the polynomial pieces.  This is one
c           greater than the degree of the pieces.  KORDER is also the
c           leading dimension of the array PC(,).
c           Require  2 .le. KORDER .le. 20.
c    NPC    - NUMBER OF POLYNOMIAL PIECES
C    XI()    - Breakpoint array of length NPC+1
C    PC(i,j) - Coeffs for the Power representation of a piecewise
c              polynomial.   i=1,KORDER , j=1,NPC
c              The coeffs PC(*,j) are used at XI(j) and on the
c              interval between XI(j) and XI(j+1).
c              PC(i,j) is the coefficient to be multiplied times
c              (X - X(j))**(i-1).
C    X1,X2  - END POINTS OF QUADRATURE INTERVAL, NORMALLY IN
C                XI(1) .LE. X .LE. XI(NPC+1) but extrapolation is
c                permitted.
C
c  OUTPUT:
c     DPQUAD - Integral of the piecewise polynomial from X1 to X2.
c     ------------------------------------------------------------------
c     Adapted from subroutine PPQUAD due to D. E. Amos,
c     Sandia, June, 1979.  Documented in SAND79-1825.  PPQUAD uses the
c     Taylor basis, whereas this subprogram uses the Power basis.
c     Uses the [XI, PC, NPC, KORDER] representation of a piecewise
c     polynomial as presented by Carl De Boor in
c     A PRACTICAL GUIDE TO SPLINES, Springer-Verlag, 1978.
c     (Called [XI, C, LXI, K] in the book.)
c     ------------------------------------------------------------------
c--D replaces "?": ?PQUAD, ?SFIND
c     ------------------------------------------------------------------
      integer II, IL1, IL2, IM, KORDER, LEFT, MODE, NPC
      double precision A, AA, B, BB, DENOM, DX, ONE
      double precision Q, S, SS(2), PC(KORDER,NPC)
      double precision X, X1, X2, XI(NPC+1)
      double precision ZERO
      parameter(ONE = 1.0D0, ZERO = 0.0D0)
      save IL1, IL2
      data IL1, IL2 / 1,1 /
c     ------------------------------------------------------------------
C
      AA= min(X1,X2)
      BB= max(X1,X2)
      Q = ZERO
      if(AA .eq. BB) go to 90
      call DSFIND ( XI, 1, NPC+1, AA, IL1, MODE )
      call DSFIND ( XI, 1, NPC+1, BB, IL2, MODE )
      do 50 LEFT=IL1,IL2
         if(LEFT .eq. IL1) then
            A=AA
         else
            A= XI(LEFT)
         endif
         if(LEFT .eq. IL2) then
            B = BB
         else
            B = XI(LEFT+1)
         endif
         X = A
         do 40 II=1,2
            SS(II) = ZERO
            DX=X-XI(LEFT)
            if(DX .ne. ZERO) then
               DENOM = dble(KORDER)
               S=PC(KORDER,LEFT)/DENOM
               do 30 IM = KORDER-1, 1, -1
                  DENOM = DENOM - ONE
                  S = S * DX + PC(IM,LEFT) / DENOM
   30          continue
               SS(II)=S*DX
            endif
            X = B
   40    continue
         Q=Q+(SS(2)-SS(1))
   50 continue
      if(X1 .gt. X2) Q=-Q
   90 continue
      DPQUAD = Q
      return
      end


	FUNCTION PS_BVSQ  ( datain, nparm, clev, ivcord )
C************************************************************************
C* PS_BVSQ								*
C*									*
C* This function computes the square of the Brunt-Vaisala Frequency.	*
C*									*
C* REAL PS_BVSQ  ( DATAIN, NPARM, CLEV, IVCORD )			*
C*									*
C* Input parameters:							*
C*	DATAIN(NPARM,*)	REAL		Station data			*
C*	NPARM		INTEGER		Number of data set parameters	*
C*	CLEV		REAL		Vertical level			*
C*	IVCORD		INTEGER 	Vertical coordinate number	*
C*									*
C* Output parameters:							*
C*	PS_BVSQ		REAL		Brunt-Vaisala Frequency **2	*
C**									*
C* Log:									*
C* J. Nielsen/SUNYA	 8/90						*
C* T. Lee/GSC		 8/97	Changed default depth to RMISSD		*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		datain (*)
C*
	REAL		stndl (10), stndb (10), stndt (10)
C*
	INCLUDE		'ERMISS.FNC'
C-----------------------------------------------------------------------------
	PS_BVSQ = RMISSD
C
C*	Get data at this layer, unless requested otherwise.
C
	dfdpth = RMISSD
	idfcrd = 3
	CALL PC_DPTH  ( datain, nparm, clev, ivcord, dfdpth, idfcrd, 1,
     +		 	depth, idcord, stndl, stndb, stndt, ier )
C
C*	Check for missing data.
C
	IF  ( ier .ne. 0 )  RETURN
	IF  ( ERMISS ( stndt (1) ) .or. ERMISS ( stndb (1) ) .or.
     +	      ERMISS ( stndt (2) ) .or. ERMISS ( stndb (2) ) .or.
     +	      ERMISS ( stndt (6) ) .or. ERMISS ( stndb (6) ) )  RETURN
	depth = stndt (6) - stndb (6)
	IF  ( depth .eq. 0.0 )  RETURN
C*
	thtop = PR_THTA ( stndt (2), stndt (1) )
	thbot = PR_THTA ( stndb (2), stndb (1) )
        theav = ( thtop + thbot ) / 2.
C
C*	Compute N**2.
C
        bvfsqd = ( GRAVTY / theav ) * ( thtop - thbot ) / depth
	IF  ( bvfsqd .lt. 0.0 )  RETURN
	PS_BVSQ = bvfsqd
C*
	RETURN
	END


!  *******************************************************************
!  *                                                                 *
!  *                     Function dlspx2                             *
!  *                                                                 *
!  *******************************************************************
!  Double Precision Version 1.71
!  Written by Gordon A. Fenton, Sept. 1989
!  Latest Update: May 9, 2001
!
!  PURPOSE  returns the covariance between two points in a 2-D random field
!           with Gaussian type covariance function (separable and mean-square
!           differentiable).
!
!  This function returns the covariance between two points, separated
!  by lag vector {X,Y}, in a 2-D random field having separable (and mean-
!  square differentiable) covariance function
!
!      B(x,y) = var * exp{ -pi*(|x|/thx)^2 } * exp{ -pi*(|y|/thy)^2 }
!
!  If var < 0, then this function returns the variance of a local average
!  of the process, |var|*V(X,Y), averaged over the domain X x Y.
!  Thus the variance function is also separable and can be written
!  as the product of two one-d variance functions corresponding to the
!  exponential correlation function
!
!         V(X,Y) = V(X)*V(Y)
!
!  where individual functions are based on the 1-D analytical model
!
!         V(X) = (1/a*a) * [pi*(|X|/thx)*erf(a) + exp(-a*a) - 1]
!
!  where a = (|X|*sqrt(pi))/thx and erf(.) is the error function,
!  dthx is the directional scale of fluctuation, and var is the
!  point variance. The variance of a local average is given by
!  var*V(X,Y).
!
!  See page 186 of "Random Fields" by E. Vanmarcke and G.A. Fenton's
!  thesis for more details.
!
!  The parameters var, dthx, and dthy are brought into this
!  routine through the common block /dparam/.
!
!  The arguments to this routine, X and Y, are the components of the lag
!  vector between the two points (or the dimensions of the averaging
!  region, if var < 0).
!
!  The data value `eund' is designed to avoid underflow errors arising from
!  exp(-a) for a > eund. We quite happily accept a zero in this case. This
!  tends to be compiler dependent.
!
!  REVISION HISTORY:
!  1.3	eliminated unused local variables `two' and `four' (Dec 5/96)
!  1.4	added lvarfn flag to end of /dparam/ common block. Set it to
!	true if the variance function is to be returned. Otherwise this
!	function returns the covariance. (May 31/00)
!  1.5	eliminated lvarfn -- now return covariances only if var < 0 (Mar 27/01)
!  1.6	properly handled sign on var for covariances (Apr 5/01)
!  1.7	reversed default - now return covariances if var > 0. (Apr 11/01)
!  1.71	revised above documentation to reflect revision 1.7 (May 9/01)
!---------------------------------------------------------------------------
      real*8 function dlspx2( X, Y )
      implicit real*8 (a-h,o-z)
      common/dparam/ var, pb, dthx, dthy, dthz
      data zero/0.d0/, one/1.d0/
      data rtpi/1.77245385090551588d0/, eund/300.d0/
      data pi/3.1415926535897932384d0/
      exp(s)   = dexp(s)
      abs(s)   = dabs(s)
      r_erf(s) = derf(s)

      if( var .lt. zero ) then			! return variance function
         rx = abs(X)/dthx
         ry = abs(Y)/dthy
         a  = rtpi*rx
         aa = a*a
         b  = rtpi*ry
         bb = b*b
!						in the x direction
         if( X .eq. zero ) then
            dsepa = one
         elseif( aa .lt. eund ) then
            dsepa = (pi*rx*r_erf(a) + exp(-aa) - one)/aa
         else
            dsepa = (pi*rx - one)/aa
         endif
!						and in the y direction
         if( Y .eq. zero ) then
            dsepb = one
         elseif( bb .lt. eund ) then
            dsepb  = (pi*ry*r_erf(b) + exp(-bb) - one)/bb
         else
            dsepb = (pi*ry - one)/bb
         endif
         dlspx2 = -var*dsepa*dsepb

      else					! var < 0, return covariance
!							in the x direction
         if( dthx .eq. zero ) then
            if( X .eq. zero ) then
               dsepa = one
            else
               dsepa = zero
            endif
         else
            rx = X/dthx
            px = pi*rx*rx
            if( px .lt. eund ) then
               dsepa = exp(-px)
            else
               dsepa = zero
            endif
         endif
!							in the y direction
         if( dthy .eq. zero ) then
            if( Y .eq. zero ) then
               dsepb = one
            else
               dsepb = zero
            endif
         else
            ry = Y/dthy
            py = pi*ry*ry
            if( py .lt. eund ) then
               dsepb = exp(-py)
            else
               dsepb = zero
            endif
         endif
         dlspx2 = var*dsepa*dsepb
      endif

      return
      end


      REAL             FUNCTION SBESY0 (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 1996-03-30 SBESY0 Krogh  Added external statement.
C>> 1995-11-13 SBESY0 Krogh  Changes to simplify conversion to C.
C>> 1994-11-11 SBESY0 Krogh   Declared all vars.
C>> 1994-10-20 SBESY0 Krogh  Changes to use M77CON
C>> 1990-11-29 SBESY0 CLL
C>> 1985-08-02 SBESY0 Lawson  Initial code.
C JULY 1977 EDITION.  W. FULLERTON, C3, LOS ALAMOS SCIENTIFIC LAB.
C C.L.LAWSON & S.CHAN, JPL, 1984 FEB ADAPTED TO JPL MATH77 LIBRARY.
c     ------------------------------------------------------------------
c--S replaces "?": ?BESY0, ?BESJ0, ?BMP0, ?INITS, ?CSEVL, ?ERM1
c     ------------------------------------------------------------------
      EXTERNAL R1MACH, SBESJ0, SCSEVL
      INTEGER NTY0
      REAL             X, BY0CS(19), AMPL, THETA, TWODPI, XSML,
     1  Y, R1MACH, SCSEVL, SBESJ0
C
C SERIES FOR BY0        ON THE INTERVAL  0.          TO  1.60000E+01
C                                        WITH WEIGHTED ERROR   8.14E-32
C                                         LOG WEIGHTED ERROR  31.09
C                               SIGNIFICANT FIGURES REQUIRED  30.31
C                                    DECIMAL PLACES REQUIRED  31.73
C
      SAVE NTY0, XSML
C
      DATA BY0CS / -.1127783939286557321793980546028E-1,
     *  -.1283452375604203460480884531838E+0,
     *  -.1043788479979424936581762276618E+0,
     *  +.2366274918396969540924159264613E-1,
     *  -.2090391647700486239196223950342E-2,
     *  +.1039754539390572520999246576381E-3,
     *  -.3369747162423972096718775345037E-5,
     *  +.7729384267670667158521367216371E-7,
     *  -.1324976772664259591443476068964E-8,
     *  +.1764823261540452792100389363158E-10,
     *  -.1881055071580196200602823012069E-12,
     *  +.1641865485366149502792237185749E-14,
     *  -.1195659438604606085745991006720E-16,
     *  +.7377296297440185842494112426666E-19,
     *  -.3906843476710437330740906666666E-21,
     *  +.1795503664436157949829120000000E-23,
     *  -.7229627125448010478933333333333E-26,
     *  +.2571727931635168597333333333333E-28,
     *  -.8141268814163694933333333333333E-31     /
C
      DATA TWODPI / 0.636619772367581343075535053490057E0 /
      DATA NTY0, XSML / 0, 0.E0 /
C     ------------------------------------------------------------------
      IF (NTY0 .eq. 0) then
      call SINITS (BY0CS, 19, 0.1E0*R1MACH(3), NTY0)
      XSML = SQRT (4.0E0*R1MACH(3))
      endif
C
      IF (X .LE. 0.E0) THEN
        SBESY0 = 0.E0
        CALL SERM1 ('SBESY0',1,0,'X IS ZERO OR NEGATIVE','X',X,'.')
      ELSE IF (X .LE. 4.E0) THEN
        IF (X .LE. XSML) THEN
          Y = 0.E0
        ELSE
          Y = X * X
        END IF
        SBESY0 = TWODPI*LOG(0.5E0*X)*SBESJ0(X) + .375E0 +
     *            SCSEVL (.125E0*Y-1.E0, BY0CS, NTY0)
      ELSE
        CALL SBMP0 (X, AMPL, THETA)
        SBESY0 = AMPL * SIN(THETA)
      END IF
C
      RETURN
C
      END


    Program dsbgv_example

!     DSBGV 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: dsbgv
      Use lapack_precision, Only: dp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter :: nin = 5, nout = 6
      Character (1), Parameter :: uplo = 'U'
!     .. Local Scalars ..
      Integer :: i, info, j, ka, kb, ldab, ldbb, n
!     .. Local Arrays ..
      Real (Kind=dp), Allocatable :: ab(:, :), bb(:, :), w(:), work(:)
      Real (Kind=dp) :: dummy(1, 1)
!     .. Intrinsic Procedures ..
      Intrinsic :: max, min
!     .. Executable Statements ..
      Write (nout, *) 'DSBGV Example Program Results'
      Write (nout, *)
!     Skip heading in data file
      Read (nin, *)
      Read (nin, *) n, ka, kb
      ldab = ka + 1
      ldbb = kb + 1
      Allocate (ab(ldab,n), bb(ldbb,n), w(n), work(3*n))

!     Read the upper or lower triangular parts of the matrices A and
!     B from data file

      If (uplo=='U') Then
        Read (nin, *)((ab(ka+1+i-j,j),j=i,min(n,i+ka)), i=1, n)
        Read (nin, *)((bb(kb+1+i-j,j),j=i,min(n,i+kb)), i=1, n)
      Else If (uplo=='L') Then
        Read (nin, *)((ab(1+i-j,j),j=max(1,i-ka),i), i=1, n)
        Read (nin, *)((bb(1+i-j,j),j=max(1,i-kb),i), i=1, n)
      End If

!     Solve the generalized symmetric band eigenvalue problem
!     A*x = lambda*B*x

      Call dsbgv('No vectors', uplo, n, ka, kb, ab, ldab, bb, ldbb, w, dummy, &
        1, work, info)

      If (info==0) Then

!       Print solution

        Write (nout, *) 'Eigenvalues'
        Write (nout, 100) w(1:n)
      Else If (info>n .And. info<=2*n) Then
        i = info - n
        Write (nout, 110) 'The leading minor of order ', i, &
          ' of B is not positive definite'
      Else
        Write (nout, 120) 'Failure in DSBGV. INFO =', info
      End If

100   Format (3X, (6F11.4))
110   Format (1X, A, I4, A)
120   Format (1X, A, I4)
    End Program


!This module contains two types that are required for the simulation:
!Vectors for calculating and storing objects' positions, velocities and accelerations
!Objects (planets, stars, moons etc.), that are made up of mass and forementioned vectors. Objects are essentially used for
!storing values.

module types_mod
      use param_mod
      !Creation of types
      type:: vector
              real(rk)::x,y,z
      end type vector
      type:: object
              character(len=50)::description
              real(rk)::mass
              type(vector)::pos
              type(vector)::vel
              type(vector)::acc
       end type object

       !Operators and routine assignment for vector calculations
       interface operator(+)
               module procedure vadd
       end interface operator(+)
       interface operator(-)
               module procedure vsub
       end interface operator(-)
       interface operator(*)
               module procedure vmul
       end interface operator(*)
       interface operator(/)
               module procedure vdiv
       end interface operator(/)
contains
       !Simple vector subroutines and also a subroutine for calculating the length of a vector

       !Addition
       type(vector) function vadd(v,u)
               implicit none
               type(vector),intent(in)::v,u
               vadd%x=v%x+u%x
               vadd%y=v%y+u%y
               vadd%z=v%z+u%z
       end function vadd

       !Subtraction
       type(vector) function vsub(v,u)
               implicit none
               type(vector),intent(in)::v,u
               vsub%x=v%x-u%x
               vsub%y=v%y-u%y
               vsub%z=v%z-u%z
       end function vsub

       !Multiplication
       type(vector) function vmul(v,k)
               implicit none
               real(rk),intent(in)::k
               type(vector),intent(in)::v
               vmul%x=k*v%x
               vmul%y=k*v%y
               vmul%z=k*v%z
       end function

       !Division
       type(vector) function vdiv(v,k)
               implicit none
               real(rk),intent(in)::k
               type(vector),intent(in)::v
               vdiv%x=v%x/k
               vdiv%y=v%y/k
               vdiv%z=v%z/k
       end function

       !Vector length
       real(rk) function vectorlen(v)
               implicit none
               type(vector),intent(in)::v
               vectorlen=sqrt((v%x)**2+(v%y)**2+(v%z)**2)
       end function vectorlen
end module types_mod


! Calculate the exponential integral using the algorithm of
! [1] Tseng, Lee, Journal of Hydrology, 205 (1998) 38-51
module m_exponential_integral

   implicit none

   real, parameter :: series_laguerre = 4.0

contains

   ! Calculate the exponential integral E_1(x):
   !
   !        inf
   !          /     -t
   !         |     e
   ! E (x) = | dt -----
   !  1      |      t
   !        /
   !         x
   !
   ! Input:  arg - position at which exponential integral is evaluated (arg > 0)
   ! Output: res - E_1(arg)
   pure subroutine calculateExponentialIntegral(arg, res)

      implicit none

      real, intent(in)  :: arg
      real, intent(inout) :: res

      ! For arguments smaller than 4 the series expansion is used
      if (arg < series_laguerre) then
         res = seriesExpansion(arg)

         ! otherwise a Gauss-Laguerre expansion is better
      else
         res = exp(-arg)*gauss_laguerre(arg)
      endif

   end subroutine calculateExponentialIntegral

   ! Series expansion of the exponential integral
   !
   !                          n_cut
   !                          -----     n  n
   !                           \    (-1)  x
   ! E (x) = -gamma - ln(x) -   )   --------
   !  1                        /     n * n!
   !                          -----
   !                          n = 1
   !
   ! where gamma is the Euler constant.
   ! n_cut is set to 25
   ! Input: arg - argument for which the exponential integral is approximated
   ! Return: approximation by series expansion for E_1(arg)
   pure real function seriesExpansion(arg)

      implicit none

      real, intent(in) :: arg

      real    :: res, fact  ! result of the summation, 1 / n
      integer :: i          ! counter variable

      real, parameter :: EULER_GAMMA = 0.57721566490153286060651209008241 ! Euler constant
      integer, parameter :: ITERATION = 25 ! Cutoff for series expansion

      ! initialize summation result
      res = 0.0

      ! perform the summation
      do i = ITERATION, 2, -1
         ! calculate 1/n
         fact = 1.0/i
         ! add next term of summation
         res = arg*fact*(fact - res)
      end do

      ! calculate the final result
      seriesExpansion = -EULER_GAMMA - log(arg) + arg*(1.0 - res)

   end function seriesExpansion

   ! The Gauss Laguerre expansion of the exponential integral can be written as
   !
   !              N
   ! E (arg)    -----    a
   !  1          \        n
   ! ------- =    )   --------
   !   -arg      /    x  + arg
   !  e         -----  n
   !             n=1
   !
   ! where the a_n and x_n are determined by least quadrature and are given in [1]
   ! Input: arg - point at which Gaussian Laguerre quadrature is calculated
   ! Return: E_1(arg) in this approximation
   pure real function gauss_laguerre(arg)

      implicit none

      real, intent(in) :: arg

      ! the quadrature constants a_n and x_n from [1]
      real, parameter :: a(1:15) = (/ &
                         0.2182348859400869e+00, 0.3422101779228833e+00, 0.2630275779416801e+00, &
                         0.1264258181059305e+00, 0.4020686492100091e-01, 0.8563877803611838e-02, &
                         0.1212436147214252e-02, 0.1116743923442519e-03, 0.6459926762022901e-05, &
                         0.2226316907096273e-06, 0.4227430384979365e-08, 0.3921897267041089e-10, &
                         0.1456515264073126e-12, 0.1483027051113301e-15, 0.1600594906211133e-19/)
      real, parameter :: x(1:15) = (/ &
                         0.9330781201728180e-01, 0.4926917403018839e+00, 0.1215595412070949e+01, &
                         0.2269949526203743e+01, 0.3667622721751437e+01, 0.5425336627413553e+01, &
                         0.7565916226613068e+01, 0.1012022856801911e+02, 0.1313028248217572e+02, &
                         0.1665440770832996e+02, 0.2077647889944877e+02, 0.2562389422672878e+02, &
                         0.3140751916975394e+02, 0.3853068330648601e+02, 0.4802608557268579e+02/)

      ! Calculate the summation
      gauss_laguerre = sum(a/(x + arg))

   end function gauss_laguerre

end module m_exponential_integral


	FUNCTION PR_DDEP ( tmpx, dwpx )
C************************************************************************
C* PR_DDEP								*
C*									*
C* This function computes DPDX, the dewpoint depression, from TMPX and 	*
C* DWPX, both of which must be in the same units (Celsius, Kelvin, or	*
C* Fahrenheit).  The output will be calculated in these units.  The 	*
C* following equation is used:						*
C*									*
C*               DPDX = TMPX - DWPX					*
C*									*
C* REAL PR_DDEP  ( TMPX, DWPX )   					*
C*									*
C* Input parameters:							*
C*	TMPX		REAL    	Air temperature 		*
C*	DWPX		REAL		Dewpoint temperature		*
C*									*
C* Output parameters:							*
C*	PR_DDEP		REAL		Dewpoint depression		*
C**									*
C* Log:									*
C* M. Goodman/RDS	1/84	Original source				*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	7/88	Documentation, variable names		*
C************************************************************************
        INCLUDE  'GEMPRM.PRM'
        INCLUDE  'ERMISS.FNC'
C------------------------------------------------------------------------
	IF  ( ERMISS (tmpx) .or. ERMISS (dwpx) .or.
     +	    ( dwpx .gt. tmpx ) )  THEN
	    PR_DDEP = RMISSD
	  ELSE
	    PR_DDEP = tmpx - dwpx
	END IF
C*
	RETURN
	END