! Copyright (c) 1997-1999, 2003 Massachusetts Institute of Technology
!
! This program is free software; you can redistribute it and/or modify
! it under the terms of the GNU General Public License as published by
! the Free Software Foundation; either version 2 of the License, or
! (at your option) any later version.
!
! This program is distributed in the hope that it will be useful,
! but WITHOUT ANY WARRANTY; without even the implied warranty of
! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
! GNU General Public License for more details.
!
! You should have received a copy of the GNU General Public License
! along with this program; if not, write to the Free Software
! Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
!

!      Simple program to demonstrate calling the wrapper routines
!      to perform 1D transforms in Fortran.  This program should be
!      linked with -lfftw -lm (assuming double-precision FFTW).  Note
!      also that the plan should be integer*8 on a 64-bit machine.

      program test

      implicit none

       include "fftw_f77.i"

      integer N
      parameter(N=16)
      double complex in, out
      dimension in(N),out(N)

      integer i,j

      integer plan

      write(*,*) 'Input array:'
      do i = 1,N,1
            j=i-1
            in(i) = dcmplx(float(j*j),float(1))
            write(*,*) '    in(',i,') = ',in(i)
      enddo

      call fftw_f77_create_plan(plan,N,FFTW_FORWARD,FFTW_ESTIMATE)

      call fftw_f77(plan,1,in,1,0,out,1,0)

        write(*,*) 'Output array:'
        do i = 1,N,1
                write(*,*) '    out(',i,') = ',out(i)
        enddo

      call fftw_f77_destroy_plan(plan)

      call fftw_f77_create_plan(plan,N,FFTW_BACKWARD,FFTW_ESTIMATE)

        call fftw_f77(plan,1,out,1,0,in,1,0)

        write(*,*) 'Output array after inverse FFT:'
        do i = 1,N,1
                write(*,*) '    ',N,' * in(',i,') = ',in(i)
        enddo

        call fftw_f77_destroy_plan(plan)

      end


      subroutine CGESLT(A,LDA,N,IPVT,B)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
c>> 2000-02-01 CGESLT  Krogh   Removed ZERO as a parameter.
c>> 1996-03-30 CGESLT  Krogh   Added external statement.
C>> 1992-05-18 CLL
C>> 1987-08-14 CGESLT Lawson  Initial code.
C
C     This subroutine solves the system of equations  (A**h) * X = B
C     using the LU factorization of A given in the array A().
c     Here A**h denotes the conjugate transpose of A.
c     ------------------------------------------------------------------
c                        Subroutine arguments
C
C     A(,)  [in]  An array of size at least N x N.  On entry must
c            contain the LU factors of an N x N  matrix, A.  It is
c            expected that this factorization will have been computed by
c            use of _GEFA, either directly or indirectly via use of
c            _GECO, _GEFS or _GEFSC.  This subr will not alter the
c            contents of A(,).
C
C     LDA  [in]  Leading dimensioning parameter for the array A(,).
C
C     N  [in]  The order of the original matrix, A.
C
C     IPVT()  [in]  An integer array of length at least N, containg a
c           record of the row interchanges made during factorization of
c           A.
C
c     B()  [inout]  On entry contains the right-side N-vector for the
c           problem, (A**h) * X = B.  On return contains the solution
c           N-vector, X.
c     ------------------------------------------------------------------
C     ERROR CONDITION
C
C        A DIVISION BY ZERO WILL OCCUR IF THE INPUT FACTOR CONTAINS A
C        ZERO ON THE DIAGONAL.  TECHNICALLY THIS INDICATES SINGULARITY
C        BUT IT IS OFTEN CAUSED BY IMPROPER ARGUMENTS OR IMPROPER
C        setting of LDA.  The user can avoid sending a singular matrix
c        to this subr by testing INFO (set by _GEFS or _GEFA) or
c        RCOND (set by _GEFSC or _GECO before calling this subr.
c        Nonsingularity is indicated by INFO .eq. 0 or RCOND .ne. 0.
c     ------------------------------------------------------------------
C     LINPACK. THIS VERSION DATED 08/14/78 .
C     CLEVE MOLER, UNIVERSITY OF NEW MEXICO, ARGONNE NATIONAL LAB.
c     Ref: LINPACK Users' Guide, by J. J. Dongarra, C. B. Moler,
c     J. R. Bunch, and G. W. Stewart, publ by Soc. for Indust. and Appl.
c     Math, Philadelphia, 1979.
c     Adapted from LINPACK for the JPL Math77 library by
c     C. L. Lawson, JPL, Aug 1987.
c     ------------------------------------------------------------------
c     Subprograms referenced: CDOTC
C     ------------------------------------------------------------------
      EXTERNAL CDOTC
      INTEGER LDA, N, IPVT(N), K, KB, L, NM1
      COMPLEX A(LDA,N), B(N), CDOTC, T
C     ------------------------------------------------------------------
      NM1 = N - 1
C
C        SOLVE  CTRANS(A) * X = B
C        FIRST SOLVE  CTRANS(U) * Y = B
C
         DO 60 K = 1, N
            T = CDOTC(K-1,A(1,K),1,B(1),1)
c           5/18/92 CLL The following stmt rewritten to avoid a bug in
c           the current SUN Fortran compiler.
c           IF (A(K,K) .NE. (0.e0, 0.e0)) THEN
            if(real(A(K,K)) .ne. 0.0e0 .or.
     *          aimag(A(K,K)) .ne. 0.0e0) then
              B(K) = (B(K) - T)/CONJG(A(K,K))
            ELSE
              CALL ERMSG('CGESLT',1,0,'A diagonal element is zero','.')
              RETURN
            END IF
   60    CONTINUE
C
C        NOW SOLVE CTRANS(L)*X = Y
C
         DO 80 KB = 1, NM1
            K = N - KB
            B(K) = B(K) + CDOTC(N-K,A(K+1,K),1,B(K+1),1)
            L = IPVT(K)
            IF (L .EQ. K) GO TO 70
               T = B(L)
               B(L) = B(K)
               B(K) = T
   70       CONTINUE
   80    CONTINUE
      RETURN
      END


program time_dependent
    ! Compile as ```gfortran time_dependent.f90 -o time_dependent finite_difference.o split_op.o -llapack -Wall -lfftw3 -frecursive```
    ! After compiling ```gfortran -c finite_difference.f90 -llapack``` and ```gfortran -c split_op.f90```
    use finite_diff
    use split_op

    integer :: NN, ii, n_eigen, timesteps, INFO, N_grid
    real*8, parameter :: L = 10, pi = acos(-1.0)
    real*8 :: dx, dp, dt, norm_sq, T
    complex*16, allocatable, dimension(:,:) :: Psi
    real*8, allocatable, dimension(:,:) :: psi_states, int_V_t
    real*8, allocatable, dimension(:) :: x_grid, p_grid, energies, V_0
    character*42 :: states_file

    write(*,*) "Enter the target state to evolve, the timesteps and the constant T"
    read(*,*) n_eigen, timesteps, T
    dt = T/timesteps

    n_eigen = n_eigen + 1! In our setting, the ground state is shifted to n = 1

    NN = 2**12 ! Just because...

    if (NN.le.n_eigen) stop "The grid size must be higher than the number of energy levels"

    ! The grid size determines the increment value
    dx = 2*L/NN
    dp = pi/L

    ! Since we assume x_0=x_n=0, we reduce the problem to a (NN-1)x(NN-1) matrix
    N_grid = NN - 1

    ! Compute the potential energy array
    allocate(x_grid(1:N_grid))
    allocate(p_grid(1:N_grid))
    x_grid = (/(ii*dx - L, ii = 1,N_grid)/)
    p_grid(1:int(N_grid/2)) = (/(ii*dp, ii = 1,int(N_grid/2))/)
    p_grid(int(N_grid/2)+1:N_grid) = (/(-int(N_grid/2)*dp+ii*dp, ii = 0,int(N_grid/2))/)

    ! Prepare t=0 potential
    allocate(V_0(1:N_grid))
    V_0 = x_grid**2/2
    ! Prepare time-evolving integrated potential
    allocate(int_V_t(1:N_grid,1:timesteps))
    do ii = 1, timesteps
        int_V_t(:,ii) = ((x_grid*T-(ii-1)*dt)**3-(x_grid*T-ii*dt)**3)/(6*T**2)
    end do

    ! Calling single particle routine for diagonal potentials and vanishing boundaries
    call finite_diff_1D(-L,L,NN,n_eigen,energies,psi_states,V_0,INFO)
    ! Validate there are no routine errors
    if (INFO.ne.0) then
        write(*,'(A,I4)') "Unsuccessful calculation. Status = ",INFO
    stop "Not storing results. Exiting program..."
    end if

    allocate(Psi(1:N_grid,0:timesteps))
    ! Use the eigenstate of interest
    norm_sq = sum(abs(psi_states(:,n_eigen))**2)*dx
    Psi(:,0) = psi_states(:,n_eigen)/sqrt(norm_sq)
    call split_op_1D(Psi,int_V_t,dt,N_grid,p_grid,timesteps,dx)
    ! evolve the state
    write(states_file,'(A,I0,A,I0,A,I0,A)') "data/state_",n_eigen-1,"_evo_T",int(T),"_",timesteps,".dat"
    open(12, file = states_file)
    do ii = 0, timesteps
        write(12,'(*(F0.8,SP,F0.8,"j",","))') Psi(:,ii)
    end do
    close(12)
end program time_dependent


!===================================================================
!   Randomly places parcels with variable volume in the domain
!===================================================================

program ranpar

 !Import parameters and constants:
use constants

implicit none

 !Total number of parcels:
integer:: n

 !Parcel positions (x,y,z) and volume fractions:
double precision:: x(nm),y(nm),z(nm),v(nm)

 !Other variables:
double precision:: vrange,fac
integer, dimension(:), allocatable :: seed
integer:: i,k,ngen

!---------------------------------------------------------------------
! Generate parcel positions and volumes:
write(*,*) ' Enter the average number of parcels per grid cell:'
read(*,*) fac
n=nint(fac*dble(ncell))

write(*,*) ' We assume any parcel volume is equally probable.'
write(*,*) ' Enter V_max/V_min:'
read(*,*) vrange

write(*,*) ' Enter an integer seed for the random number generator:'
read(*,*) ngen
call random_seed(size=k)
allocate(seed(1:k))
seed(:)=ngen
do i=1,ngen
  call random_seed(put=seed)
enddo

vrange=vrange-1.d0
do i=1,n
  call random_number(fac)
  x(i)=ellx*fac+xmin
  call random_number(fac)
  y(i)=elly*fac+ymin
  call random_number(fac)
  z(i)=ellz*fac+zmin
  call random_number(fac)
  v(i)=vrange*fac+1.d0
enddo

! Re-normalise so that sum(v) = ncell = nx*ny*nz:
fac=dble(ncell)/sum(v(1:n))
v(1:n)=fac*v(1:n)

!---------------------------------------------------------------------
! Write parcel positions and volume fractions (of grid cell volume):
open(80,file='ini_parcels.asc',status='replace')
write(80,*) n
do i=1,n
  write(80,*) x(i),y(i),z(i),v(i)
enddo
close(80)

write(*,*)
write(*,*) ' The initial parcels are in ini_parcels.asc'
write(*,*)

 !End main program
end program ranpar


module numerical_constants
  implicit none

        integer, parameter :: dp = selected_real_kind(14)
        real(kind=dp), parameter :: pi = real(4, kind=dp)*atan(real(1, kind=dp))

end module numerical_constants


real(kind=8) pure function qtrue(x, y, t)

    implicit none

    ! Input
    real(kind=8), intent(in) :: x, y, t

    ! Locals
    real(kind=8) :: x0, y0, r

    ! Common block
    real(kind=8) :: ubar, vbar
    common /cparam/ ubar,vbar

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

    ! evaluate desired initial data at (x0,y0):
    r = sqrt((x0 + 0.2d0)**2 + (y0 - 0.4d0)**2)
    if (r <= 0.3d0) then
        qtrue = 1.d0
    else
        qtrue = 0.d0
    endif

    r = sqrt((x0 - 0.3d0)**2 + (y0 - 0.1d0)**2)
    qtrue = qtrue - exp(-15.d0 * r**2)

end function qtrue


use FEMDomainClass

type(FEMDomain_) :: domain
type(ShapeFunction_) :: sf
real(real64) :: x=0.0d0,y=0.0d0,z=0.0d0,position(3)

call domain%create(meshtype="Cube3D",x_num=2,y_num=2,z_num=2)
call domain%resize(x=2.0d0,y=2.0d0,z=2.0d0)
call domain%msh("domain")
call domain%move(x=x,y=y,z=z)

! Get the nearest Element to (x,y,z) = (0,0,1)
print *, domain%mesh%nearestElementID(x=0.0d0,y=0.0d0,z=1.0d0)

! P(51,51,100) is in the 5th element?
print *, domain%mesh%InsideOfElement(ElementID=5,x=0.0d0,y=0.0d0,z=1.0d0)

! get local coordinates
print *, domain%getLocalCoordinate(ElementID=1,x=0.20d0+x,y=0.20d0+y,z=0.000d0+z)
print *, domain%getLocalCoordinate(ElementID=1,x=0.00d0+x,y=0.00d0+y,z=0.000d0+z)
print *, domain%getLocalCoordinate(ElementID=1,x=0.300d0+x,y=0.300d0+y,z=0.5000d0+z)

! set global coordinate
position(1) = 1.500d0
position(2) = 0.00d0
position(3) = 0.00d0

! get shape-function
sf = domain%getShapeFunction(position=position)

! show global coordinate
print *, "x",position(1)
print *, "y",position(2)
print *, "z",position(3)

! show element-id
print *, "ELEMENT ID: ",sf%ElementID
! show shape-function
print *, "Shape Function "
do i=1,size(sf%Nmat)
     print *, "N"//str(i), sf%Nmat(i)
enddo

end


module dual_numbers

    use constants, only : rk
    implicit none
    private

    type, public :: dual_t
        real(rk) :: re, du
    end type dual_t

    ! =========================================== dual number operator overloads

    public :: assignment (=)
    interface assignment (=)
        module procedure mov_real_dual, mov_dual_real
    end interface assignment (=)

    public :: operator (+)
    interface operator (+)
        module procedure pos_dual, add_real_dual, add_dual_real, add_dual_dual
    end interface operator (+)

    public :: operator (-)
    interface operator (-)
        module procedure neg_dual, sub_real_dual, sub_dual_real, sub_dual_dual
    end interface operator (-)

    public :: operator (*)
    interface operator (*)
        module procedure mul_real_dual, mul_dual_real, mul_dual_dual
    end interface operator (*)

    public :: operator (/)
    interface operator (/)
        module procedure div_real_dual, div_dual_real, div_dual_dual
    end interface operator (/)

    ! TODO: Add operator overload for exponentiation operator (**).
    ! TODO: Add elemental interface overloads for scalar intrinsic functions,
    !       e.g., sin, cos, tan, log, exp, bessel_j0, etc.
    ! TODO: Add interface overloads for intrinsic array functions,
    !       e.g., dot_product.

    public :: sum
    interface sum
        module procedure sum_dual
    end interface sum

    public :: dot_product
    interface dot_product
        module procedure dot_product_real_dual, dot_product_dual_real, &
                       & dot_product_dual_dual
    end interface dot_product

contains

    ! ========================================= dual number conversion operators

    elemental subroutine mov_real_dual(c, a)
        real(rk), intent(out) :: c
        type(dual_t), intent(in) :: a
        c = a%re
    end subroutine mov_real_dual

    elemental subroutine mov_dual_real(c, a)
        type(dual_t), intent(out) :: c
        real(rk), intent(in) :: a
        c%re = a
        c%du = 0.0_rk
    end subroutine mov_dual_real

    ! ============================================== dual number unary operators

    type(dual_t) elemental function pos_dual(a) result (c)
        type(dual_t), intent(in) :: a
        c%re = +a%re
        c%du = +a%du
    end function pos_dual

    type(dual_t) elemental function neg_dual(a) result (c)
        type(dual_t), intent(in) :: a
        c%re = -a%re
        c%du = -a%du
    end function neg_dual

    ! =========================================== dual number addition operators

    type(dual_t) elemental function add_real_dual(a, b) result (c)
        real(rk), intent(in) :: a
        type(dual_t), intent(in) :: b
        c%re = a + b%re
        c%du = b%du
    end function add_real_dual

    type(dual_t) elemental function add_dual_real(a, b) result (c)
        type(dual_t), intent(in) :: a
        real(rk), intent(in) :: b
        c%re = a%re + b
        c%du = a%du
    end function add_dual_real

    type(dual_t) elemental function add_dual_dual(a, b) result (c)
        type(dual_t), intent(in) :: a, b
        c%re = a%re + b%re
        c%du = a%du + b%du
    end function add_dual_dual

    ! ======================================== dual number subtraction operators

    type(dual_t) elemental function sub_real_dual(a, b) result (c)
        real(rk), intent(in) :: a
        type(dual_t), intent(in) :: b
        c%re = a - b%re
        c%du = -b%du
    end function sub_real_dual

    type(dual_t) elemental function sub_dual_real(a, b) result (c)
        type(dual_t), intent(in) :: a
        real(rk), intent(in) :: b
        c%re = a%re - b
        c%du = a%du
    end function sub_dual_real

    type(dual_t) elemental function sub_dual_dual(a, b) result (c)
        type(dual_t), intent(in) :: a, b
        c%re = a%re - b%re
        c%du = a%du - b%du
    end function sub_dual_dual

    ! ===================================== dual number multiplication operators

    type(dual_t) elemental function mul_real_dual(a, b) result (c)
        real(rk), intent(in) :: a
        type(dual_t), intent(in) :: b
        c%re = a * b%re
        c%du = a * b%du
    end function mul_real_dual

    type(dual_t) elemental function mul_dual_real(a, b) result (c)
        type(dual_t), intent(in) :: a
        real(rk), intent(in) :: b
        c%re = a%re * b
        c%du = a%du * b
    end function mul_dual_real

    type(dual_t) elemental function mul_dual_dual(a, b) result (c)
        type(dual_t), intent(in) :: a, b
        c%re = a%re * b%re
        c%du = a%re * b%du + a%du * b%re
    end function mul_dual_dual

    ! =========================================== dual number division operators

    type(dual_t) elemental function div_real_dual(a, b) result (c)
        real(rk), intent(in) :: a
        type(dual_t), intent(in) :: b
        c%re = a / b%re
        c%du = -c%re * b%du / b%re
    end function div_real_dual

    type(dual_t) elemental function div_dual_real(a, b) result (c)
        type(dual_t), intent(in) :: a
        real(rk), intent(in) :: b
        c%re = a%re / b
        c%du = a%du / b
    end function div_dual_real

    type(dual_t) elemental function div_dual_dual(a, b) result (c)
        type(dual_t), intent(in) :: a, b
        c%re = a%re / b%re
        c%du = (a%du - c%re * b%du) / b%re
    end function div_dual_dual

    ! ============================================= dual number array intrinsics

    type(dual_t) pure function sum_dual(a)
        type(dual_t), intent(in) :: a(:)
        integer :: i
        sum_dual = 0.0_rk
        do i = 1, size(a)
            sum_dual = sum_dual + a(i)
        end do
    end function sum_dual

    type(dual_t) pure function dot_product_real_dual(a, b)
        real(rk), intent(in) :: a(:)
        type(dual_t), intent(in) :: b(:)
        dot_product_real_dual = sum(a * b)
    end function dot_product_real_dual

    type(dual_t) pure function dot_product_dual_real(a, b)
        type(dual_t), intent(in) :: a(:)
        real(rk), intent(in) :: b(:)
        dot_product_dual_real = sum(a * b)
    end function dot_product_dual_real

    type(dual_t) pure function dot_product_dual_dual(a, b)
        type(dual_t), intent(in) :: a(:), b(:)
        dot_product_dual_dual = sum(a * b)
    end function dot_product_dual_dual

end module dual_numbers


! =============================================================================
!                       Test subroutine diffz
!
!  This unit test checks the subroutine diffz using the
!  function:
!               cos(k * x) * sin(l * y) * sin(m * z)
!  where k = 2pi/L_x, l = 2pi/L_y and m = pi/L_z and where x, y and z all start
!  at 0 (one could start at -pi for x and y just as well).
!  The subroutine diffz should return
!               m * cos(k * x) * sin(l * y) * cos(m * z)
! =============================================================================
program test_diffz
    use unit_test
    use constants, only : zero, one, two, pi, twopi
    use parameters, only : lower, update_parameters, dx, nx, ny, nz, extent
    use inversion_utils, only : init_fft
    use inversion_mod, only : diffz
    implicit none

    double precision              :: error
    double precision, allocatable :: fs(:, :, :), ds(:, :, :), &
                                     ref_sol(:, :, :)
    integer                       :: ix, iy, iz
    double precision              :: x, y, z, k, l, m, prefactor

    nx = 32
    ny = 64
    nz = 128
    lower  = (/zero, zero, zero/)
    extent =  (/pi, twopi, two * twopi/)

    allocate(fs(0:nz, nx, ny))
    allocate(ds(0:nz, nx, ny))
    allocate(ref_sol(0:nz, nx, ny))

    call update_parameters

    k = twopi / extent(1)
    l = twopi / extent(2)
    m =    pi / extent(3)

    prefactor = - one / (k ** 2 + l ** 2 + m ** 2)

    do ix = 1, nx
        x = lower(1) + (ix - 1) * dx(1)
        do iy = 1, ny
            y = lower(2) + (iy - 1) * dx(2)
            do iz = 0, nz
                z = lower(3) + iz * dx(3)

                fs(iz, ix, iy) = dcos(k * x) * dsin(l * y) * dsin(m * z)
                ref_sol(iz, ix, iy) = m * dcos(k * x) * dsin(l * y) * dcos(m * z)

            enddo
        enddo
    enddo

    call init_fft

    call diffz(fs, ds)

    error = maxval(dabs(ds - ref_sol))

    call print_result_dp('Test inversion (diffz)', error, atol=2.6e-5)

    deallocate(fs)
    deallocate(ds)
    deallocate(ref_sol)

end program test_diffz


program fourier_sum

    implicit none
    integer :: n, i, nterms, k
    real(kind=8) :: pi, ck, term, dx
    real(kind=8), dimension(:), allocatable :: x, fsum
    open(unit=21, file='input_data.txt', status='old')

    read(21,*) n
    read(21,*) nterms

    print '("n = ",i6)', n
    print '("nterms = ",i6)', nterms

    allocate(x(0:n+1), fsum(0:n+1))
    pi = acos(-1.d0)

    open(unit=22, file='xf.txt', status='unknown')
    open(unit=23, file='frames.txt', status='unknown')

    dx = pi / (n + 1.d0)

    do i=0,n+1
        x(i) = i*dx
        write(22,221) x(i), exp(x(i))
221     format(2e20.10)
        fsum(i) = 0.d0
        enddo

    do k=1,nterms
        ck = 2*k*(1. - (-1.)**k * exp(pi)) / ((k**2 + 1)*pi)
        do i=0,n+1
            term = ck * sin(k*x(i))
            fsum(i) = fsum(i) + term
            write(23,221) term, fsum(i)
            enddo
        enddo

end program fourier_sum


program test
!  Test the CIJ_brow_chev subroutine

use anisotropy_ajn

implicit none

real(8),dimension(6,6) :: C,CI,CX,CT,CO,CM,CR
real(8) :: pI,pX,pT,pO,pM,pR
real(8) :: rho
real(8) :: R(3,3)
character(len=250) :: fname,fmt1,fmt2,symmetry

if (command_argument_count() /= 1) then
   write(0,'(a)') 'Usage: test_CIJ_brow_chev [.ecs file]'
   stop
endif

call get_command_argument(1,fname)

!  Load constants
call CIJ_load(fname,C,rho)

!  Convert into GPa
C = C / 1.d9

!  Express constants according to B&C 2004
call CIJ_brow_chev(C,CI,CX,CT,CO,CM,CR,pI,pX,pT,pO,pM,pR)

!  Output format
fmt1 = '(a,f6.2," %")'
fmt2 = '(6e12.3)'
fmt2 = '(6f7.1)'

write(*,'(a)') 'Input tensor:'
write(*,fmt2) C
write(*,*)

write(*,fmt1) 'Isotropic part:    ' ,pI*100._8
write(*,fmt2) CI
write(*,*)

write(*,fmt1) 'Hexagonal part:    ' ,pX*100._8
write(*,fmt2) CX
write(*,*)

write(*,fmt1) 'Tetragonal part:   ' ,pT*100._8
write(*,fmt2) CT
write(*,*)

write(*,fmt1) 'Orthorhombic part: ' ,pO*100._8
write(*,fmt2) CO
write(*,*)

write(*,fmt1) 'Monoclinic part:   ' ,pM*100._8
write(*,fmt2) CM
write(*,*)

write(*,fmt1) 'Triclinic part:    ' ,pR*100._8
write(*,fmt2) CR
write(*,*)

write(*,fmt1) 'Sum of all parts:  ' ,(pI + pX + pT + pO + pM + pR)*100._8
write(*,fmt2) CI + CX + CT + CO + CM + CR
write(*,*)

! Determine symmetry type and rotate to optimum orientation
call CIJ_brow_chev_symm(C, CR=CR, R=R, symm=symmetry)

write(*,'(a)') 'Symmetry type: ' // trim(symmetry)
write(*,'(a)') 'Tensor in optimum orientation:'
write(*,fmt2) CR
write(*,*)

write(*,'(a)') 'Rotation matrix (vectors in columns):'
write(*,'(3f8.4)') R
write(*,*)

call CIJ_save('/tmp/test_CIJ_brow_chev.ecs', CR*1.e9, rho)

end program test


 subroutine chobk2(kb,loads)
!Choleski back-substitution
 implicit none
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),intent(in)::kb(:,:)
 REAL(iwp),intent(in out)::loads(0:)
 integer::iw,n,i,j,l,m
 REAL(iwp)::x
 n=size(kb,1)
 iw=size(kb,2)-1
 loads(n)=loads(n)/kb(n,iw+1)
 do i=n-1,1,-1
   x=0.0
   l=i+iw
   if(i>n-iw)l=n
   m=i+1
   do j=m,l
     x=x+kb(j,iw+i-j+1)*loads(j)
   end do
   loads(i)=(loads(i)-x)/kb(i,iw+1)
 end do
 return
 end subroutine chobk2


!-----------------------------------------------------------------------------
!
! Halo multiplicity function in double precision, mf(lnnu),
! where lnnu=ln(nu) and nu is called the "threshold,"
! given by nu = [delta_c/sigma(R,z)]^2. Here, delta_c=1.6865, sigma(R,z)
! is the r.m.s. mass fluctuation within a top-hat smoothing of scale R
! at a redshift z.
!
! Ref. Press & Schechter, 187, 425 (1974)
! See also Bond, Cole, Efstathiou & Kaiser, ApJ, 379, 440 (1991)
! See Sheth & Tormen, MNRAS, 329, 61 (2002) for the notation used here
! Note that "mf(lnnu)" here corresponds to nu*f(nu) in Sheth&Tormen(2002)
!
! The halo multiplicity function has been normalized such that
!
! int_{-infinity}^{+infinity} dln(nu) mf(lnnu) = 1
!
! This normalization is equivalent to saying that all the mass in
! the universe is contained in halos. In terms of the comoving number
! density of halos per mass, dn/dM, one can write this normalization as
!
! int_0^{+infinity} dM M dn/dM = (average mass density of the universe today)
!
! The halo mass function can be computed in the following way.
!
! (1) First, the comoving number density of halos per ln(nu) is related
! to the mass function, dn/dM, as
!
! dM M dn/dM = rho_m dln(nu) mf(lnnu)
!
! where rho_m = (average mass density of the universe today)
!
! Dividing both sides by dM, one finds
!
! dn/dlnM = rho_m dln(nu)/dlnM mf(lnnu)/M
!
! (2) nu is more directly related to R, as nu=[delta_c/sigma(R,z)]^2.
! So, it is more convenient to write dn/dM as
!
! dn/dlnM = dlnR/dlnM dn/dlnR
!
! and compute dn/dlnR first, via
!
! dn/dlnR = rho_m dln(nu)/dlnR mf(lnnu)/M(R)
!
! Now, we can use M(R)=(4pi/3)rho_m R^3 to obtain
!
! dn/dlnR = (3/4pi) dln(nu)/dlnR mf(lnnu)/R^3
!
! with ln(nu) and dln(nu)/dlnR related to lnR via
! - ln(nu) = 2*ln(1.6865)-ln[sigma^2(R,z)]
! - dln(nu)/dlnR = -dln[sigma^2(R)]/dlnR (which is indep. of z)
!
! (3) Once dn/dlnR is obtained as a function of R, one can
! compute dn/dlnM using dlnR/dlnM=1/3, and obtain
!
! dn/dlnM = (1/3) dn/dlnR
!
! with M(R)=(4pi/3)rho_m R^3,
! and rho_m=2.775d11 (omega_matter h^2) M_solar Mpc^-3.
!
!
! << sample code >>
!
! USE linearpk
! USE sigma
! double precision :: deltac=1.6865d0,mf,dndlnRh,dndlnMh
! double precision :: lnnu,dlnnudlnRh,Mh
! REAL :: chebev
! REAL :: lnsigma2,lnRh,Rh,dlnsigma2dlnRh
! character(len=128) :: filename
! integer :: n
! filename='wmap5baosn_max_likelihood_matterpower.dat'
! n=896 ! # of lines in the file
! CALL get_linearpk(filename,n)
! CALL compute_sigma2
! Rh=8. ! h^-1 Mpc
! lnRh = alog(Rh)
! if(lnRh>lnR2.or.lnRh<lnR1)then
!    print*,'lnR=',lnRh,' is out of range. It must be between',lnR1,' and',lnR2
!    stop
! else
!    lnsigma2 = CHEBEV(lnR1,lnR2,c,ndim,lnRh)          ! ln(sigma^2)
!    dlnsigma2dlnRh = CHEBEV(lnR1,lnR2,cder,ndim,lnRh) ! dln(sigma^2)/dlnRh
!    lnnu = 2d0*dlog(deltac)-dble(lnsigma2) ! ln(nu)
!    dlnnudlnRh = -dble(dlnsigma2dlnRh)     ! dln(nu)/dlnRh
!    dndlnRh = (3d0/4d0/3.1415926535d0)*dlnnudlnRh*mf(lnnu)/dble(Rh)**3d0 ! in units of h^3 Mpc^-3
!    print*,'dn/dlnR at R=',Rh,' h^-1 Mpc is',dndlnRh,' h^3 Mpc^-3'
!    dndlnMh = dndlnRh/3d0 ! in units of h^3 Mpc^-3
!    Mh = (4d0*3.1415926535d0/3d0)*2.775d11*Rh**3d0 ! in units of omega_matter h^-1 M_solar
!    print*,'dn/dlnM at M=',Mh,' omega_matter h^-1 M_solar is (',dndlnMh,') h^3 Mpc^-3'
! endif
! end
!
! August 25, 2008
! E. Komatsu
!
!-----------------------------------------------------------------------------
MODULE mf_pressschechter

contains
DOUBLE PRECISION FUNCTION mf(lnnu)
!!$ Halo multiplicity function per log(nu): nu*f(nu)
!!$ \int_{-infty}^infty mf(lnnu) dlnnu = 1
  IMPLICIT none
  DOUBLE PRECISION, intent(IN) :: lnnu
  DOUBLE PRECISION :: nu
  nu= exp(lnnu)
  mf = 1d0/sqrt(2d0*3.14159d0)*(nu)**0.5d0*exp(-nu/2d0)
  return
END FUNCTION mf
END MODULE mf_pressschechter


MODULE DOT
! Module for dot product of two real arrays of rank 1.
! The caller needs to ensure that exceptions do not cause halting.
! Source https://j3-fortran.org/doc/year/18/18-007r1.pdf
    USE, INTRINSIC :: IEEE_EXCEPTIONS
    LOGICAL :: MATRIX_ERROR = .FALSE.

    INTERFACE OPERATOR(.dot.)
        MODULE PROCEDURE MULT
    END INTERFACE

CONTAINS

    REAL FUNCTION MULT (A, B)
        REAL, INTENT (IN) :: A(:), B(:)
        INTEGER I
        LOGICAL OVERFLOW

        IF (SIZE(A) /= SIZE(B)) THEN
            MATRIX_ERROR = .TRUE.
            RETURN
        END IF
        ! The processor ensures that IEEE_OVERFLOW is quiet.

        MULT = 0.0
        DO I = 1, SIZE (A)
            MULT = MULT + A(I)*B(I)
        END DO
        CALL IEEE_GET_FLAG (IEEE_OVERFLOW, OVERFLOW)
        IF (OVERFLOW) MATRIX_ERROR = .TRUE.
    END FUNCTION MULT
END MODULE DOT


subroutine evolve_temperature(j,t)
!****************************************************************
! Evolve temperature of embryo j at time t
! Currently assumes a polytropic collapse (cf protostar formation)
!****************************************************************

use eosdata, only: Boltzmannk, mH
use embryodata
implicit none

integer,intent(in) :: j
real,intent(in) :: t

embryo(j)%T = embryo(j)%T0*(1.0+(1.0+p_kap)*t/embryo(j)%t_cool0)**(1.0/(1.0+p_kap))
embryo(j)%cs = sqrt(gamma*Boltzmannk*embryo(j)%T/(mu*mH))

end subroutine evolve_temperature


!*****************************************************************!
!                            Melissa                              !
!-----------------------------------------------------------------!
!   COPYRIGHT (C) 2017  by INRIA and EDF. ALL RIGHTS RESERVED.    !
!                                                                 !
! This source is covered by the BSD 3-Clause License.             !
! Refer to the  LICENCE file for further information.             !
!                                                                 !
!-----------------------------------------------------------------!
!  Original Contributors:                                         !
!    Theophile Terraz,                                            !
!    Bruno Raffin,                                                !
!    Alejandro Ribes,                                             !
!    Bertrand Iooss,                                              !
!*****************************************************************!

program heat_no_mpi

  use heat_utils_no_mpi

  implicit none

  include "melissa_api.f90"

  integer :: nx, ny, n, nmax, vect_size, narg
  real*8 :: lx, ly, dt, dx, dy, d, t, epsilon, t1, t2
  real*8,dimension(:),pointer :: U => null(), F => null()
  real*8,dimension(3) :: A
  real*8,dimension(5) :: param
  character(len=32) :: arg
  character(len=5) :: name = C_CHAR_"heat"//C_NULL_CHAR

  ! The program now takes at least 2 parameter:
  ! - The coupling method for Sobol' groups
  ! - the initial temperature

  narg = iargc()
  if (narg .lt. 2) then
    print*,"Missing parameter"
    stop
  endif

  param(:) = 0

  ! The initial temperature is stored in param(1)
  ! The four next optional parameters are the boundary temperatures
  do n=1, 5
    if(narg .ge. n) then
      call getarg(n, arg)
      read( arg, * ) param(n)
    endif
  enddo

  ! Init timer
  call cpu_time(t1)

  nx        = 100 ! x axis grid subdivisions
  ny        = 100 ! y axis grid subdivisions
  lx        = 10.0 ! x length
  ly        = 10.0 ! y length
  d         = 1.0 ! diffusion coefficient
  dt        = 0.01 ! timestep value
  nmax      = 100 ! number of timesteps
  dx        = lx/(nx+1) ! x axis step
  dy        = ly/(ny+1) ! y axis step
  epsilon   = 0.0001 ! conjugated gradient precision
  vect_size = nx*ny ! number of cells in the drid

  ! initialization
  allocate(U(vect_size))
  allocate(F(vect_size))
  ! we will solve Au=F
  call init(U, vect_size, param(1))
  ! init A (tridiagonal matrix):
  call filling_A(d, dx, dy, dt, A) ! fill A

  ! melissa_init_no_mpi is the first Melissa function to call, and it is called only once.
  ! It mainly contacts the server.
  call melissa_init_no_mpi(name, vect_size)

  ! main loop:
  do n=1, nmax
    t = t + dt
    ! filling F (RHS) before each iteration:
    call filling_F(nx, ny, U, d, dx, dy, dt, t, F, vect_size, lx, ly, param)
    ! conjugated gradient to solve Au = F.
    call conjgrad(A, F, U, nx, ny, epsilon)
    ! The result is u
    ! melissa_send_no_mpi is called at each iteration to send u to the server.
    call melissa_send_no_mpi(name, u)
  end do

  ! melissa_finalize closes the connexion with the server.
  ! No Melissa function should be called after melissa_finalize.
  call melissa_finalize()

  ! end timer
  call cpu_time(t2)
  print*,'Calcul time:', t2-t1, 'sec'
  print*,'Final time step:', t

  deallocate(U, F)

end program heat_no_mpi


*DECK DRC
      DOUBLE PRECISION FUNCTION DRC (X, Y, IER)
C***BEGIN PROLOGUE  DRC
C***PURPOSE  Calculate a double precision approximation to
C             DRC(X,Y) = Integral from zero to infinity of
C                              -1/2     -1
C                    (1/2)(t+X)    (t+Y)  dt,
C            where X is nonnegative and Y is positive.
C***LIBRARY   SLATEC
C***CATEGORY  C14
C***TYPE      DOUBLE PRECISION (RC-S, DRC-D)
C***KEYWORDS  DUPLICATION THEOREM, ELEMENTARY FUNCTIONS,
C             ELLIPTIC INTEGRAL, TAYLOR SERIES
C***AUTHOR  Carlson, B. C.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Notis, E. M.
C             Ames Laboratory-DOE
C             Iowa State University
C             Ames, IA  50011
C           Pexton, R. L.
C             Lawrence Livermore National Laboratory
C             Livermore, CA  94550
C***DESCRIPTION
C
C   1.     DRC
C          Standard FORTRAN function routine
C          Double precision version
C          The routine calculates an approximation result to
C          DRC(X,Y) = integral from zero to infinity of
C
C                              -1/2     -1
C                    (1/2)(t+X)    (t+Y)  dt,
C
C          where X is nonnegative and Y is positive.  The duplication
C          theorem is iterated until the variables are nearly equal,
C          and the function is then expanded in Taylor series to fifth
C          order.  Logarithmic, inverse circular, and inverse hyper-
C          bolic functions can be expressed in terms of DRC.
C
C   2.     Calling Sequence
C          DRC( X, Y, IER )
C
C          Parameters On Entry
C          Values assigned by the calling routine
C
C          X      - Double precision, nonnegative variable
C
C          Y      - Double precision, positive variable
C
C
C
C          On Return  (values assigned by the DRC routine)
C
C          DRC    - Double precision approximation to the integral
C
C          IER    - Integer to indicate normal or abnormal termination.
C
C                     IER = 0 Normal and reliable termination of the
C                             routine.  It is assumed that the requested
C                             accuracy has been achieved.
C
C                     IER > 0 Abnormal termination of the routine
C
C          X and Y are unaltered.
C
C   3.    Error messages
C
C         Value of IER assigned by the DRC routine
C
C                  Value assigned         Error message printed
C                  IER = 1                X.LT.0.0D0.OR.Y.LE.0.0D0
C                      = 2                X+Y.LT.LOLIM
C                      = 3                MAX(X,Y) .GT. UPLIM
C
C   4.     Control parameters
C
C                  Values of LOLIM, UPLIM, and ERRTOL are set by the
C                  routine.
C
C          LOLIM and UPLIM determine the valid range of X and Y
C
C          LOLIM  - Lower limit of valid arguments
C
C                   Not less  than 5 * (machine minimum)  .
C
C          UPLIM  - Upper limit of valid arguments
C
C                   Not greater than (machine maximum) / 5 .
C
C
C                     Acceptable values for:   LOLIM       UPLIM
C                     IBM 360/370 SERIES   :   3.0D-78     1.0D+75
C                     CDC 6000/7000 SERIES :   1.0D-292    1.0D+321
C                     UNIVAC 1100 SERIES   :   1.0D-307    1.0D+307
C                     CRAY                 :   2.3D-2466   1.0D+2465
C                     VAX 11 SERIES        :   1.5D-38     3.0D+37
C
C          ERRTOL determines the accuracy of the answer
C
C                 The value assigned by the routine will result
C                 in solution precision within 1-2 decimals of
C                 "machine precision".
C
C
C          ERRTOL  - relative error due to truncation is less than
C                    16 * ERRTOL ** 6 / (1 - 2 * ERRTOL).
C
C
C              The accuracy of the computed approximation to the inte-
C              gral can be controlled by choosing the value of ERRTOL.
C              Truncation of a Taylor series after terms of fifth order
C              introduces an error less than the amount shown in the
C              second column of the following table for each value of
C              ERRTOL in the first column.  In addition to the trunca-
C              tion error there will be round-off error, but in prac-
C              tice the total error from both sources is usually less
C              than the amount given in the table.
C
C
C
C          Sample choices:  ERRTOL   Relative truncation
C                                    error less than
C                           1.0D-3    2.0D-17
C                           3.0D-3    2.0D-14
C                           1.0D-2    2.0D-11
C                           3.0D-2    2.0D-8
C                           1.0D-1    2.0D-5
C
C
C                    Decreasing ERRTOL by a factor of 10 yields six more
C                    decimal digits of accuracy at the expense of one or
C                    two more iterations of the duplication theorem.
C
C *Long Description:
C
C   DRC special comments
C
C
C
C
C                  Check: DRC(X,X+Z) + DRC(Y,Y+Z) = DRC(0,Z)
C
C                  where X, Y, and Z are positive and X * Y = Z * Z
C
C
C          On Input:
C
C          X, and Y are the variables in the integral DRC(X,Y).
C
C          On Output:
C
C          X and Y are unaltered.
C
C
C
C                    DRC(0,1/4)=DRC(1/16,1/8)=PI=3.14159...
C
C                    DRC(9/4,2)=LN(2)
C
C
C
C          ********************************************************
C
C          WARNING: Changes in the program may improve speed at the
C                   expense of robustness.
C
C
C   --------------------------------------------------------------------
C
C   Special functions via DRC
C
C
C
C                  LN X                X .GT. 0
C
C                                             2
C                  LN(X) = (X-1) DRC(((1+X)/2)  , X )
C
C
C   --------------------------------------------------------------------
C
C                  ARCSIN X            -1 .LE. X .LE. 1
C
C                                       2
C                  ARCSIN X = X DRC (1-X  ,1 )
C
C   --------------------------------------------------------------------
C
C                  ARCCOS X            0 .LE. X .LE. 1
C
C
C                                     2       2
C                  ARCCOS X = SQRT(1-X ) DRC(X  ,1 )
C
C   --------------------------------------------------------------------
C
C                  ARCTAN X            -INF .LT. X .LT. +INF
C
C                                        2
C                  ARCTAN X = X DRC(1,1+X  )
C
C   --------------------------------------------------------------------
C
C                  ARCCOT X            0 .LE. X .LT. INF
C
C                                  2   2
C                  ARCCOT X = DRC(X  ,X +1 )
C
C   --------------------------------------------------------------------
C
C                  ARCSINH X           -INF .LT. X .LT. +INF
C
C                                       2
C                  ARCSINH X = X DRC(1+X  ,1 )
C
C   --------------------------------------------------------------------
C
C                  ARCCOSH X           X .GE. 1
C
C                                    2         2
C                  ARCCOSH X = SQRT(X -1) DRC(X  ,1 )
C
C   --------------------------------------------------------------------
C
C                  ARCTANH X           -1 .LT. X .LT. 1
C
C                                         2
C                  ARCTANH X = X DRC(1,1-X  )
C
C   --------------------------------------------------------------------
C
C                  ARCCOTH X           X .GT. 1
C
C                                   2   2
C                  ARCCOTH X = DRC(X  ,X -1 )
C
C   --------------------------------------------------------------------
C
C***REFERENCES  B. C. Carlson and E. M. Notis, Algorithms for incomplete
C                 elliptic integrals, ACM Transactions on Mathematical
C                 Software 7, 3 (September 1981), pp. 398-403.
C               B. C. Carlson, Computing elliptic integrals by
C                 duplication, Numerische Mathematik 33, (1979),
C                 pp. 1-16.
C               B. C. Carlson, Elliptic integrals of the first kind,
C                 SIAM Journal of Mathematical Analysis 8, (1977),
C                 pp. 231-242.
C***ROUTINES CALLED  D1MACH, XERMSG
C***REVISION HISTORY  (YYMMDD)
C   790801  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891009  Removed unreferenced statement labels.  (WRB)
C   891009  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900315  CALLs to XERROR changed to CALLs to XERMSG.  (THJ)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   900510  Changed calls to XERMSG to standard form, and some
C           editorial changes.  (RWC))
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  DRC
      CHARACTER*16 XERN3, XERN4, XERN5
      INTEGER IER
      DOUBLE PRECISION C1, C2, ERRTOL, LAMDA, LOLIM, D1MACH
      DOUBLE PRECISION MU, S, SN, UPLIM, X, XN, Y, YN
      LOGICAL FIRST
      SAVE ERRTOL,LOLIM,UPLIM,C1,C2,FIRST
      DATA FIRST /.TRUE./
C
C***FIRST EXECUTABLE STATEMENT  DRC
      IF (FIRST) THEN
         ERRTOL = (D1MACH(3)/16.0D0)**(1.0D0/6.0D0)
         LOLIM  = 5.0D0 * D1MACH(1)
         UPLIM  = D1MACH(2) / 5.0D0
C
         C1 = 1.0D0/7.0D0
         C2 = 9.0D0/22.0D0
      ENDIF
      FIRST = .FALSE.
C
C         CALL ERROR HANDLER IF NECESSARY.
C
      DRC = 0.0D0
      IF (X.LT.0.0D0.OR.Y.LE.0.0D0) THEN
         IER = 1
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         CALL XERMSG ('SLATEC', 'DRC',
     *      'X.LT.0 .OR. Y.LE.0 WHERE X = ' // XERN3 // ' AND Y = ' //
     *      XERN4, 1, 1)
         RETURN
      ENDIF
C
      IF (MAX(X,Y).GT.UPLIM) THEN
         IER = 3
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') UPLIM
         CALL XERMSG ('SLATEC', 'DRC',
     *      'MAX(X,Y).GT.UPLIM WHERE X = '  // XERN3 // ' Y = ' //
     *      XERN4 // ' AND UPLIM = ' // XERN5, 3, 1)
         RETURN
      ENDIF
C
      IF (X+Y.LT.LOLIM) THEN
         IER = 2
         WRITE (XERN3, '(1PE15.6)') X
         WRITE (XERN4, '(1PE15.6)') Y
         WRITE (XERN5, '(1PE15.6)') LOLIM
         CALL XERMSG ('SLATEC', 'DRC',
     *      'X+Y.LT.LOLIM WHERE X = ' // XERN3 // ' Y = ' // XERN4 //
     *      ' AND LOLIM = ' // XERN5, 2, 1)
         RETURN
      ENDIF
C
      IER = 0
      XN = X
      YN = Y
C
   30 MU = (XN+YN+YN)/3.0D0
      SN = (YN+MU)/MU - 2.0D0
      IF (ABS(SN).LT.ERRTOL) GO TO 40
      LAMDA = 2.0D0*SQRT(XN)*SQRT(YN) + YN
      XN = (XN+LAMDA)*0.250D0
      YN = (YN+LAMDA)*0.250D0
      GO TO 30
C
   40 S = SN*SN*(0.30D0+SN*(C1+SN*(0.3750D0+SN*C2)))
      DRC = (1.0D0+S)/SQRT(MU)
      RETURN
      END


Program Leonhard
  implicit none
  REAL::a, b, h, x, f, y
  INTEGER::i, N
  N=1000
  a=0
  b=10
  h=(b-a)/N
  y=1
  do i=1, N
     x=a+i*h
     write(90, *) x, y
     y=y+h*f(x, y)
  end do

end Program Leonhard

function f(x, y)
  implicit none
  REAL::x, y, f
  f=-y-3*exp(-x)*sin(3*x)
end function f


! =============================================================================
subroutine rp1_ptwise(num_eqn, num_aux, num_waves, q_l, q_r, aux_l, aux_r,    &
wave, s, amdq, apdq)
! =============================================================================
!
! Riemann problems for the 1D Burgers' equation with entropy fix for
! transonic rarefaction. See "Finite Volume Method for Hyperbolic Problems",
! R. J. LeVeque.

! waves: 1
! equations: 1

! Conserved quantities:
!       1 q

    implicit none

    ! Input Arguments
    integer, intent(in) :: num_eqn, num_aux, num_waves
    real(kind=8), intent(in out) :: q_l(num_eqn), q_r(num_eqn)
    real(kind=8), intent(in out) :: aux_l(num_aux), aux_r(num_aux)

    ! Output arguments
    real(kind=8), intent(in out) :: wave(num_eqn, num_waves)
    real(kind=8), intent(in out) :: s(num_waves)
    real(kind=8), intent(in out) :: apdq(num_eqn), amdq(num_eqn)

    ! Local
    logical :: efix

    efix = .true.   !# Compute correct flux for transonic rarefactions

    wave(1,1) = q_r(1) - q_l(1)
    s(1) = 0.5d0 * (q_l(1) + q_r(1))

    amdq(1) = dmin1(s(1), 0.d0) * wave(1,1)
    apdq(1) = dmax1(s(1), 0.d0) * wave(1,1)

    if (efix) then
        if (q_r(1).gt.0.d0 .and. q_l(1).lt.0.d0) then
            amdq(1) = - 1.d0/2.d0 * q_l(1)**2
            apdq(1) =   1.d0/2.d0 * q_r(1)**2
        endif
    endif

    end subroutine rp1_ptwise


      FUNCTION torflux_deriv (x)
      USE stel_kinds
      USE vmec_input, ONLY: lRFP
      USE vmec_input, ONLY: tf => aphi
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      REAL(rprec) :: x, torflux_deriv
      REAL(rprec), EXTERNAL :: polflux_deriv, piota
      INTEGER     :: i
C-----------------------------------------------
      IF (lRFP) THEN
!        RFP/TOKAMAK
         torflux_deriv = polflux_deriv(x)/piota(x)

      ELSE
!        TOKAMAK/STELLARATOR (default is tf(1) = 1)
         torflux_deriv = 0
         DO i = UBOUND(tf,1), LBOUND(tf,1), -1
            torflux_deriv = x*torflux_deriv + i*tf(i)
         END DO
!        torflux_deriv = 1
      END IF

      END FUNCTION torflux_deriv

      FUNCTION polflux_deriv (x)
      USE stel_kinds
      USE vmec_input, ONLY: lRFP
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      REAL(rprec) :: x, polflux_deriv
      REAL(rprec), EXTERNAL :: torflux_deriv, piota
C-----------------------------------------------
      IF (lRFP) THEN
!        RFP/TOKAMAK
         polflux_deriv = 1

      ELSE
!        TOKAMAK/STELLARATOR: dchi/ds = iota * dphi/ds
         polflux_deriv = piota(x)*torflux_deriv(x)
      END IF

      END FUNCTION polflux_deriv

      FUNCTION torflux (x)
      USE stel_kinds
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      REAL(rprec) :: x, torflux
      REAL(rprec) :: h, xi
      REAL(rprec), EXTERNAL :: torflux_deriv
      INTEGER     :: i
C-----------------------------------------------
      h = 1.E-2_dp*x
      torflux = 0
      DO i=1,101
         xi = (i-1)*h
         torflux = torflux + torflux_deriv(xi)
      END DO
      torflux = torflux-0.5_dp*(torflux_deriv(0._dp)+torflux_deriv(x))
      torflux = h*torflux

      END FUNCTION torflux

      FUNCTION polflux (x)
      USE stel_kinds
!     USE vmec_input, ONLY: af => achi
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      REAL(rprec) :: x, polflux
      REAL(rprec) :: h, xi
      REAL(rprec), EXTERNAL :: polflux_deriv
      INTEGER     :: i
C-----------------------------------------------
      h = 1.E-2_dp*x
      polflux = 0
      DO i=1,101
         xi = (i-1)*h
         polflux = polflux + polflux_deriv(xi)
      END DO
      polflux = polflux-0.5_dp*(polflux_deriv(0._dp)+polflux_deriv(x))
      polflux = h*polflux

      END FUNCTION polflux

!  function piota moved to a separate file, piota.f. J Hanson, 2010-03-16


PURE FUNCTION func_stderr(arr, dof) RESULT(ans)
    ! NOTE: See https://docs.scipy.org/doc/scipy/reference/generated/scipy.stats.sem.html

    USE ISO_FORTRAN_ENV

    IMPLICIT NONE

    ! Declare inputs/outputs ...
    INTEGER(kind = INT64), INTENT(in), OPTIONAL                                 :: dof
    REAL(kind = REAL64)                                                         :: ans
    REAL(kind = REAL64), DIMENSION(:), INTENT(in)                               :: arr

    ! Declare internal variables ...
    INTEGER(kind = INT64)                                                       :: n

    ! Find size of array ...
    n = SIZE(arr, kind = INT64)

    ! Calculate the standard error ...
    IF(PRESENT(dof))THEN
        ans = func_stddev(arr, dof) / SQRT(REAL(n, kind = REAL64))
    ELSE
        ans = func_stddev(arr, 1_INT64) / SQRT(REAL(n, kind = REAL64))
    END IF
END FUNCTION func_stderr


! This sample solution has both method 1 and 2, and also two additional
! methods 3, 4 that are analogous but that only call the random number
! generator once to get all the random numbers needed, rather than having the
! call inside a loop.

module approx_norm

    implicit none
    integer :: nsamples, seed, method
    save

contains

    subroutine approx_norm1(a, anorm)

    use omp_lib
    implicit none
    real(kind=8), dimension(:,:), intent(in) :: a
    real(kind=8), intent(out) :: anorm

    real(kind=8), allocatable, dimension(:) :: x,ax,allx
    integer :: i,j,k,n,k1,k2
    real(kind=8) :: xnorm, axnorm, ratio, max_ratio

    n = size(a,1)
    allocate(x(n),ax(n))

    if (method == 1) then

        max_ratio = 0.d0

        !$omp parallel do private(i,j,x,ax,xnorm,axnorm,ratio) &
        !$omp reduction(max:max_ratio)
        do k=1,nsamples

            ! choose a random vector x:
            call random_number(x)

            ! compute matrix-vector product ax:
            do i=1,n
                ax(i) = 0.d0
                do j=1,n
                    ax(i) = ax(i) + a(i,j)*x(j)
                    enddo
                enddo

            ! compute 1-norm of x and ax
            xnorm = 0.d0
            axnorm = 0.d0
            do i=1,n
                xnorm = xnorm + abs(x(i))
                axnorm = axnorm + abs(ax(i))
                enddo

            ratio = axnorm/xnorm
            max_ratio = max(max_ratio, ratio)
            enddo

        anorm = max_ratio

    else if (method == 2) then

        max_ratio = 0.d0
        do k=1,nsamples

            ! choose a random vector x:
            call random_number(x)

            ! compute matrix-vector product ax:
            !$omp parallel do private(j)
            do i=1,n
                ax(i) = 0.d0
                do j=1,n
                    ax(i) = ax(i) + a(i,j)*x(j)
                    enddo
                enddo

            ! compute 1-norm of x and ax
            xnorm = 0.d0
            axnorm = 0.d0
            !$omp parallel do reduction(+:xnorm,axnorm)
            do i=1,n
                xnorm = xnorm + abs(x(i))
                axnorm = axnorm + abs(ax(i))
                enddo

            ratio = axnorm/xnorm
            max_ratio = max(max_ratio, ratio)
            enddo

        anorm = max_ratio

    else if (method == 3) then

        ! generate all the random numbers we'll ever need:
        allocate(allx(n*nsamples))
        call random_number(allx)

        max_ratio = 0.d0

        !$omp parallel do private(i,j,x,ax,xnorm,axnorm,ratio) &
        !$omp reduction(max:max_ratio)
        do k=1,nsamples

            ! choose a random vector x by taking n elements from allx :
            k1 = (k-1)*n+1
            k2 = k*n
            x = allx(k1:k2)

            ! compute matrix-vector product ax:
            do i=1,n
                ax(i) = 0.d0
                do j=1,n
                    ax(i) = ax(i) + a(i,j)*x(j)
                    enddo
                enddo

            ! compute 1-norm of x and ax
            xnorm = 0.d0
            axnorm = 0.d0
            do i=1,n
                xnorm = xnorm + abs(x(i))
                axnorm = axnorm + abs(ax(i))
                enddo

            ratio = axnorm/xnorm
            max_ratio = max(max_ratio, ratio)
            enddo

        anorm = max_ratio

    else if (method == 4) then

        ! generate all the random numbers we'll ever need:
        allocate(allx(n*nsamples))
        call random_number(allx)

        max_ratio = 0.d0
        do k=1,nsamples

            ! choose a random vector x by taking n elements from allx :
            k1 = (k-1)*n+1
            k2 = k*n
            x = allx(k1:k2)

            ! compute matrix-vector product ax:
            !$omp parallel do private(j)
            do i=1,n
                ax(i) = 0.d0
                do j=1,n
                    ax(i) = ax(i) + a(i,j)*x(j)
                    enddo
                enddo

            ! compute 1-norm of x and ax
            xnorm = 0.d0
            axnorm = 0.d0
            !$omp parallel do reduction(+:xnorm,axnorm)
            do i=1,n
                xnorm = xnorm + abs(x(i))
                axnorm = axnorm + abs(ax(i))
                enddo

            ratio = axnorm/xnorm
            max_ratio = max(max_ratio, ratio)
            enddo

        anorm = max_ratio

    else

        print *, "Unrecognized method"
        stop

    endif

    end subroutine approx_norm1

end module approx_norm


	FUNCTION PR_RELH  ( tmpc, dwpc )
C************************************************************************
C* PR_RELH								*
C*									*
C* This function computes RELH from TMPC and DWPC.  The following	*
C* equation is used:							*
C*									*
C*               RELH  =  VAPR / VAPS * 100				*
C*									*
C*                     VAPR = vapor pressure				*
C*                          = PR_VAPR ( DWPC )				*
C*                     VAPS = saturation vapor pressure			*
C*                          = PR_VAPR ( TMPC )				*
C*									*
C* REAL PR_RELH  ( TMPC, DWPC )						*
C*									*
C* Input parameters:							*
C*	TMPC		REAL		Temperature in Celsius		*
C*	DWPC		REAL    	Dewpoint in Celsius		*
C*									*
C* Output parameters:							*
C*	PR_RELH		REAL		Relative humidity in percent	*
C**									*
C* Log:									*
C* I. Graffman/CSC	8/83	Original source code			*
C* M. Goodman/RDS	3/84	Modified prologue			*
C* I. Graffman/RDS	12/87	GEMPAK4					*
C* G. Huffman/GSC	7/88	Documentation				*
C* M. Linda/GSC		 9/97	Corrected right border of prologue	*
C************************************************************************
        INCLUDE    'GEMPRM.PRM'
        INCLUDE    'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing data.
C
	IF  ( ERMISS ( tmpc ) .or. ERMISS ( dwpc ) )  THEN
	    PR_RELH = RMISSD
	  ELSE
C
C*	    Find the vapor pressure .
C
	    E = PR_VAPR ( dwpc )
C
C*	    Find the saturated vapor pressure.
C
	    es = PR_VAPR ( tmpc )
C
C*	    Calculate humidity.
C
	    PR_RELH = ( e / es ) * 100.
	END IF
C*
	RETURN
	END


      SUBROUTINE relax(u,rhs,n)
      INTEGER n
      DOUBLE PRECISION rhs(n,n),u(n,n)
      INTEGER i,ipass,isw,j,jsw
      DOUBLE PRECISION h,h2
      h=1.d0/(n-1)
      h2=h*h
      jsw=1
      do 13 ipass=1,2
        isw=jsw
        do 12 j=2,n-1
          do 11 i=isw+1,n-1,2
            u(i,j)=0.25d0*(u(i+1,j)+u(i-1,j)+u(i,j+1)+u(i,j-1)-h2*rhs(i,
     *j))
11        continue
          isw=3-isw
12      continue
        jsw=3-jsw
13    continue
      return
      END

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


! Author: Alex Schmith, aschmith2019@my.fit.edu
! Course: CSE 4250, Fall 2021
! Project: Proj1, Spread of Epidemics

! This program compiles with gfortan version :
! GNU Fortran (Ubuntu 5.4.0-6ubuntu1~16.04.10) 5.4.0 20160609

program epidemics
    implicit none
    integer :: population, population_infected, n = 1
    real :: y = 1, alpha

    read *, population, alpha
    do while(population > 0 .and. alpha > 0)
        y = infected(alpha) * 100
        population_infected = 1 + y * population / 100

        print *,"Case", n, ":", population_infected, int(y),"%"
        n = n + 1
        read *, population, alpha
    end do

    contains
        !The inverse function of x = ye^y approximated using the Halley Method
        real function lambert_w(x) result(wn)
            implicit none
            real :: x, w = 1, difference

            !Using the Halley Method until difference between W(x) and W(x+1) is less than .000001
            wn = w - (w * EXP(w) - x)/( EXP(w) * (w + 1) - ((w+2) * (w * EXP(w) - x))/(2 * w + 2)  )
            difference = wn - w

            do while ((ABS(difference))> 0.00000001)
                w = wn
                wn = w - (w * EXP(w) - x)/( EXP(w) * (w + 1) - ((w+2) * (w * EXP(w) - x))/(2 * w + 2)  )
                difference = wn - w
            end do
        end function lambert_w

        !function that returns the percentage of people that are infected in a population
        !given the population and the expected amount of people a person is in contact with (alpha)
        real function infected(alpha) result(y)
            implicit none
            real :: alpha, num
            num = -1 * alpha * EXP(-1 * alpha)
            y = 1 + lambert_w(num)/alpha

        end function infected

end program epidemics


!***********************************************************************
!                                                                      *
      SUBROUTINE RADGRD
!                                                                      *
!   This routine sets up the radial grid  R  and the associated arr-   *
!   ays  RP  and  RPOR  in the COMMON block  /GRID/. Different grids   *
!   are generated depending on whether or not  HP  is  zero .          *
!                                                                      *
!   Written by Farid A Parpia, at Oxford  Last revision: 06 Oct 1992   *
!                                                                      *
!***********************************************************************
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:50:19   2/14/04
!...Modified by Charlotte Froese Fischer
!                     Gediminas Gaigalas  10/05/17
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE DEBUG_C
      USE DEF_C, ONLY: PRECIS
      USE GRID_C
      IMPLICIT NONE
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: NP10, I, NB2, NROWS, II, II1, II2
      REAL(DOUBLE) :: EPH, ETT, ETTM1, EPSLON, A, RLAST, REST, T, RESTS, FOFR, &
         FPRI, DELR
!-----------------------------------------------
!
!
!   RPOR(1) is never used in the program: it is arbitrarily
!   set to zero
!
      NP10 = N + 10
      R(1) = 0.0D00
      RPOR(1) = 0.0D00
!
!   Now set up the grids
!
      IF (HP == 0.0D00) THEN
!        default comes here
!
!   Exponential grid if HP is zero
!
!   Initializations
!
         RP(1) = RNT
         EPH = EXP(H)
         ETT = 1.0D00
!
!   Set up the arrays R, RP, RPOR
!
         DO I = 2, NP10
            ETT = EPH*ETT
            ETTM1 = ETT - 1.0D00
            R(I) = RNT*ETTM1
            RP(I) = RNT*ETT
            RPOR(I) = ETT/ETTM1
         END DO
!
      ELSE
!
!   Asymptotically-linear exponential grid otherwise:
!
!   Initializations
!
         EPSLON = 1.0D03*PRECIS
         A = H/HP
         RP(1) = RNT/(A*RNT + 1.0D00)
         RLAST = 0.0D00
         REST = 0.0D00
!
!   Set up the arrays R, RP, RPOR
!
         DO I = 2, NP10
!
            T = H*DBLE(I - 1)
!
!   Solve the implicit equation for R using the Newton-Raphson
!   method
!
    2       CONTINUE
            RESTS = REST + RNT
            FOFR = LOG(RESTS/RNT) + A*REST - T
            FPRI = RESTS/(A*RESTS + 1.0D00)
            DELR = -FOFR*FPRI
            REST = RLAST + DELR
!
            IF (ABS(DELR/REST) < EPSLON) THEN
               R(I) = REST
               RESTS = REST + RNT
               FPRI = RESTS/(A*RESTS + 1.0D00)
               RP(I) = FPRI
               RPOR(I) = FPRI/REST
            ELSE
               RLAST = REST
               GO TO 2
            ENDIF
!
         END DO
!
      ENDIF
!
!   Debug printout
!
      IF (LDBPR(1)) THEN
         WRITE (99, 300)
         NB2 = N/2
         IF (2*NB2 == N) THEN
            NROWS = NB2
         ELSE
            NROWS = NB2 + 1
         ENDIF
         DO II = 1, NROWS
            II1 = II
            II2 = II1 + NROWS
            IF (II2 <= N) THEN
               WRITE (99, 301) R(II1), RP(II1), RPOR(II1), R(II2), RP(II2), &
                  RPOR(II2)
            ELSE IF (II1 <= N) THEN
               WRITE (99, 301) R(II1), RP(II1), RPOR(II1)
            ENDIF
         END DO
      ENDIF
!
      RETURN
!
  300 FORMAT(/,'From SUBROUTINE RADGRD:'/,2(&
         ' -------- r -------- -------- r'' -------',' ------- r''/r ------'))
  301 FORMAT(1P,6(1X,1D19.12))
      RETURN
!
      END SUBROUTINE RADGRD


	FUNCTION  PR_SCLH  ( tb, tt, tdb, tdt, pb, pt )
C************************************************************************
C* PR_SCLH								*
C*									*
C* This function computes SCLH from TB, TT, TDB, TDT, PB, and PT.	*
C* SCLH, the scale height in a layer, can then be used to compute 	*
C* the moist hydrostatic height.  The following equation is used:	*
C*									*
C*              SCLH  =  ( RDGAS / GRAVTY ) * TAV			*
C*									*
C*                    TAV    = average virtual temperature in layer	*
C*                           = ( TVIRTB + TVIRTT ) / 2			*
C*                    TVIRTB = virtual temperature at bottom		*
C*                    TVIRTT = virtual temperature at top		*
C*									*
C* REAL PR_SCLH  ( TB, TT, TDB, TDT, PB, PT )				*
C*									*
C* Input parameters:							*
C*	TB		REAL		Bottom temperature in Celsius	*
C*	TT		REAL		Top temperature in Celsius	*
C*	TDB		REAL		Bottom dewpoint in Celsius	*
C*	TDT		REAL		Top dewpoint in Celsius		*
C*	PB		REAL		Bottom pressure in millibars	*
C*	PT		REAL		Top pressure in millibars	*
C*									*
C* Output parameters:							*
C*	PR_SCLH		REAL		Scale height in meters		*
C**									*
C* Log:									*
C* M. desJardins/GSFC							*
C* G. Huffman/GSC	 7/88	Documentation; test td's, tv's		*
C* M. desJardins/GSFC	12/88	Eliminated check for missing td for	*
C*				the SECOND time.  DO NOT PUT IT BACK.	*
C************************************************************************
        INCLUDE         'GEMPRM.PRM'
        INCLUDE         'ERMISS.FNC'
C------------------------------------------------------------------------
C*      Check for missing data.
C
C*	DO NOT PUT CHECK FOR MISSING TD HERE.  IT WILL SCREW ALL THE
C*	UPPER AIR MERGING SOFTWARE UP!!!!!!!!!!!!!
C
	IF  ( ( ERMISS (tb)  ) .or. ( ERMISS (tt)  ) .or.
     +        ( ERMISS (pb)  ) .or. ( ERMISS (pt)  ) )  THEN
	    PR_SCLH = RMISSD
	  ELSE
	    tvb = PR_TVRK ( tb, tdb, pb )
	    tvt = PR_TVRK ( tt, tdt, pt )
	    IF  ( ( ERMISS (tvb)) .or. ( ERMISS (tvt) ) )  THEN
	        PR_SCLH = RMISSD
              ELSE
	        tav = ( tvb + tvt ) / 2.0
	        PR_SCLH = RKAP * tav
	    END IF
	END IF
C*
	RETURN
	END


PROGRAM SAMPLE_DELAUNAY
! Locate the Delaunay simplex containing a point Q using linear programming.
! Consider a set of points PTS = {P_i} \in R^d, i = 1, ..., n.
! Let A be a (d+1) X (d+1) matrix whose rows are given by: A_i = [ p_i, 1 ];
! let B be a n-vector B_i = p_i \dot p_i; and
! let C be a (d+1)-vector C_i = -Q_i for i = 1, ..., d, C_{d+1} = -1.
!
! If the problem
!
! \max C^T X
! s.t. AX \leq B.
!
! has a unique solution, then the vertices of the simplex S \in DT(PTS) that
! contains Q are given by the solution basis for solving and the affine
! interpolation weights are given by the dual solution for the corresponding
! basis.
!
! In such a situation, since the dual solution is unique, it can be solved
! for via the asymetric dual
!
! \min B^T Y
! s.t. A^T Y = C
! Y \geq 0.
!
! If the solution is nonunique, the problem is significantly harder and cannot
! be solved via the above methodology. Therefore, this code is to be used for
! demonstrative purposes only.

USE DUALSIMP_MOD
IMPLICIT NONE

! Declare inputs and local data.
INTEGER :: D, N, M, DUMMY
REAL(KIND=R8), ALLOCATABLE :: A(:,:), B(:), C(:,:), X(:), Y(:), WEIGHTS(:,:)
REAL(KIND=R8) :: START, FINISH, EPS
INTEGER, ALLOCATABLE :: SIMPLEX(:,:), BASIS(:), IERR(:)
INTEGER :: I, J
CHARACTER(LEN=80) :: FILEPATH

! Open the file path $(filepath), and get the metadata from the
! first line (D, N, and M).
CALL GET_COMMAND_ARGUMENT(1, FILEPATH)
OPEN(1, FILE=TRIM(FILEPATH))
READ(1, *) D, N, M, DUMMY
IF(D .LE. 0 .OR. N .LE. 0 .OR. M .LE. 0) THEN
   WRITE(*,*) "Illegal input dimensions in input file, line 1."
END IF
! Allocate all necessarry arrays.
ALLOCATE(A(D+1,N), B(N), C(D+1,M), Y(N), X(D+1), WEIGHTS(D+1,M), &
   & SIMPLEX(D+1,M), BASIS(D+1), IERR(M), STAT=I)
IF(I .NE. 0) THEN
   WRITE(*,*) "Memory allocation error."
END IF
! Read the input data/training points into the matrix PTS(:,:).
DO I = 1, N
   READ(1, *) A(1:D, I)
   A(D+1,I) = 1.0_R8
   B(I) = DOT_PRODUCT(A(1:D,I),A(1:D,I))
END DO
A = -A
! Read the interpolation points into the matrix C(:,:).
DO I = 1, M
   READ(1, *) C(1:D, I)
   C(D+1,I) = 1.0_R8
END DO
CLOSE(1)
C = -C

EPS = SQRT(EPSILON(0.0_R8))

! Compute the interpolation results and time.
CALL CPU_TIME(START)
!DO I = 1, 20
DO I = 1, M
   CALL FEASIBLEBASIS(D+1, N, A, C(:,I), BASIS, IERR(I),EPS=EPS)
   IF (IERR(I) .EQ. 0) THEN
      CALL DUALSIMPLEX(D+1, N, A, B, C(:,I), BASIS, X, Y, &
         & IERR(I), OBASIS=SIMPLEX(:,I),EPS=EPS)
      IF (IERR(I) .EQ. 0) THEN
         FORALL (J = 1 : D+1) WEIGHTS(J,I) = Y(SIMPLEX(J,I))
      END IF
   END IF
END DO
!END DO
CALL CPU_TIME(FINISH)
FINISH = (FINISH - START)! / 20.0_R8
! Print the timing data.
DO I = 1, M
   IF (IERR(I) .EQ. 2) THEN
      WRITE(*,*) 'Extrapolation at point ', I, '. No solution computed.'
   ELSE IF (IERR(I) .NE. 0) THEN
      WRITE(*,14) 'Error at point ', I, '. IERR = ', IERR(I)
   ELSE
      WRITE(*,10) 'Interpolation point: ', -C(1:D,I)
      WRITE(*,11) 'Simplex : ', SIMPLEX(:,I)
      WRITE(*,10) 'Weights: ', WEIGHTS(:,I)
   END IF
END DO

WRITE(*,15) M, ' points interpolated in ', FINISH, ' seconds.'

10 FORMAT(1X,A,/,(1X,5ES15.7))
11 FORMAT(1X,A,/,(10I7))
14 FORMAT(1X,A,I7,A,I2)
15 FORMAT(/,I7,A,ES16.8,A,/)

END PROGRAM SAMPLE_DELAUNAY


module definitions
    implicit none
        type complex_matrix
            integer*4 :: dimensions(1:2)
            complex*16, allocatable :: entries(:,:)
            complex*16 :: determinant, trace
        end type

    contains
        function enter_mat(entries) result(new_mat)
            implicit none
            complex*16, intent(in) :: entries(:,:)
            type(complex_matrix):: new_mat

            new_mat%dimensions = shape(entries)
            new_mat%entries = entries
            new_mat%trace = mat_trace(entries)
            ! This function is intended for the initialization of the matrix
        end function enter_mat

        function mat_trace(entries) result(trace)
            implicit none
            complex*16, intent(in) :: entries(:,:)
            complex*16 :: trace
            integer*4 :: ii, NN
            integer*4 :: mat_shape(1:2)

            ! Todo: trace only available for square matrices
            mat_shape = shape(entries)
            NN = mat_shape(1)
            trace = (0.d0,0.d0)
            do ii = 1, NN
                trace = trace + entries(ii,ii)
            end do
        end function mat_trace

        function mat_adj(entries) result(adj_mat)
            implicit none
            complex*16, intent(in) :: entries(:,:)
            complex*16, allocatable :: adj_entries(:,:)
            type(complex_matrix) :: adj_mat
            integer*4 :: ii, jj, NN, MM
            integer*4 :: mat_shape(1:2)

            mat_shape = shape(entries)
            NN = mat_shape(1)
            MM = mat_shape(2)
            allocate(adj_entries(1:MM,1:NN))
            do ii = 1, NN
                do jj = 1, MM
                    adj_entries(jj, ii) = conjg(entries(ii,jj))
                end do
            end do
            adj_mat = enter_mat(adj_entries)
        end function mat_adj

        subroutine write_mat(new_mat,file_name)
            implicit none
            character :: file_name
            type(complex_matrix) :: new_mat
            integer*4 :: ii, NN

            NN = new_mat%dimensions(1)
            open(12,file = file_name)
            do ii = 1, NN
                write(12,'(*(F0.8,SP,F0.8,"i",", "))') new_mat%entries(ii,:)
            end do
            close(12)
        end subroutine

        function random_mat(N)
            ! Generates an order N complex matrix with random entries x+iy
            ! where each x and y are uniformly distributed between -1 and 1
            implicit none
            integer :: N, ii, jj
            complex*16, dimension(N,N) :: random_mat
            real*8, dimension(N,N) :: A, B

                call random_number(A)
                ! rescaling into an element in (-1,1)
                A = 2*A - 1
                call random_number(B)
                ! rescaling into an element in (-1,1)
                B = 2*B - 1

                ! populating the matrix
                do ii = 1,N
                    do jj = 1,N
                        ! cast into a complex entry
                        random_mat(ii,jj) = complex(A(ii,jj),B(ii,jj))
                    end do
                end do

        end function random_mat

        function rand_positive(N)
            ! Generates an order N positive matrix with random entries x+iy
            implicit none
            integer :: N
            complex*16, dimension(N,N) :: rand_positive
            type(complex_matrix) :: trans_mat

                rand_positive = random_mat(N)
                ! Theorem a positive semi-definite matrix A is s. t. A = dagger(M)*M
                trans_mat = mat_adj(rand_positive)
                rand_positive = matmul(trans_mat%entries,rand_positive)

        end function rand_positive

end module


module quantile_mod    ! quantile finder.    median = quantile( size(a)/2, a)
contains
    pure recursive function quantile(k, a) result(value)
        integer, intent(in)  :: k          ! position in array
        real, dimension(:), intent(in)  :: a

        real                              :: value      ! output value of quantile
        integer                           :: j
        real                              :: ak

        ak = a(k)
        j = count(a < ak)                              ! how many a(:) < ak

        if (j .ge. k) then
            value = quantile(k, pack(a, a < ak))
        else
            j = count(a > ak) + k - size(a)

            if (j .gt. 0) then
                value = quantile(j, pack(a, a > ak))
            else
                value = ak
            end if
        end if
    end function quantile
end module quantile_mod


! Defines mathemtaical and physical constants such as Pi
! Source: https://www.fortran90.org/src/rosetta.html#arrays
module Constants
use Types, only: dp
implicit none
private
public pi, e, I, OUTPUT_LENGTH
    ! Constants contain more digits than double precision, so that
    ! they are rounded correctly:
    real(dp), parameter :: pi   = 3.1415926535897932384626433832795_dp
    real(dp), parameter :: e    = 2.7182818284590452353602874713527_dp
    complex(dp), parameter :: I = (0, 1)
    integer, parameter :: OUTPUT_LENGTH = 4096
end module


c------------------------------------------------------------------------------
c Tabulate redshift, z, luminosity distance, d_L, and the combination
c d_L^2 (1+z)^-beta against comoving distance, given Omega_0 and Lambda_0
c
      subroutine  tabulate_dist(omega0,lambda0,beta)
*************************************variables*********************************
      implicit none
      integer ntable,NT,it,NNT,jt
      real EPS,beta
c      parameter(NT=1000,EPS=1.0e-04,NNT=10000)
      parameter(NT=10000,EPS=1.0e-04,NNT=10000)
      real rcomov(NT),z(NT),dl(NT),comb(NT),zplus1,x,om,atanhom,rchar
      real drc,zplus1t(NNT),rct(NNT),dz,intp,intt,h,omega0,lambda0,rcuml
      common /dist_table/ ntable,drc,rcomov,z,dl,comb
*******************************************************************************
      ntable=NT
      if (omega0.lt.0.0) then    !flags non-relativistic assumption
      else if (abs(omega0-1.0).le.EPS .and. (lambda0).le.EPS) then !omega=1
      else if (abs(omega0-1.0).gt.EPS .and. (lambda0).le.EPS) then !open
         om=sqrt(1.0-omega0)  !useful numbers in open model
         atanhom=0.5*log((1.0+om)/(1.0-om) )
      else if (abs(omega0+lambda0-1.0).lt.EPS ) then !flat with lambda
c        First tabulate rcomov as with redshift by integrating
         dz=10.0/real(NNT)
         rcuml=0.0
         rct(1)=0.0
         zplus1t(1)=1.0
         intp=0.0
         do it=2,NNT
            zplus1t(it)=1.0+real(it-1)*dz
            intt=1.0/sqrt(omega0*zplus1t(it)**3 + 1.0 - omega0)
            rcuml=rcuml+0.5*(intt+intp)*dz
            rct(it)=rcuml*3000.0
            intp=intt
         end do
      else
         stop 'Not programmed for this cosmology'
      end if

c
c     Loop over comoving distances and compute corresponding
c     redshift and luminosity distances...
      drc=6000.0/real(NT)
      do it=1,NT   !make table uniformly spaced in comoving distance.
         rcomov(it)=real(it-1)*drc
c
         if (omega0.lt.0.0) then
            zplus1=1.0 +rcomov(it)/3000.0
            z(it)= rcomov(it)/3000.0
            dl(it)=rcomov(it)
            comb(it)= dl(it)**2 * zplus1**(-beta)
         else if (abs(omega0-1.0).le.EPS .and. (lambda0).le.EPS) then !omega=1
            zplus1=1.0/(1.0-rcomov(it)/6000.0)**2
            z(it)=zplus1-1.0
            dl(it)=rcomov(it)*zplus1
            comb(it)=dl(it)**2 * zplus1**(-beta)
c
         else if (abs(omega0-1.0).gt.EPS .and. (lambda0).le.EPS) then !open
            x=tanh(atanhom-om*rcomov(it)/6000.0)
            zplus1=((om/x)**2-om**2)/omega0
            z(it)=zplus1-1.0
            rchar=(6000.0/(zplus1*omega0**2)) *
     &           (omega0*z(it)+(omega0-2.0)*(sqrt(1+omega0*z(it))-1.0))
            dl(it)=rchar*zplus1
            comb(it)=dl(it)**2 * zplus1**(-beta)
c
         else if (abs(omega0+lambda0-1.0).lt.EPS ) then !flat
c           look up redshift from temporary table
            jt=1
            do while (rcomov(it).ge.rct(jt))
               jt=jt+1
               if (jt.gt.NNT) stop
     &         'tabulate_dist(): rct() not tabulated to sufficient z'
            end do
            h=(rcomov(it)-rct(jt-1))/(rct(jt)-rct(jt-1))
            zplus1=zplus1t(jt-1)*(1.0-h) + zplus1t(jt)*h
            z(it)=zplus1-1.0
            dl(it)=rcomov(it)*zplus1
            comb(it)=dl(it)**2 * zplus1**(-beta)
c
         end if
      end do

      return
      end
c------------------------------------------------------------------------------
c Given either rcomov, z, dl or dl^2(1+z)^-beta look up the corresponding
c values of the other quantities. The integer isel specifies which argument
c is set on input.
c
      subroutine  search_dist(rc,zplus1,dlum,dlzcomb,isel)
*************************************variables*********************************
      implicit none
      integer ntable,NT,it,isel,itlo,ithi
      parameter(NT=10000)
      real rcomov(NT),z(NT),dl(NT),comb(NT),rc,zplus1,dlum,dlzcomb
      real drc,h,rit,zt
      save itlo,ithi
      common /dist_table/ ntable,drc,rcomov,z,dl,comb
      data itlo/1/
      data ithi/1/
*******************************************************************************
      if (isel.eq.1) then  !rc set so lookup zplus1,dlum and dlum^2(1+z)^-beta
c      This is the fast/easy case as the table is equally spaced in rc
         rit=1.0+rc/drc
         it = int(rit)
         h= rit-real(it)
         if (it.ge.NT) stop 'search_dist() r beyond tabulated range'
         zplus1=1.0+ z(it)*(1.0-h)    +    z(it+1)*h
         dlum=       dl(it)*(1.0-h)  +    dl(it+1)*h
         dlzcomb=  comb(it)*(1.0-h)  +  comb(it+1)*h
c
      else if (isel.eq.2) then !zplus1 set
c      Search for corresponding redshift
         zt=zplus1-1.0
         if (z(ithi).lt.zt .or. z(itlo).gt.zt ) then!short cut if zt close to
            itlo=1                                  !last call
            ithi=NT                                 !otherwise do binary search
            do while (ithi-itlo.gt.1)
               it=(ithi+itlo)/2
               if(z(it).gt.zt)then
                  ithi=it
               else
                  itlo=it
               endif
            end do
         end if
         h=(zt-z(itlo))/(z(ithi)-z(itlo))
         rc=     rcomov(itlo)*(1.0-h)  +rcomov(ithi)*h
         dlum=       dl(itlo)*(1.0-h)  +    dl(ithi)*h
         dlzcomb=  comb(itlo)*(1.0-h)  +  comb(ithi)*h
c
      else if (isel.eq.3) then !luminosity distance set
c      Search for corresponding luminosity distance
         if (dl(ithi).lt.dlum .or. dl(itlo).gt.dlum ) then
            itlo=1
            ithi=NT
            do while (ithi-itlo.gt.1)
               it=(ithi+itlo)/2
               if(dl(it).gt.dlum)then
                  ithi=it
               else
                  itlo=it
               endif
            end do
         end if
         h=(dlum-dl(itlo))/(dl(ithi)-dl(itlo))
         rc=     rcomov(itlo)*(1.0-h)  +rcomov(ithi)*h
         zplus1=1.0+ z(itlo)*(1.0-h)    +    z(ithi)*h
         dlzcomb=  comb(itlo)*(1.0-h)  +  comb(ithi)*h
c
      else if (isel.eq.4) then !dl^2 zplus1^-beta set
c      Search for corresponding  dlum^2 zplus1^-beta set
         if (comb(ithi).lt.dlzcomb .or. comb(itlo).gt.dlzcomb ) then
            itlo=1
            ithi=NT
            do while (ithi-itlo.gt.1)
               it=(ithi+itlo)/2
               if(comb(it).gt.dlzcomb)then
                  ithi=it
               else
                  itlo=it
               endif
            end do
         end if
         h=(dlzcomb-comb(itlo))/(comb(ithi)-comb(itlo))
         rc=     rcomov(itlo)*(1.0-h)  +rcomov(ithi)*h
         zplus1=1.0+ z(itlo)*(1.0-h)    +    z(ithi)*h
         dlum=       dl(itlo)*(1.0-h)  +    dl(ithi)*h
c
      end if
      return
      end
c------------------------------------------------------------------------------


      SUBROUTINE sla_CLDJ (IY, IM, ID, DJM, J)
*+
*     - - - - -
*      C L D J
*     - - - - -
*
*  Gregorian Calendar to Modified Julian Date
*
*  Given:
*     IY,IM,ID     int    year, month, day in Gregorian calendar
*
*  Returned:
*     DJM          dp     modified Julian Date (JD-2400000.5) for 0 hrs
*     J            int    status:
*                           0 = OK
*                           1 = bad year   (MJD not computed)
*                           2 = bad month  (MJD not computed)
*                           3 = bad day    (MJD computed)
*
*  The year must be -4699 (i.e. 4700BC) or later.
*
*  The algorithm is derived from that of Hatcher 1984
*  (QJRAS 25, 53-55).
*
*  P.T.Wallace   Starlink   11 March 1998
*
*  Copyright (C) 1998 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 59 Temple Place, Suite 330,
*    Boston, MA  02111-1307  USA
*
*-

      IMPLICIT NONE

      INTEGER IY,IM,ID
      DOUBLE PRECISION DJM
      INTEGER J

*  Month lengths in days
      INTEGER MTAB(12)
      DATA MTAB / 31,28,31,30,31,30,31,31,30,31,30,31 /

*  Preset status
      J=0

*  Validate year
      IF (IY.LT.-4699) THEN
         J=1
      ELSE

*     Validate month
         IF (IM.GE.1.AND.IM.LE.12) THEN

*        Allow for leap year
            IF (MOD(IY,4).EQ.0) THEN
               MTAB(2)=29
            ELSE
               MTAB(2)=28
            END IF
            IF (MOD(IY,100).EQ.0.AND.MOD(IY,400).NE.0)
     :         MTAB(2)=28

*        Validate day
            IF (ID.LT.1.OR.ID.GT.MTAB(IM)) J=3

*        Modified Julian Date
            DJM=DBLE((1461*(IY-(12-IM)/10+4712))/4
     :               +(306*MOD(IM+9,12)+5)/10
     :               -(3*((IY-(12-IM)/10+4900)/100))/4
     :               +ID-2399904)

*        Bad month
         ELSE
            J=2
         END IF

      END IF

      END


subroutine pcoefficients(uf, vf, auf_bar, avf_bar, awp, aep, asp, anp, app, bp, dx, dy, imax, jmax, xi, xf)
use parallel_variables
use kind_parameters
implicit none

!! Input variables

integer, intent(in):: imax, jmax, xi, xf
real(kind=dp), dimension(imax, xi-1:xf+1), intent(inout):: awp, aep, asp, anp, app
real(kind=dp), dimension(imax, xi-1:xf+1), intent(inout):: bp
real(kind=dp), dimension(imax-1, xi-1:xf+1)::uf, auf_bar
real(kind=dp), dimension(imax, xi-1:xf+1)::vf, avf_bar
real(kind=dp), intent(in):: dx(imax), dy(jmax)

!! Other local variables

real(kind=dp):: totalmb
integer:: ip, jp

!   Velocities are specified along the boundaries

do jp = xi,xf

      do ip = 2,imax-1

            awp(ip,jp) = (dy(jp)/auf_bar(ip-1,jp))*dy(jp)
            aep(ip,jp) = (dy(jp)/auf_bar(ip,jp))*dy(jp)
            asp(ip,jp) = (dx(ip)/avf_bar(ip,jp-1))*dx(ip)
            anp(ip,jp) = (dx(ip)/avf_bar(ip,jp))*dx(ip)

      end do

end do

!  Linking P-coefficients are zeros

if (xi .eq. 2) then

do ip = 2,imax-1

      asp(ip,2) = 0.0d0

end do

end if

if (xf .eq. jmax-1) then

do ip = 2,imax-1

      anp(ip,jmax-1) = 0.0d0

end do

end if

do jp = xi,xf

     awp(2,jp) = 0.0d0
     aep(imax-1,jp) = 0.0d0

end do

do jp = xi,xf

     do ip = 2,imax-1

            app(ip,jp) = aep(ip,jp) + awp(ip,jp) + asp(ip,jp) + anp(ip,jp)

     end do

end do

totalmb = 0.0d0

do jp = xi,xf

     do ip = 2,imax-1

        !bp(ip,jp) = (uf(ip-1,jp)-uf(ip,jp))/dx(ip) + (vf(ip,jp-1)-vf(ip,jp))/dy(jp)

        bp(ip,jp) = (uf(ip-1,jp)-uf(ip,jp))*dy(jp) + (vf(ip,jp-1)-vf(ip,jp))*dx(ip)

        totalmb = totalmb + bp(ip,jp)

     end do

end do

!if (taskid .eq. 0) write(*,*) app
!write(*,*) ''

end subroutine


!Autor: Claudio Iván Esparza Castañeda
!Título: Evaluar polinomios y su derivada
!Descripción: Se encarga de evaluar polinomios mediante la anidación de los términos, así como la evaluación de la derivada
!Fecha: 19/01/2020

program eval !Inicio del programa
  implicit none !Sin variables implícitas
  REAL, allocatable, dimension(:)::a !Vector tipo REAL con dimensión dinámica
  REAL::p, d, x !Varibles tipo REAL
  INTEGER::i, n !Variables enteras
  d=0.0 !Inicializar valor de derivada
  p=0.0 !Inicializar valor de polinomio
  WRITE(*, *) "Grado del polinomio" !Preguntar por el grado del polinomio
  READ(*, *) n
  allocate(a(0:n)) !Asignar valor a variable dinámica
  WRITE(*, *) "Coeficientes del polinomio a0+a1x+a2x²+...anx^n" !Pregunta coeficientes del polinomio
  do i=0, n
     READ(*, *) a(i)
  end do
  WRITE(*, *) "Valor para evaluar polinomio" !Preguntar valor para evaluar polinomio
  READ(*, *) x
  do i=n, 0, -1 !Recorrer el arreglo al revés
     d=d*x+p !Derivada=Derivada*valor+Polinomio
     p=p*x+a(i) !Polinomio=Polinomio*valor+elemento del vector
  end do
  deallocate(a)
  WRITE(*, 1) "F(x)=", p, "F'(x)=", d !Imprimir resultado con formato 1
  1 format(' ', a5, f10.3, 5x, a6, f10.3) !
end program eval


subroutine inital(neqn,t,u0)
!
!  Subroutine inital sets the initial condition vector
!  for the linear PDE problem
!
!  Double precision coding is used
implicit double precision(a-h,o-z)
!
!  Size the arrays
dimension u0(neqn)
!
!  Problem parameters
call par(xl,xu,pi)
!
!  Initial condition
do i=1,neqn
x=xl+dfloat(i-1)/dfloat(neqn-1)*(xu-xl)
u0(i)=dsin(pi*x)
end do
return
!
!  End of inital
end


c     program DRSTCST
c>> 1996-06-05 DRSTCST Krogh Fixes for conversion to C.
c>> 1996-05-28 DRSTCST Krogh Moved formats up.
c>> 1994-10-19 DRSTCST Krogh  Changes to use M77CON
c>> 1994-08-09 DRSTCST WVS Remove '0' from format
c>> 1992-04-22 DRSTCST CAO commented program statement
c>> 1989-05-08 DRSTCST FTK, CLL
c>> 1989-05-04 DRSTCST FTK, CLL
c Driver to demonstrate STCST
c     ------------------------------------------------------------------
c--S replaces "?": DR?TCST, ?TCST
c     ------------------------------------------------------------------
      real             F(65), S(32), T, TTIME
      real             DELTAT, DELTAO, OMEGA, FTRUE, SIN1,COS1
      real             PI, ZERO, ONE
      integer    K, KSKIP, M, MS, N, ND, MA(1)
      parameter (M = 6)
c      parameter (N = 2 ** M + 1)
      parameter (N = 65)
      parameter (ND = 1)
      parameter (KSKIP = 10)
      parameter (PI = 3.1415926535897932384E0)
      parameter (ZERO = 0.E0)
      parameter (ONE = 1.E0)
      data TTIME / 10.E0 /
      data MA / M /
 1000 format (/'  K', 4X, 'OMEGA', 8X, 'COMPUTED', 9X, 'TRUE')
 1001 format (1X, I3, 1P,E13.5, 2E15.7)
c     ------------------------------------------------------------------
      SIN1 = SIN (ONE)
      COS1 = COS (ONE)
      DELTAT = TTIME / REAL(N - 1)
      DELTAO = REAL(KSKIP) * (PI / TTIME)
      T = ZERO
c                 Compute (TTIME / 2 ) * F(T)
      F(1) = TTIME / PI
      do 10 K = 2, N
         T = T + DELTAT
         F(K) = TTIME * SINH(T) / SINH(PI * T)
   10 continue
c
      MS = 0
      call STCST (F, 'C', 'A', MA, ND, MS, S)
c
      OMEGA = ZERO
      write (*, 1000)
      do 20 K = 1, N, KSKIP
         FTRUE = SIN1 / (COSH(OMEGA) + COS1)
         write (*, 1001) K, OMEGA, F(K), FTRUE
         OMEGA = OMEGA + DELTAO
   20 continue
      stop
      end


program static_array_in_function_test
    implicit none
    integer, parameter :: n = 100

    print '(F10.5)', compute_normal_avg(n)

contains

    function compute_normal_avg(n) result(average)
        use, intrinsic :: iso_fortran_env, only : REAL32
        implicit none
        integer, intent(in) :: n
        real(kind=REAL32) :: average
        real(kind=REAL32), dimension(n) :: v

        call random_number(v)
        average = sum(v)/n

    end function compute_normal_avg

end program static_array_in_function_test


      logical function graph_connected(topo,nn)
      !
      ! analyze graph for connectedness by a depth first search (DFS)
      ! we start at the first vertex and travel along all possible paths
      ! at the end, all vertices must be visited, otherwise the graph is not connected
      ! input: topo -- a topology matrix topo (should be symmetrically filled)
      !                !=0 - connection  =0 - no connection
      !        nn   -- its dimension
      ! returns: .true. if graph is connected, .false. otherwise
      !        nn = 0 or 1 --> returns .true.
      !
      ! Andreas Koehn, Dec. 2020
      !
      implicit none

      integer, intent(in) :: nn, topo(nn,nn)

      logical, allocatable :: visited(:)

      if (nn.eq.0.or.nn.eq.1) then
         graph_connected = .true.
         return
      end if

      allocate(visited(nn))
      visited(1:nn) = .false.

      call dfs(1)

      graph_connected = all(visited)

      deallocate(visited)

      return

      contains

        recursive subroutine dfs(idx)

        integer, intent(in) :: idx

        integer :: jdx

        visited(idx) = .true.
        do jdx = 1, nn
          if (topo(idx,jdx).ne.0 .and. .not.visited(jdx)) then
            call dfs(jdx)
          end if
        end do

        end subroutine

      end function


module loglikelihood_module
    use utils_module, only: dp

    contains

    !> Eggbox likelihood
    !!
    !! \f[ -\log L(x, y) = (2+ \prod_i^n \cos(\theta_i/2) )^5 \f]
    !!
    function loglikelihood(theta,phi)
        implicit none
        real(dp), intent(in),  dimension(:) :: theta         !> Input parameters
        real(dp), intent(out), dimension(:) :: phi           !> Output derived parameters
        real(dp)                            :: loglikelihood ! loglikelihood value to output

        ! No normalisation implemented yet
        loglikelihood = 0

        ! calculate
        loglikelihood =  loglikelihood  -  (2 + product(cos(theta / 2d0) ) )**5

    end function loglikelihood

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

    end subroutine setup_loglikelihood

end module loglikelihood_module


!-----------------------------------------------------------------------
! Solve tridiagonal matrix equation
!-----------------------------------------------------------------------
subroutine TRIDIAG(Nvec,Nmax,a,b,c,r,x)

implicit none

integer, intent(in) :: &
  Nvec,              &! Vector length
  Nmax                ! Maximum vector length

real*8, intent(in) :: &
  a(Nmax),           &! Below-diagonal matrix elements
  b(Nmax),           &! Diagonal matrix elements
  c(Nmax),           &! Above-diagonal matrix elements
  r(Nmax)             ! Matrix equation rhs

real*8, intent(out) :: &
  x(Nmax)             ! Solution vector

integer :: n          ! Loop counter

! Work space
real*8 :: beta, gamma(Nvec)

beta = b(1)
x(1) = r(1) / beta

do n = 2, Nvec
  gamma(n) = c(n-1) / beta
  beta = b(n) - a(n)*gamma(n)
  x(n) = (r(n) - a(n)*x(n-1)) / beta
end do

do n = Nvec - 1, 1, -1
  x(n) = x(n) - gamma(n+1)*x(n+1)
end do

end subroutine TRIDIAG


!---------------------------------------------------------------------!
! OWNER: Ithaca Combustion Enterprise, LLC                            !
! COPYRIGHT: © 2012, Ithaca Combustion Enterprise, LLC                !
! LICENSE: BSD 3-Clause License (The complete text of the license can !
!  be found in the `LICENSE-ICE.txt' file included in the ISAT-CK7    !
!  source directory.)                                                 !
!---------------------------------------------------------------------!

subroutine ell_pair_cover_cv_ql( n, c1, gg1, c2, gg2, c, gg )

!  Given a pair of ellipsoids, E1 and E2, determine a third ellipsoid
!  E which covers E1 and E2.
!  E is defined by:  (x-c)^T * G * G^T * (x-c) <= 1, where the array gg
!  contains G in packed format.  Similarly for E1 and E2.

!  Method:
!  c = (c1+c2)/2
!  With A = G * G^T, A1 = G1 * G1^T, A2 = G2 * G2^T, d = (c1-c2)/2, A is obtained from
!  A^{-1} = a * ( A1^{-1} + A2^{-1} + d * d^T )
!         = a * B^T * B,  where B = [G_1^{-1}; G_2^{-1}; d^T]
!         = a * L^T * L,  where B = Q * [0; L] is the QL factorization of B
!         = G^{-T} * G,   where a is determined so that E just covers E1 and E2.
!  Thus, G = L^{-1} * sqrt(a)

!  Note: this is a heuristic: E does not have minimal volume.

!  S.B. Pope  12/2/2007

implicit none

integer, parameter      :: k_dp = kind(1.d0)
integer, intent(in)     :: n
real(k_dp), intent(in)  :: c1(n), gg1((n*(n+1))/2), c2(n), gg2((n*(n+1))/2)
real(k_dp), intent(out) :: c(n),  gg((n*(n+1))/2)

integer    :: i, j, k, info, lwork, m
real(k_dp) :: g1(n,n), g2(n,n), cv1(n,n), cv2(n,n), dc(n), &
              orig(n), c3(n), xf(n), rsq1, rsq2, &
              b(n+n+1,n), work(3*n*n), eye(n,n)

lwork = 3*n*n
m     = n+n+1

eye   = 0.d0 !  set identity
do i = 1, n
   eye(i,i) = 1.d0
end do

c    = 0.5d0 * ( c1 + c2 )
dc   = 0.5d0 * ( c1 - c2 )
orig = 0.d0

! unpack gg1 and gg2 into g1 and g2
k  = 0
g1 = 0.d0
g2 = 0.d0
do j = 1, n
   do i = j, n
      k = k + 1
	  g1(i,j) = gg1(k)
	  g2(i,j) = gg2(k)
   end do
end do

!  form inverses G1^{-1}, G2^{-1}
cv1 = eye
cv2 = eye
call dtrsm( 'L', 'L', 'N', 'N', n, n, 1.d0, g1, n, cv1, n )
call dtrsm( 'L', 'L', 'N', 'N', n, n, 1.d0, g2, n, cv2, n )

!  assemble B=[ G1^{-1}; G2^{-1}; d^T ]
b(1:n,1:n)     = cv1
b(n+1:n+n,1:n) = cv2
b(m,1:n)       = dc

!  B = Q [0; L]
call dgeqlf( m, n, b, m, c3, work, lwork, info )

if( info /= 0 ) then
   write(0,*)'ell_pair_cover_cv_ql dgeqlf failed: info = ', info
   stop
endif

!  extract L from the QL factorization: cv2 = L
cv2 = 0.d0
do i = 1, n
   do j = 1, i
      cv2(i,j) = b(i+n+1,j)
   end do
end do

!  change sign of rows as needed so that diagonals are positive
do j = 1, n
   if( cv2(j,j) < 0.d0 ) cv2(j,1:j) = -cv2(j,1:j)
end do

!  cv1=L_0 = L^{-1} = G / sqrt(a)
cv1 = eye
call dtrsm( 'L', 'L', 'N', 'N', n, n, 1.d0, cv2, n, cv1, n )

!  Determine a such that E just covers E1 and E2

!  Transform so that E is the unit ball, and find the furthest point on E1
c3 = c1 - c   ! c3 = G^T (c1 - c )
call dtrmv( 'L', 'T', 'N', n, cv1, n, c3, 1 )

! g1 = G^{-1} * G1
call dtrsm( 'L', 'L', 'N', 'N', n, n, 1.d0, cv1, n, g1, n )

call ellu_pt_near_far( 2, n, c3, g1, orig, xf )  !  xf is furthest point
rsq1 = sum( xf*xf )

!  Transform so that E is the unit ball, and find the furthest point on E2
c3 = c2 - c   ! c3 = G^T (c2 - c )
call dtrmv( 'L', 'T', 'N', n, cv1, n, c3, 1 )

! g2 = G^{-1} * G2
call dtrsm( 'L', 'L', 'N', 'N', n, n, 1.d0, cv1, n, g2, n )

call ellu_pt_near_far( 2, n, c3, g2, orig, xf )

rsq2 = sum( xf*xf )

rsq1 = max(rsq1,rsq2)
if( rsq1 > 0.d0 ) rsq1 = 1.d0 / sqrt( rsq1 )
k  = 0  !  pack re-scaled G into gg
do j = 1, n
   do i = j, n
      k = k + 1
	  gg(k) = rsq1 * cv1(i,j)
   end do
end do

return
end subroutine ell_pair_cover_cv_ql


module fishpack_precision

    use, intrinsic :: ISO_C_binding, only: &
        C_INT, &
        C_DOUBLE, &
        C_DOUBLE_COMPLEX

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: wp ! Working precision
    public :: ip ! Integer precision
    public :: PI, TWO_PI, HALF_PI, EPS, MACHINE_EPSILON
    public :: get_pi

    ! Floating point precision constants
    integer, parameter :: FLOAT128 = selected_real_kind(p=33, r=4931) ! 33 digits, range [10^(-4931), 10^(+4931) - 1], 128 bits
    integer, parameter :: FLOAT64 = selected_real_kind(p=15, r=307) ! 15 digits, range [10^(-307) , 10^(+307)  - 1], 64 bits
    integer, parameter :: FLOAT32 = selected_real_kind(p=6, r=37) ! 6 digits, range [10^(-37)  , 10^(+37)   - 1],  32 bits
    integer, parameter :: wp = C_DOUBLE ! Default floating point precision
    integer, parameter :: cwp = C_DOUBLE_COMPLEX

    ! Integer precision constants
    integer, parameter :: INT64 = selected_int_kind(r=18) ! 19 digits plus sign, range [-2^(63),+2^(63) - 1], 64 bits
    integer, parameter :: INT32 = selected_int_kind(r=9) ! 10 digits plus sign, range [-2^(31),+2^(31) - 1], 32 bits
    integer, parameter :: INT16 = selected_int_kind(r=4) ! 5 digits plus sign, range [-2^(15),+2^(15) - 1], 16 bits
    integer, parameter :: INT8 = selected_int_kind(r=2) ! 3 digits plus sign, range [-2^(7) ,+2^(7)  - 1], 8 bits
    integer, parameter :: ip = C_INT ! Default integer precision

    ! Calculation constants
    real(wp), parameter :: ONE = 1.0_wp
    real(wp), parameter :: TWO = 2.0_wp
    real(wp), parameter :: PI = acos(-ONE)
    real(wp), parameter :: HALF_PI = PI/TWO
    real(wp), parameter :: TWO_PI = TWO * PI
    real(wp), parameter :: MACHINE_EPSILON = epsilon(ONE)
    real(wp), parameter :: EPS = MACHINE_EPSILON

contains

    pure function get_pi() &
        result (return_value)

        ! Dummy arguments
        real(wp) :: return_value

        return_value = 3.141592653589793238462643383279502884197169399375105820974_wp

    end function get_pi

end module fishpack_precision


program arithmatic
    use iso_fortran_env, only : i1 => int8, i2 => int16, r4 => real32, r8=> real64
    implicit none
    real(r4) :: x_r4
    real(r8) :: x_r8
    x_r4 = 7_r4 / 2_r4
    print *, x_r4
    x_r8 = 7_r8 / 2_r8
    print *, x_r8
    print *, 7_i1 / 2_i1
    print *, 7_i2 / 2_i2

end program arithmatic


module constants
   implicit none

   real, parameter :: pi = 3.1415926536
   real, parameter :: e = 2.7182818285

contains
   subroutine show_consts()
      print *, "Pi = ", pi
      print *, "e = ", e
   end subroutine show_consts

end module constants

program module_example
   use constants
   implicit none

   real :: x, ePowerx, area, radius
   x = 2.0
   radius = 7.0
   ePowerx = e**x
   area = pi*radius**2

   call show_consts()

   print *, "e raised to the power of 2.0 = ", ePowerx
   print *, "Area of a circle with radius 7.0 = ", area

end program module_example