      subroutine nscore(nd,vr,tmin,tmax,iwt,wt,tmp,lout,vrg,ierror)
c-----------------------------------------------------------------------
c
c              Transform Univariate Data to Normal Scores
c              ******************************************
c
c This subroutibe takes "nd" data "vr(i),i=1,...,nd" possibly weighted
c by "wt(i),i=,...,nd" and returns the normal scores transform N(0,1)
c as "vrg(i),i=1,...,nd".  The extra storage array "tmp" is required
c so that the data can be returned in the same order (just in case
c there are associated arrays like the coordinate location).
c
c
c
c INPUT VARIABLES:
c
c   nd               Number of data (no missing values)
c   vr(nd)           Data values to be transformed
c   tmin,tmax        data trimming limits
c   iwt              =0, equal weighted; =1, then apply weight
c   wt(nd)           Weight for each data (don't have to sum to 1.0)
c   tmp(nd)          Temporary storage space for sorting
c   lout             if > 0 then transformation table will be written
c
c
c
c OUTPUT VARIABLES:
c
c   vrg(nd)          normal scores
c   ierror           error flag (0=error free,1=problem)
c
c
c
c EXTERNAL REFERENCES:
c
c   gauinv           Calculates the inverse of a Gaussian cdf
c   sortem           sorts a number of arrays according to a key array
c
c
c
c-----------------------------------------------------------------------
      parameter(EPSLON=1.0e-20)
      real      vr(nd),wt(nd),vrg(nd),tmp(nd)
      real*8    pd
c
c Sort the data in ascending order and calculate total weight:
c
      ierror = 0
      twt    = 0.0
      do i=1,nd
            tmp(i) = real(i)
            if(vr(i).ge.tmin.and.vr(i).lt.tmax) then
                  if(iwt.eq.0) then
                        twt = twt + 1.
                  else
                        twt = twt + wt(i)
                  end if
            end if
      end do
      if(nd.lt.1.or.twt.lt.EPSLON) then
            ierror = 1
            return
      end if
      call sortem(1,nd,vr,2,wt,tmp,d,e,f,g,h)
c
c Compute the cumulative probabilities:
c
      oldcp = 0.0
      cp    = 0.0
      do i=1,nd
            cp     =  cp + wt(i) / twt
            wt(i)  = (cp + oldcp)/ 2.0
            oldcp  =  cp
            call gauinv(dble(wt(i)),vrg(i),ierr)
            if(lout.gt.0) write(lout,'(f12.5,1x,f12.5)') vr(i),vrg(i)
      end do
c
c Get the arrays back in original order:
c
      call sortem(1,nd,tmp,3,wt,vr,vrg,e,f,g,h)
c
c Finished:
c
      return
      end


PROGRAM test_entry
REAL :: a = 1., b = 2., c = 1., d = 2.
CALL initl ( a, b, c, d )
DO I = 1, 10
   CALL eval3 ( REAL(i), result )
   WRITE (*,*) 'EVAL3(', i, ') = ', result
END DO
END PROGRAM

SUBROUTINE eval3 ( x, result )
!
!     Evaluates a third order polynomial of the form:
!        RESULT = A + B*X + C*X**2 + D*X**3
!
!     Declare calling arguments
IMPLICIT NONE
REAL :: a1, b1, c1, d1, x, result

! Declare local variables
REAL, SAVE :: a, b, c, d

! Calculate result
result = a + b**x + c*x**2 + d*x**3

RETURN

! Entry INITL specifies the values of a, b, c, and d
! to be used when evaluating the polynomial.

ENTRY initl(a1, b1, c1, d1)
a = a1
b = b1
c = c1
d = d1

RETURN
END SUBROUTINE


submodule(euler_interface_m) euler_prob_0039_m
    implicit none

contains

    module character(len=20) function euler0039()
        write (euler0039, "(i20)") ans(1000)
    end function euler0039

    integer function ans(n)
        integer, intent(in) :: n
        integer :: i, count_arr(n)

        do i = 1, n
            count_arr(i) = right_triangle_with_perimeter(i)
        end do

        ans = maxloc(count_arr, dim=1)
    end function ans

    integer function right_triangle_with_perimeter(p)
        integer, intent(in) :: p
        integer :: i, j, k, t

        t = 0
        do i = 1, p/2 + 1
            do j = 1, p - i - 1
                k = p - i - j
                if (is_right_triangle(i, j, k)) t = t + 1
            end do
        end do
        right_triangle_with_perimeter = t
    end function right_triangle_with_perimeter

    logical function is_right_triangle(i, j, k)
        integer, intent(in) :: i, j, k

        is_right_triangle = .false.
        if (i**2 + j**2 == k**2) then
            is_right_triangle = .true.
        end if
    end function is_right_triangle

end submodule euler_prob_0039_m


!> module containing the mean radial distribution function
module mean_RDF_mod
  use working_prec_mod, only: rk, ik
  use globals_mod
  implicit none
  private

   public:: mean_RDF
contains

  !> calc. radial distribution function
  subroutine mean_RDF ( g_RDF )
    integer(ik):: ref_part
    integer(ik):: n_part_k = 0
    real(rk):: dis_1
    real(rk):: dis_max
    real(rk), allocatable:: dis_k(:), dis_k2(:)
    real(rk), intent(out):: g_RDF(intervalls)
    real(rk):: dis_kmin
    real(rk):: d2
    integer(ik):: i, k

    allocate(dis_k(0:intervalls))
    allocate(dis_k2(0:intervalls))

    ref_part = 1_ik

    dis_1 =  sigma_list(ref_part)
    dis_max = 4._rk * dis_1

    do k = 0, intervalls
        dis_k(k) = ( dis_1**2._rk + ( dis_max**2._rk - dis_1**2._rk ) * real(k,rk)/real(intervalls,rk) )**0.5_rk
        dis_k2(k) = dis_k(k)*dis_k(k)
    end do

    do k = 1, intervalls
      do i = 2, npart
        d2 = squared_distance (particle_positions(:,ref_part), particle_positions(:,i))
        if ( dis_k2(k-1_ik) .lt. d2 .and. d2 .lt. dis_k2(k) )    n_part_k = n_part_k + 1_ik
      end do
      g_RDF(k) = 3._rk*boxlength**3._rk*real(n_part_k,rk) / ( 2._rk*PI* ( dis_k(k)**3._rk - dis_k(k-1_ik)**3._rk ) * real(npart,rk) * ( real(npart,rk) - 1._rk )  )
      n_part_k = 0_ik
    end do

    deallocate(dis_k)
    deallocate(dis_k2)

  end subroutine mean_RDF

end module mean_RDF_mod


program intrinsics_31
    real :: x = 63.29
    real :: y = -63.59
    real :: x_ceil, y_ceil
    x_ceil = ceiling(x)
    y_ceil = ceiling(y)
    print *, x_ceil, ceiling(x_ceil)
    print *, y_ceil, ceiling(y_ceil)
end program intrinsics_31


*
* grades - Calculate student grades based on partial scores
*
* The final grade is 30% programs, 50% tests and 20% homework
*
* Grades are assigned based on the following scale:
*
*    >0.90 4.0
*    >0.80 3.0
*    >0.70 2.0
*    <0.60 0.0
*
*  Written by: C. Severance 16Mar92
*
* Declare the variables:
*
      REAL PPER,TPER,HPER,TOTAL
*
* Prompt the user for the three percentages
*
      PRINT *,'Enter the program percentage -'
      READ *,PPER
      PRINT *,'Enter the test percentage -'
      READ *,TPER
      PRINT *,'Enter the homework percentage -'
      READ *,HPER
*
* Calculate the total percentage
*
      TOTAL = PPER * 0.30 + TPER * 0.50 + HPER * 0.20
      PRINT *,'Total percentage is ', TOTAL
*
* Determine the final grade
*
      IF ( TOTAL .GE. 0.90 ) THEN
        PRINT *,'Grade is 4.0'
      ELSE IF ( TOTAL .GE. 0.80 ) THEN
        PRINT *,'Grade is 3.0'
      ELSE IF ( TOTAL .GE. 0.70 ) THEN
        PRINT *,'Grade is 2.0'
      ELSE
        PRINT *,'Grade is 0.0'
      ENDIF
      END


program inverse_matrix
	! This program tests the speed of flips
	! in inverting square matrices

	use flips

	implicit none

	type(flips_s) :: gg
	integer :: n, nb,id,i
	real, dimension(:,:), allocatable :: amat, eye
	real :: ts,te,tot

	write(*,*) 'Give matrix size: '
	read(*,*) n
	write(*,*) 'Give rotation buffer size: '
	read(*,*) nb
	write(*,*) 'Give problem ID (0 uses memory): '
	read(*,*) id

	! Init flips
	if (id <= 0) then
		call flips_init(gg,n,n,buffersize=nb)
	else
		call flips_init(gg,n,n,id,nb)
	end if

	allocate(amat(n,n),eye(n,n))

	eye = 0.0
	do i = 1,n
		eye(i,i) = 1.0
	end do

	call random_number(amat)

	write(*,*) 'flips START!'

	call cpu_time(ts)
	! Feed into flips
	do i = 1,n
		call flips_add(gg,1,amat(i,:),eye(i,:))
	end	do

	! Do the last rotation
	call make_rotations_s(gg)

	call cpu_time(te)

	tot = te-ts

	write(*,*) 'Rotation time: ',tot

	! Solve
	call cpu_time(ts)
	call solve_utriag_mem_s(gg)
	call cpu_time(te)

	tot = te-ts + tot

	write(*,*) 'Solving time: ',te-ts
	write(*,*) 'Total time: ',tot

	! Kill
	call flips_kill(gg,.FALSE.)

end program inverse_matrix


program rect_method
implicit none

integer :: i,N

real(8),allocatable :: x(:),y(:),a(:)
 real (8):: h,ul,ll,E

N =10

ul =1.0
ll =0.0
h = (ul-ll)/N

print*, h,ul,ll,N

allocate(x(N+1),y(N+1))

	do i =1, N+1
	if(i==1) then
	x(i) = ll
	else
	x(i) =x(i-1)+h
	end if
	print*, x(i)
	end do

y =1/x
y = exp(-x**2)
y = (2+ sin(2*x**2))
y = exp(10-x)
print*,x
print*,y
print*,x,y
   do i=1,N
!a(i) = h*(y(i+1)-y(i))
a(i)= h*y(i+1)
print*, a(i)
end do

print*,"the calculated value for the integration is",sum(a)
print*,"the value of error is ",E

deallocate (x,y,a)
end program rect_method


Program Temperature
  implicit none

  real :: kel, cel, fah, ran

  write(*,*) "Input Kelvin temperature to convert"
  read(*,*) kel

  call temp_convert(kel, cel, fah, ran)
  write(*, "((a10), f10.3)") "Kelvin", kel
  write(*, "((a10), f10.3)") "Celsius", cel
  write(*, "((a10), f10.3)") "Fahrenheit", fah
  write(*, "((a10), f10.3)") "Rankine", ran

contains

subroutine temp_convert(kelvin, celsius, fahrenheit, rankine)
  real, intent(in)  :: kelvin
  real, intent(out) :: celsius, fahrenheit, rankine

  celsius = kelvin - 273.15
  fahrenheit = kelvin * 1.8 - 459.67
  rankine = kelvin * 1.8

end subroutine
end program


      subroutine ire_dtk(ctfmp,n_A,n_Athth,n_Axx,n_B,n_DDLthetatheta,n_D
     &DLxx,n_K,n_TS,n_alpha,n_beta,n_metthetatheta,n_metxx,n_rho,nm1_K,n
     &p1_K,Nx,ht,hx,res)
      implicit none
      integer i
      integer Nx
      real*8 ht
      real*8 hx
      real*8 ctfmp(Nx)
      real*8 n_A(Nx)
      real*8 n_Athth(Nx)
      real*8 n_Axx(Nx)
      real*8 n_B(Nx)
      real*8 n_DDLthetatheta(Nx)
      real*8 n_DDLxx(Nx)
      real*8 n_K(Nx)
      real*8 n_TS(Nx)
      real*8 n_alpha(Nx)
      real*8 n_beta(Nx)
      real*8 n_metthetatheta(Nx)
      real*8 n_metxx(Nx)
      real*8 n_rho(Nx)
      real*8 nm1_K(Nx)
      real*8 np1_K(Nx)
      real*8 res
      real*8 qb
      res = 0.0D0
      do i=2, Nx-1, 1
      qb = -0.5000000000000000D0 * (nm1_K(i) - 0.1D1 * np1_K(i)) / ht -
     #0.3333333333333333D0 * n_alpha(i) * n_K(i) ** 2 - 0.50000000000000
     #00D0 / ctfmp(i) * (-0.1D1 * n_K(i - 1) + n_K(i + 1)) / hx * n_beta
     #(i) - 0.5000000000000000D0 * n_alpha(i) * n_rho(i) - 0.50000000000
     #00000D0 * n_alpha(i) * n_TS(i) - 0.1D1 / n_A(i) ** 2 * n_Axx(i) **
     # 2 * n_alpha(i) - 0.2D1 / n_B(i) ** 2 * n_Athth(i) ** 2 * n_alpha(
     #i) + 0.2D1 / n_metthetatheta(i) * n_DDLthetatheta(i) + 0.1D1 / n_m
     #etxx(i) * n_DDLxx(i)
      res = res + qb**2
      end do
      res = sqrt(res/(1*Nx))
      END


program Magic_Square
  implicit none

  integer, parameter :: order = 15
  integer :: i, j

  write(*, "(a, i0)") "Magic Square Order: ", order
  write(*, "(a)")     "----------------------"
  do i = 1, order
    do j = 1, order
      write(*, "(i4)", advance = "no") f1(order, i, j)
    end do
    write(*,*)
  end do
  write(*, "(a, i0)") "Magic number = ", f2(order)

contains

integer function f1(n, x, y)
  integer, intent(in) :: n, x, y

  f1 = n * mod(x + y - 1 + n/2, n) + mod(x + 2*y - 2, n) + 1
end function

integer function f2(n)
  integer, intent(in) :: n

  f2 = n * (1 + n * n) / 2
end function
end program


! ALOHA2D Plasma module
!
!
module aloha2d_plasma
  use aloha2d_constants
  use aloha2d_globalparameters

  real :: wce, wcD, wcT, wcH, wcHe ! cyclotron pulsations
  real :: wpe, wpD, wpT, wpH, wpHe ! plasma pulsations
  real :: dwpe, dwpD, dwpT, dwpH, dwpHe ! plasma pulsations derivative with respect to ne
  real :: S, D, P, dD, dP ! Cold plasma dielectric tensor elements

contains

  !
  ! Calculate the cyclotron pulsations :
  ! wce, wcD, wcT, wcH, wcHe
  !
  subroutine eval_cyclotron_pulsations()
    wce = omega_c(qe, B0, me)
    wcD = omega_c(qe, B0, mD)
    wcT = omega_c(qe, B0, mT)
    wcH = omega_c(qe, B0, mH)
    wcHe= omega_c(2*qe, B0, mHe)
  end subroutine eval_cyclotron_pulsations

  !
  ! Calculate the plasma pulsations
  ! wpe, wpD, wpT, wpH, wpHe
  !
  subroutine eval_plasma_pulsations()
    wpe = omega_p(ne, qe, me)
    wpD = omega_p(nD, qe, mD)
    wpT = omega_p(nT, qe, mT)
    wpH = omega_p(nH, qe, mH)
    wpHe= omega_p(nHe, 2*qe, mHe)
  end subroutine eval_plasma_pulsations

  !
  ! Calculate the plasma pulsations derivatives
  ! with respect to species's density
  ! dwpe, dwpD, dwpT, dwpH, dwpHe
  !
  subroutine eval_plasma_pulsations_derivatives()
    dwpe = domega_p(dne, qe, me)
    dwpD = domega_p(dnD, qe, mD)
    dwpT = domega_p(dnT, qe, mT)
    dwpH = domega_p(dnH, qe, mH)
    dwpHe = domega_p(2*nD, 2*qe, mHe)
  end subroutine eval_plasma_pulsations_derivatives

  !
  ! Calculate the cold plasma dielectric tensor element (Stix elements)
  ! S, D, P
  ! and derivatives with respect to the electron density
  ! dD, dP
  !
  subroutine eval_cold_tensor_elements()
    S = cold_plasma_dielectric_S()
    D = cold_plasma_dielectric_D()
    P = cold_plasma_dielectric_P()
    dD = cold_plasma_dielectric_dD()
    dP = cold_plasma_dielectric_dP()
  end subroutine eval_cold_tensor_elements

  !
  ! Cyclotron pulsation
  !
  function omega_c(q,B,m)
    real, intent(in) :: q,B,M ! electric charge, DC magnetic field, mass
    real  :: omega_c

    omega_c = q*B/m
  end function omega_c

  !
  ! Plasma pulsation
  !
  function omega_p(n, q, m)
    real, intent(in) :: n, q, m
    real :: omega_p

    omega_p = sqrt(n*q**2/(Eps0*m))
  end function omega_p

  !
  ! Plasma pulsation derivative with respect to the species density
  !
  function domega_p(dn, q, m)
    real, intent(in) :: dn, q, m
    real :: domega_p

    domega_p = sqrt(dn*q**2/(Eps0*m))
  end function domega_p

  !
  ! Cold plasma dielectric tensor elements S, D, P
  !
  function cold_plasma_dielectric_S()
    real :: cold_plasma_dielectric_S

    cold_plasma_dielectric_S = 1-( wpe**2/((2*pi*f)**2-wce**2) + &
      wpD**2/((2*pi*f)**2-wcD**2) + &
      wpT**2/((2*pi*f)**2-wcT**2) + &
      wpH**2/((2*pi*f)**2-wcH**2) + &
      wpHe**2/((2*pi*f)**2-wcHe**2) )

  end function cold_plasma_dielectric_S

  function cold_plasma_dielectric_D()
    real :: cold_plasma_dielectric_D
    cold_plasma_dielectric_D= &
      -wpe**2*wce/(2*pi*f*((2*pi*f)**2 - wce**2)) + &
      wpD**2*wcD/(2*pi*f*((2*pi*f)**2 - wcD**2)) + &
      wpT**2*wcT/(2*pi*f*((2*pi*f)**2 - wcT**2)) + &
      wpH**2*wcH/(2*pi*f*((2*pi*f)**2 - wcH**2)) + &
      wpHe**2*wcHe/(2*pi*f*((2*pi*f)**2 - wcHe**2))
  end function cold_plasma_dielectric_D

  function cold_plasma_dielectric_P()
    real :: cold_plasma_dielectric_P

    cold_plasma_dielectric_P=&
      1-( (wpe/(2*pi*f))**2 + &
      (wpD/(2*pi*f))**2 + &
      (wpT/(2*pi*f))**2 + &
      (wpH/(2*pi*f))**2 + &
      (wpHe/(2*pi*f))**2 )

  end function cold_plasma_dielectric_P

  !
  ! Cold plasma tensor element derivative with respect to electron density dD, dP
  !
  function cold_plasma_dielectric_dD()
    real :: cold_plasma_dielectric_dD

    cold_plasma_dielectric_dD=&
      (-dwpe**2*wce/(2*pi*f*((2*pi*f)**2 - wce**2)) + &
      dwpD**2*wcD/(2*pi*f*((2*pi*f)**2 - wcD**2)) +   &
      dwpT**2*wcT/(2*pi*f*((2*pi*f)**2 - wcT**2)) +   &
      dwpH**2*wcH/(2*pi*f*((2*pi*f)**2 - wcH**2)) +   &
      dwpHe**2*wcHe/(2*pi*f*((2*pi*f)**2 - wcHe**2))) &
      /k0
  end function cold_plasma_dielectric_dD

  function cold_plasma_dielectric_dP()
    real :: cold_plasma_dielectric_dP

    cold_plasma_dielectric_dP=&
    -((dwpe/(2*pi*f))**2 + &
      (dwpD/(2*pi*f))**2 +   &
      (dwpT/(2*pi*f))**2 +   &
      (dwpH/(2*pi*f))**2 +   &
      (dwpHe/(2*pi*f))**2)/k0

  end function cold_plasma_dielectric_dP

end module aloha2d_plasma


module test_gauss
    use stdlib_kinds, only: dp
    use testdrive, only : new_unittest, unittest_type, error_type, check
    use stdlib_quadrature , only: gauss_legendre, gauss_legendre_lobatto

    implicit none

contains

    !> Collect all exported unit tests
    subroutine collect_gauss(testsuite)
        !> Collection of tests
        type(unittest_type), allocatable, intent(out) :: testsuite(:)

        testsuite = [ &
            new_unittest("gauss-analytic", test_gauss_analytic), &
            new_unittest("gauss-5", test_gauss_5), &
            new_unittest("gauss-32", test_gauss_32), &
            new_unittest("gauss-64", test_gauss_64), &
            new_unittest("gauss-lobatto-analytic", test_gauss_lobatto_analytic), &
            new_unittest("gauss-lobatto-5", test_gauss_lobatto_5), &
            new_unittest("gauss-lobatto-32", test_gauss_lobatto_32), &
            new_unittest("gauss-lobatto-64", test_gauss_lobatto_64) &
            ]
    end subroutine

    subroutine test_gauss_analytic(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer :: i
        real(dp) :: analytic, numeric

        ! test an analytic derivative versus an actual integration
        ! x**2 from -1 to 1
        analytic = 2.0_dp/3.0_dp
        do i=2,6
            block
                real(dp), dimension(i) :: x,w
                call gauss_legendre(x,w)
                numeric = sum(x**2 * w)
                !print *, i, numeric
                call check(error, abs(numeric-analytic) < 2*epsilon(analytic))
                if (allocated(error)) return
            end block
        end do

    end subroutine

    subroutine test_gauss_5(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer :: i

        ! test the values of nodes and weights
        i = 5
        block
            real(dp), dimension(i) :: x,w,xref,wref
            call gauss_legendre(x,w)
            xref(1)=-0.90617984593866399_dp
            xref(2)=-0.53846931010568309_dp
            xref(3)=0.0_dp
            xref(4)=0.53846931010568309_dp
            xref(5)=0.90617984593866399_dp

            wref(1)=0.23692688505618909_dp
            wref(2)=0.47862867049936647_dp
            wref(3)=0.56888888888888889_dp
            wref(4)=0.47862867049936647_dp
            wref(5)=0.23692688505618909_dp

            call check(error, all(abs(x-xref) < 2*epsilon(x(1))))
            if (allocated(error)) return
            call check(error, all(abs(w-wref) < 2*epsilon(w(1))))
        end block

    end subroutine

    subroutine test_gauss_32(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer :: i

        i = 32
        block
            real(dp), dimension(i) :: x,w,xref,wref
            call gauss_legendre(x,w)

            xref(1)=-0.99726386184948156_dp
            xref(2)=-0.98561151154526834_dp
            xref(3)=-0.96476225558750643_dp
            xref(4)=-0.93490607593773969_dp
            xref(5)=-0.89632115576605212_dp
            xref(6)=-0.84936761373256997_dp
            xref(7)=-0.79448379596794241_dp
            xref(8)=-0.73218211874028968_dp
            xref(9)=-0.66304426693021520_dp
            xref(10)=-0.58771575724076233_dp
            xref(11)=-0.50689990893222939_dp
            xref(12)=-0.42135127613063535_dp
            xref(13)=-0.33186860228212765_dp
            xref(14)=-0.23928736225213707_dp
            xref(15)=-0.14447196158279649_dp
            xref(16)=-0.048307665687738316_dp
            xref(17)=0.048307665687738316_dp
            xref(18)=0.14447196158279649_dp
            xref(19)=0.23928736225213707_dp
            xref(20)=0.33186860228212765_dp
            xref(21)=0.42135127613063535_dp
            xref(22)=0.50689990893222939_dp
            xref(23)=0.58771575724076233_dp
            xref(24)=0.66304426693021520_dp
            xref(25)=0.73218211874028968_dp
            xref(26)=0.79448379596794241_dp
            xref(27)=0.84936761373256997_dp
            xref(28)=0.89632115576605212_dp
            xref(29)=0.93490607593773969_dp
            xref(30)=0.96476225558750643_dp
            xref(31)=0.98561151154526834_dp
            xref(32)=0.99726386184948156_dp

            wref(1)=0.0070186100094700966_dp
            wref(2)=0.016274394730905671_dp
            wref(3)=0.025392065309262059_dp
            wref(4)=0.034273862913021433_dp
            wref(5)=0.042835898022226681_dp
            wref(6)=0.050998059262376176_dp
            wref(7)=0.058684093478535547_dp
            wref(8)=0.065822222776361847_dp
            wref(9)=0.072345794108848506_dp
            wref(10)=0.078193895787070306_dp
            wref(11)=0.083311924226946755_dp
            wref(12)=0.087652093004403811_dp
            wref(13)=0.091173878695763885_dp
            wref(14)=0.093844399080804566_dp
            wref(15)=0.095638720079274859_dp
            wref(16)=0.096540088514727801_dp
            wref(17)=0.096540088514727801_dp
            wref(18)=0.095638720079274859_dp
            wref(19)=0.093844399080804566_dp
            wref(20)=0.091173878695763885_dp
            wref(21)=0.087652093004403811_dp
            wref(22)=0.083311924226946755_dp
            wref(23)=0.078193895787070306_dp
            wref(24)=0.072345794108848506_dp
            wref(25)=0.065822222776361847_dp
            wref(26)=0.058684093478535547_dp
            wref(27)=0.050998059262376176_dp
            wref(28)=0.042835898022226681_dp
            wref(29)=0.034273862913021433_dp
            wref(30)=0.025392065309262059_dp
            wref(31)=0.016274394730905671_dp
            wref(32)=0.0070186100094700966_dp

            call check(error, all(abs(x-xref) < 2*epsilon(x(1))))
            if (allocated(error)) return
            call check(error, all(abs(w-wref) < 2*epsilon(w(1))))
        end block

    end subroutine

    subroutine test_gauss_64(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer :: i

        i = 64
        block
            real(dp), dimension(i) :: x,w,xref,wref
            call gauss_legendre(x,w)

            xref(1)=-0.99930504173577214_dp
            xref(2)=-0.99634011677195528_dp
            xref(3)=-0.99101337147674432_dp
            xref(4)=-0.98333625388462596_dp
            xref(5)=-0.97332682778991096_dp
            xref(6)=-0.96100879965205372_dp
            xref(7)=-0.94641137485840282_dp
            xref(8)=-0.92956917213193958_dp
            xref(9)=-0.91052213707850281_dp
            xref(10)=-0.88931544599511411_dp
            xref(11)=-0.86599939815409282_dp
            xref(12)=-0.84062929625258036_dp
            xref(13)=-0.81326531512279756_dp
            xref(14)=-0.78397235894334141_dp
            xref(15)=-0.75281990726053190_dp
            xref(16)=-0.71988185017161083_dp
            xref(17)=-0.68523631305423324_dp
            xref(18)=-0.64896547125465734_dp
            xref(19)=-0.61115535517239325_dp
            xref(20)=-0.57189564620263403_dp
            xref(21)=-0.53127946401989455_dp
            xref(22)=-0.48940314570705296_dp
            xref(23)=-0.44636601725346409_dp
            xref(24)=-0.40227015796399160_dp
            xref(25)=-0.35722015833766812_dp
            xref(26)=-0.31132287199021096_dp
            xref(27)=-0.26468716220876742_dp
            xref(28)=-0.21742364374000708_dp
            xref(29)=-0.16964442042399282_dp
            xref(30)=-0.12146281929612055_dp
            xref(31)=-0.072993121787799039_dp
            xref(32)=-0.024350292663424433_dp
            xref(33)=0.024350292663424433_dp
            xref(34)=0.072993121787799039_dp
            xref(35)=0.12146281929612055_dp
            xref(36)=0.16964442042399282_dp
            xref(37)=0.21742364374000708_dp
            xref(38)=0.26468716220876742_dp
            xref(39)=0.31132287199021096_dp
            xref(40)=0.35722015833766812_dp
            xref(41)=0.40227015796399160_dp
            xref(42)=0.44636601725346409_dp
            xref(43)=0.48940314570705296_dp
            xref(44)=0.53127946401989455_dp
            xref(45)=0.57189564620263403_dp
            xref(46)=0.61115535517239325_dp
            xref(47)=0.64896547125465734_dp
            xref(48)=0.68523631305423324_dp
            xref(49)=0.71988185017161083_dp
            xref(50)=0.75281990726053190_dp
            xref(51)=0.78397235894334141_dp
            xref(52)=0.81326531512279756_dp
            xref(53)=0.84062929625258036_dp
            xref(54)=0.86599939815409282_dp
            xref(55)=0.88931544599511411_dp
            xref(56)=0.91052213707850281_dp
            xref(57)=0.92956917213193958_dp
            xref(58)=0.94641137485840282_dp
            xref(59)=0.96100879965205372_dp
            xref(60)=0.97332682778991096_dp
            xref(61)=0.98333625388462596_dp
            xref(62)=0.99101337147674432_dp
            xref(63)=0.99634011677195528_dp
            xref(64)=0.99930504173577214_dp

            wref(1)=0.0017832807216964329_dp
            wref(2)=0.0041470332605624676_dp
            wref(3)=0.0065044579689783629_dp
            wref(4)=0.0088467598263639477_dp
            wref(5)=0.011168139460131129_dp
            wref(6)=0.013463047896718643_dp
            wref(7)=0.015726030476024719_dp
            wref(8)=0.017951715775697343_dp
            wref(9)=0.020134823153530209_dp
            wref(10)=0.022270173808383254_dp
            wref(11)=0.024352702568710873_dp
            wref(12)=0.026377469715054659_dp
            wref(13)=0.028339672614259483_dp
            wref(14)=0.030234657072402479_dp
            wref(15)=0.032057928354851554_dp
            wref(16)=0.033805161837141609_dp
            wref(17)=0.035472213256882384_dp
            wref(18)=0.037055128540240046_dp
            wref(19)=0.038550153178615629_dp
            wref(20)=0.039953741132720341_dp
            wref(21)=0.041262563242623529_dp
            wref(22)=0.042473515123653589_dp
            wref(23)=0.043583724529323453_dp
            wref(24)=0.044590558163756563_dp
            wref(25)=0.045491627927418144_dp
            wref(26)=0.046284796581314417_dp
            wref(27)=0.046968182816210017_dp
            wref(28)=0.047540165714830309_dp
            wref(29)=0.047999388596458308_dp
            wref(30)=0.048344762234802957_dp
            wref(31)=0.048575467441503427_dp
            wref(32)=0.048690957009139720_dp
            wref(33)=0.048690957009139720_dp
            wref(34)=0.048575467441503427_dp
            wref(35)=0.048344762234802957_dp
            wref(36)=0.047999388596458308_dp
            wref(37)=0.047540165714830309_dp
            wref(38)=0.046968182816210017_dp
            wref(39)=0.046284796581314417_dp
            wref(40)=0.045491627927418144_dp
            wref(41)=0.044590558163756563_dp
            wref(42)=0.043583724529323453_dp
            wref(43)=0.042473515123653589_dp
            wref(44)=0.041262563242623529_dp
            wref(45)=0.039953741132720341_dp
            wref(46)=0.038550153178615629_dp
            wref(47)=0.037055128540240046_dp
            wref(48)=0.035472213256882384_dp
            wref(49)=0.033805161837141609_dp
            wref(50)=0.032057928354851554_dp
            wref(51)=0.030234657072402479_dp
            wref(52)=0.028339672614259483_dp
            wref(53)=0.026377469715054659_dp
            wref(54)=0.024352702568710873_dp
            wref(55)=0.022270173808383254_dp
            wref(56)=0.020134823153530209_dp
            wref(57)=0.017951715775697343_dp
            wref(58)=0.015726030476024719_dp
            wref(59)=0.013463047896718643_dp
            wref(60)=0.011168139460131129_dp
            wref(61)=0.0088467598263639477_dp
            wref(62)=0.0065044579689783629_dp
            wref(63)=0.0041470332605624676_dp
            wref(64)=0.0017832807216964329_dp

            call check(error, all(abs(x-xref) < 2*epsilon(x(1))))
            if (allocated(error)) return
            call check(error, all(abs(w-wref) < 2*epsilon(w(1))))
        end block

    end subroutine

    subroutine test_gauss_lobatto_analytic(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer :: i
        real(dp) :: analytic, numeric

        ! test an analytic derivative versus an actual integration
        ! x**2 from -1 to 1
        analytic = 2.0_dp/3.0_dp
        do i=4,6 ! lobatto quadrature is less accurate for low i, so omit checking at i=2,3
            block
                real(dp), dimension(i) :: x,w
                call gauss_legendre_lobatto(x,w)
                numeric = sum(x**2 * w)
                !print *, i, numeric
                call check(error, abs(numeric-analytic) < 2*epsilon(analytic))
                if (allocated(error)) return
            end block
        end do

    end subroutine

    subroutine test_gauss_lobatto_5(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer :: i

        ! test the values of nodes and weights
        i = 5
        block
            real(dp), dimension(i) :: x,w,xref,wref
            call gauss_legendre_lobatto(x,w)

            xref(1)=-1.0000000000000000_dp
            xref(2)=-0.65465367070797714_dp
            xref(3)=0.0_dp
            xref(4)=0.65465367070797714_dp
            xref(5)=1.0000000000000000_dp

            wref(1)=0.10000000000000000_dp
            wref(2)=0.54444444444444444_dp
            wref(3)=0.71111111111111111_dp
            wref(4)=0.54444444444444444_dp
            wref(5)=0.10000000000000000_dp

            call check(error, all(abs(x-xref) < 2*epsilon(x(1))))
            if (allocated(error)) return
            call check(error, all(abs(w-wref) < 2*epsilon(w(1))))
        end block

    end subroutine

    subroutine test_gauss_lobatto_32(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer :: i

        i = 32
        block
            real(dp), dimension(i) :: x,w,xref,wref
            call gauss_legendre_lobatto(x,w)

            xref(1)=-1.0000000000000000_dp
            xref(2)=-0.99260893397276136_dp
            xref(3)=-0.97529469048270923_dp
            xref(4)=-0.94828483841723238_dp
            xref(5)=-0.91184993906373190_dp
            xref(6)=-0.86635247601267552_dp
            xref(7)=-0.81224473177744234_dp
            xref(8)=-0.75006449393667480_dp
            xref(9)=-0.68042975561555082_dp
            xref(10)=-0.60403258714842113_dp
            xref(11)=-0.52163226288156529_dp
            xref(12)=-0.43404771720184694_dp
            xref(13)=-0.34214940653888149_dp
            xref(14)=-0.24685065885020530_dp
            xref(15)=-0.14909859681364749_dp
            xref(16)=-0.049864725046593252_dp
            xref(17)=0.049864725046593252_dp
            xref(18)=0.14909859681364749_dp
            xref(19)=0.24685065885020530_dp
            xref(20)=0.34214940653888149_dp
            xref(21)=0.43404771720184694_dp
            xref(22)=0.52163226288156529_dp
            xref(23)=0.60403258714842113_dp
            xref(24)=0.68042975561555082_dp
            xref(25)=0.75006449393667480_dp
            xref(26)=0.81224473177744234_dp
            xref(27)=0.86635247601267552_dp
            xref(28)=0.91184993906373190_dp
            xref(29)=0.94828483841723238_dp
            xref(30)=0.97529469048270923_dp
            xref(31)=0.99260893397276136_dp
            xref(32)=1.0000000000000000_dp

            wref(1)=0.0020161290322580645_dp
            wref(2)=0.012398106501373844_dp
            wref(3)=0.022199552889291965_dp
            wref(4)=0.031775135410915466_dp
            wref(5)=0.041034201586062723_dp
            wref(6)=0.049885271336221207_dp
            wref(7)=0.058240497248055870_dp
            wref(8)=0.066016877257154544_dp
            wref(9)=0.073137139602679033_dp
            wref(10)=0.079530525692106252_dp
            wref(11)=0.085133497949668231_dp
            wref(12)=0.089890372957357833_dp
            wref(13)=0.093753875546813814_dp
            wref(14)=0.096685608948002601_dp
            wref(15)=0.098656436540761777_dp
            wref(16)=0.099646771501276778_dp
            wref(17)=0.099646771501276778_dp
            wref(18)=0.098656436540761777_dp
            wref(19)=0.096685608948002601_dp
            wref(20)=0.093753875546813814_dp
            wref(21)=0.089890372957357833_dp
            wref(22)=0.085133497949668231_dp
            wref(23)=0.079530525692106252_dp
            wref(24)=0.073137139602679033_dp
            wref(25)=0.066016877257154544_dp
            wref(26)=0.058240497248055870_dp
            wref(27)=0.049885271336221207_dp
            wref(28)=0.041034201586062723_dp
            wref(29)=0.031775135410915466_dp
            wref(30)=0.022199552889291965_dp
            wref(31)=0.012398106501373844_dp
            wref(32)=0.0020161290322580645_dp

            call check(error, all(abs(x-xref) < 2*epsilon(x(1))))
            if (allocated(error)) return
            call check(error, all(abs(w-wref) < 2*epsilon(w(1))))
        end block

    end subroutine

    subroutine test_gauss_lobatto_64(error)
        !> Error handling
        type(error_type), allocatable, intent(out) :: error

        integer :: i

        i = 64
        block
            real(dp), dimension(i) :: x,w,xref,wref
            call gauss_legendre_lobatto(x,w)

            xref(1)=-1.0000000000000000_dp
            xref(2)=-0.99817987150216322_dp
            xref(3)=-0.99390272670305729_dp
            xref(4)=-0.98719267660274024_dp
            xref(5)=-0.97806666283139607_dp
            xref(6)=-0.96654711036909923_dp
            xref(7)=-0.95266223578866292_dp
            xref(8)=-0.93644602747563416_dp
            xref(9)=-0.91793817351028163_dp
            xref(10)=-0.89718396784585004_dp
            xref(11)=-0.87423420065762749_dp
            xref(12)=-0.84914503454299099_dp
            xref(13)=-0.82197786730751705_dp
            xref(14)=-0.79279918182620814_dp
            xref(15)=-0.76168038340811997_dp
            xref(16)=-0.72869762508883694_dp
            xref(17)=-0.69393162129070484_dp
            xref(18)=-0.65746745031297650_dp
            xref(19)=-0.61939434613843155_dp
            xref(20)=-0.57980548006771842_dp
            xref(21)=-0.53879773271680044_dp
            xref(22)=-0.49647145693605775_dp
            xref(23)=-0.45293023223158118_dp
            xref(24)=-0.40828061128985404_dp
            xref(25)=-0.36263185922626182_dp
            xref(26)=-0.31609568619562581_dp
            xref(27)=-0.26878597401917000_dp
            xref(28)=-0.22081849749695350_dp
            xref(29)=-0.17231064108779297_dp
            xref(30)=-0.12338111165002799_dp
            xref(31)=-0.074149647946115919_dp
            xref(32)=-0.024736727621958728_dp
            xref(33)=0.024736727621958728_dp
            xref(34)=0.074149647946115919_dp
            xref(35)=0.12338111165002799_dp
            xref(36)=0.17231064108779297_dp
            xref(37)=0.22081849749695350_dp
            xref(38)=0.26878597401917000_dp
            xref(39)=0.31609568619562581_dp
            xref(40)=0.36263185922626182_dp
            xref(41)=0.40828061128985404_dp
            xref(42)=0.45293023223158118_dp
            xref(43)=0.49647145693605775_dp
            xref(44)=0.53879773271680044_dp
            xref(45)=0.57980548006771842_dp
            xref(46)=0.61939434613843155_dp
            xref(47)=0.65746745031297650_dp
            xref(48)=0.69393162129070484_dp
            xref(49)=0.72869762508883694_dp
            xref(50)=0.76168038340811997_dp
            xref(51)=0.79279918182620814_dp
            xref(52)=0.82197786730751705_dp
            xref(53)=0.84914503454299099_dp
            xref(54)=0.87423420065762749_dp
            xref(55)=0.89718396784585004_dp
            xref(56)=0.91793817351028163_dp
            xref(57)=0.93644602747563416_dp
            xref(58)=0.95266223578866292_dp
            xref(59)=0.96654711036909923_dp
            xref(60)=0.97806666283139607_dp
            xref(61)=0.98719267660274024_dp
            xref(62)=0.99390272670305729_dp
            xref(63)=0.99817987150216322_dp
            xref(64)=1.0000000000000000_dp

            wref(1)=0.00049603174603174603_dp
            wref(2)=0.0030560082449124904_dp
            wref(3)=0.0054960162038171569_dp
            wref(4)=0.0079212897900466340_dp
            wref(5)=0.010327002366815328_dp
            wref(6)=0.012707399197454735_dp
            wref(7)=0.015056683987961443_dp
            wref(8)=0.017369116384542182_dp
            wref(9)=0.019639040723241718_dp
            wref(10)=0.021860903511518060_dp
            wref(11)=0.024029268144023827_dp
            wref(12)=0.026138828614338438_dp
            wref(13)=0.028184422665848517_dp
            wref(14)=0.030161044499089451_dp
            wref(15)=0.032063857057727025_dp
            wref(16)=0.033888203884125398_dp
            wref(17)=0.035629620524489486_dp
            wref(18)=0.037283845459801173_dp
            wref(19)=0.038846830537807737_dp
            wref(20)=0.040314750881560237_dp
            wref(21)=0.041684014250801952_dp
            wref(22)=0.042951269833601819_dp
            wref(23)=0.044113416446892471_dp
            wref(24)=0.045167610125947702_dp
            wref(25)=0.046111271084289059_dp
            wref(26)=0.046942090027028316_dp
            wref(27)=0.047658033802220637_dp
            wref(28)=0.048257350376414549_dp
            wref(29)=0.048738573122233185_dp
            wref(30)=0.049100524407501308_dp
            wref(31)=0.049342318477139574_dp
            wref(32)=0.049463363620776646_dp
            wref(33)=0.049463363620776646_dp
            wref(34)=0.049342318477139574_dp
            wref(35)=0.049100524407501308_dp
            wref(36)=0.048738573122233185_dp
            wref(37)=0.048257350376414549_dp
            wref(38)=0.047658033802220637_dp
            wref(39)=0.046942090027028316_dp
            wref(40)=0.046111271084289059_dp
            wref(41)=0.045167610125947702_dp
            wref(42)=0.044113416446892471_dp
            wref(43)=0.042951269833601819_dp
            wref(44)=0.041684014250801952_dp
            wref(45)=0.040314750881560237_dp
            wref(46)=0.038846830537807737_dp
            wref(47)=0.037283845459801173_dp
            wref(48)=0.035629620524489486_dp
            wref(49)=0.033888203884125398_dp
            wref(50)=0.032063857057727025_dp
            wref(51)=0.030161044499089451_dp
            wref(52)=0.028184422665848517_dp
            wref(53)=0.026138828614338438_dp
            wref(54)=0.024029268144023827_dp
            wref(55)=0.021860903511518060_dp
            wref(56)=0.019639040723241718_dp
            wref(57)=0.017369116384542182_dp
            wref(58)=0.015056683987961443_dp
            wref(59)=0.012707399197454735_dp
            wref(60)=0.010327002366815328_dp
            wref(61)=0.0079212897900466340_dp
            wref(62)=0.0054960162038171569_dp
            wref(63)=0.0030560082449124904_dp
            wref(64)=0.00049603174603174603_dp

            call check(error, all(abs(x-xref) < 2*epsilon(x(1))))
            if (allocated(error)) return
            call check(error, all(abs(w-wref) < 2*epsilon(w(1))))
        end block

    end subroutine

end module

program tester
    use, intrinsic :: iso_fortran_env, only : error_unit
    use testdrive, only : run_testsuite, new_testsuite, testsuite_type
    use test_gauss, only : collect_gauss
    implicit none
    integer :: stat, is
    type(testsuite_type), allocatable :: testsuites(:)
    character(len=*), parameter :: fmt = '("#", *(1x, a))'

    stat = 0

    testsuites = [ &
        new_testsuite("gauss", collect_gauss) &
        ]

    do is = 1, size(testsuites)
        write(error_unit, fmt) "Testing:", testsuites(is)%name
        call run_testsuite(testsuites(is)%collect, error_unit, stat)
    end do

    if (stat > 0) then
        write(error_unit, '(i0, 1x, a)') stat, "test(s) failed!"
        error stop
    end if
end program


!	Multinomial covariance matrix.
!	density is vector of probabilities.
!	meanth is vector of means.
!	quadpoint is array of weights.
function mcovth(density,meanth,quadpoint)
implicit none
interface
!
	subroutine makesym(matrix)
!	Symmetrize n by n matrix based on lower triangle.
		real(kind=8),intent(inout)::matrix(:,:)
	end subroutine makesym
end interface
real(kind=8),intent(in)::density(:),meanth(:),quadpoint(:,:)
real(kind=8)::mcovth(size(meanth),size(meanth))
!	Count columns, quadrature points, and rows.
integer::col,quad,row
mcovth=0.0_8
if(size(density)>1)then
    do row=1,size(meanth)
        do col=1,row
            do quad=1,size(density)
                mcovth(row,col)=mcovth(row,col)+(quadpoint(row,quad)-meanth(row))*&
                    (quadpoint(col,quad)-meanth(col))*density(quad)
            end do
        end do
    end do
    call makesym(mcovth)
end if

return
end function mcovth


FUNCTION IMF(mass)

  !define IMFs (dn/dM)

  !the following is just a fast-and-loose way to pass things around:
  !if the imf_type var is +10 then we calculate dn/dm*m
  !if the imf_type var is <10 then we calculate dn/dm

  USE sps_vars
  IMPLICIT NONE

  REAL(SP), DIMENSION(:), INTENT(in) :: mass
  REAL(SP), DIMENSION(SIZE(mass)) :: imf
  INTEGER :: i,n
  REAL(SP) :: imfcu

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

  imf = 0.0

  !Salpeter (1955) IMF
  IF (MOD(imf_type,10).EQ.0) THEN
     imf = mass**(-salp_ind)
     IF (imf_type.EQ.10) imf = mass*imf
  ENDIF

  !Chabrier (2003) IMF
  IF (MOD(imf_type,10).EQ.1) THEN
     DO i=1,size(mass)
        IF (mass(i).LT.1) THEN
           imf(i) = exp(-(log10(mass(i))-log10(chab_mc))**2&
                /2/chab_sigma2)
        ELSE
           imf(i) = exp(-log10(chab_mc)**2/2./chab_sigma2)*&
                mass(i)**(-chab_ind)
        ENDIF
     ENDDO
     !convert from dn/dlnM to dn/dM
     imf = imf/mass
     IF (imf_type.EQ.11) imf = mass*imf
  ENDIF

  !Kroupa (2001) IMF
  IF (MOD(imf_type,10).EQ.2) THEN
     DO i=1,size(mass)
        IF (mass(i).GE.0.08.AND.mass(i).LT.0.5) &
             imf(i) = mass(i)**(-imf_alpha(1))
        IF (mass(i).GE.0.5.AND.mass(i).LT.1.0) &
             imf(i) = 0.5**(-imf_alpha(1)+imf_alpha(2))*&
             mass(i)**(-imf_alpha(2))
        IF (mass(i).GE.1.0) &
             imf(i) = 0.5**(-imf_alpha(1)+imf_alpha(2))*&
             mass(i)**(-imf_alpha(3))
     ENDDO
     IF (imf_type.EQ.12) imf = mass*imf
  ENDIF

  !van Dokkum (2008) IMF
  IF (MOD(imf_type,10).EQ.3) THEN
     DO i=1,size(mass)
        IF (mass(i).LE.vd_nc*imf_vdmc) THEN
           imf(i) = vd_al*(0.5*vd_nc*imf_vdmc)**(-vd_ind)*&
                exp(-(log10(mass(i))-log10(imf_vdmc))*&
                (log10(mass(i))-log10(imf_vdmc))/2./vd_sigma2)
        ELSE
           imf(i) = vd_ah*mass(i)**(-vd_ind)
        ENDIF
     ENDDO
     !convert from dn/dlnM to dn/dM
     imf = imf/mass
     IF (imf_type.EQ.13) imf = mass*imf
  ENDIF

  !Dave (2008) IMF
  IF (MOD(imf_type,10).EQ.4) THEN
     DO i=1,size(mass)
        IF (mass(i).GE.0.08.AND.mass(i).LT.imf_mdave) &
             imf(i) = mass(i)**(-imf_alpha(1))
        IF (mass(i).GE.imf_mdave) &
             imf(i) = imf_mdave**(-imf_alpha(1)+imf_alpha(2))*&
             mass(i)**(-imf_alpha(2))
     ENDDO
     IF (imf_type.EQ.14) imf = mass*imf
  ENDIF

  !user-defined IMF
  IF (MOD(imf_type,10).EQ.5) THEN
     DO i=1,size(mass)
        IF (mass(i).GE.imf_user_alpha(1,1).AND.&
                mass(i).LT.imf_user_alpha(2,1)) &
                imf(i) = mass(i)**(-imf_user_alpha(3,1))
        imfcu = 1.0
        DO n=2,n_user_imf
           IF (mass(i).GE.imf_user_alpha(1,n).AND.&
                mass(i).LT.imf_user_alpha(2,n)) &
                imf(i) = mass(i)**(-imf_user_alpha(3,n))*&
                imf_user_alpha(1,n)**(-imf_user_alpha(3,n-1)+&
                imf_user_alpha(3,n))*imfcu
           imfcu = imfcu*imf_user_alpha(1,n)**(-imf_user_alpha(3,n-1)+&
                imf_user_alpha(3,n))
        ENDDO
     ENDDO
     IF (imf_type.EQ.15) imf = mass*imf
  ENDIF

END FUNCTION IMF


      SUBROUTINE SB03QY( JOB, TRANA, LYAPUN, N, T, LDT, U, LDU, X, LDX,
     $                   SEP, THNORM, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To estimate the separation between the matrices op(A) and -op(A)',
C
C     sep(op(A),-op(A)') = min norm(op(A)'*X + X*op(A))/norm(X)
C                        = 1 / norm(inv(Omega))
C
C     and/or the 1-norm of Theta, where op(A) = A or A' (A**T), and
C     Omega and Theta are linear operators associated to the real
C     continuous-time Lyapunov matrix equation
C
C            op(A)'*X + X*op(A) = C,
C
C     defined by
C
C     Omega(W) = op(A)'*W + W*op(A),
C     Theta(W) = inv(Omega(op(W)'*X + X*op(W))).
C
C     The 1-norm condition estimators are used.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     JOB     CHARACTER*1
C             Specifies the computation to be performed, as follows:
C             = 'S':  Compute the separation only;
C             = 'T':  Compute the norm of Theta only;
C             = 'B':  Compute both the separation and the norm of Theta.
C
C     TRANA   CHARACTER*1
C             Specifies the form of op(A) to be used, as follows:
C             = 'N':  op(A) = A    (No transpose);
C             = 'T':  op(A) = A**T (Transpose);
C             = 'C':  op(A) = A**T (Conjugate transpose = Transpose).
C
C     LYAPUN  CHARACTER*1
C             Specifies whether or not the original Lyapunov equations
C             should be solved, as follows:
C             = 'O':  Solve the original Lyapunov equations, updating
C                     the right-hand sides and solutions with the
C                     matrix U, e.g., X <-- U'*X*U;
C             = 'R':  Solve reduced Lyapunov equations only, without
C                     updating the right-hand sides and solutions.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A and X.  N >= 0.
C
C     T       (input) DOUBLE PRECISION array, dimension (LDT,N)
C             The leading N-by-N upper Hessenberg part of this array
C             must contain the upper quasi-triangular matrix T in Schur
C             canonical form from a Schur factorization of A.
C
C     LDT     INTEGER
C             The leading dimension of array T.  LDT >= MAX(1,N).
C
C     U       (input) DOUBLE PRECISION array, dimension (LDU,N)
C             The leading N-by-N part of this array must contain the
C             orthogonal matrix U from a real Schur factorization of A.
C             If LYAPUN = 'R', the array U is not referenced.
C
C     LDU     INTEGER
C             The leading dimension of array U.
C             LDU >= 1,        if LYAPUN = 'R';
C             LDU >= MAX(1,N), if LYAPUN = 'O'.
C
C     X       (input) DOUBLE PRECISION array, dimension (LDX,N)
C             The leading N-by-N part of this array must contain the
C             solution matrix X of the Lyapunov equation (reduced
C             Lyapunov equation if LYAPUN = 'R').
C             If JOB = 'S', the array X is not referenced.
C
C     LDX     INTEGER
C             The leading dimension of array X.
C             LDX >= 1,        if JOB = 'S';
C             LDX >= MAX(1,N), if JOB = 'T' or 'B'.
C
C     SEP     (output) DOUBLE PRECISION
C             If JOB = 'S' or JOB = 'B', and INFO >= 0, SEP contains the
C             estimated separation of the matrices op(A) and -op(A)'.
C             If JOB = 'T' or N = 0, SEP is not referenced.
C
C     THNORM  (output) DOUBLE PRECISION
C             If JOB = 'T' or JOB = 'B', and INFO >= 0, THNORM contains
C             the estimated 1-norm of operator Theta.
C             If JOB = 'S' or N = 0, THNORM is not referenced.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N*N)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The length of the array DWORK.  LDWORK >= 2*N*N.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = N+1:  if the matrices T and -T' have common or very
C                   close eigenvalues; perturbed values were used to
C                   solve Lyapunov equations (but the matrix T is
C                   unchanged).
C
C     METHOD
C
C     SEP is defined as the separation of op(A) and -op(A)':
C
C            sep( op(A), -op(A)' ) = sigma_min( K )
C
C     where sigma_min(K) is the smallest singular value of the
C     N*N-by-N*N matrix
C
C        K = kprod( I(N), op(A)' ) + kprod( op(A)', I(N) ).
C
C     I(N) is an N-by-N identity matrix, and kprod denotes the Kronecker
C     product. The routine estimates sigma_min(K) by the reciprocal of
C     an estimate of the 1-norm of inverse(K), computed as suggested in
C     [1]. This involves the solution of several continuous-time
C     Lyapunov equations, either direct or transposed. The true
C     reciprocal 1-norm of inverse(K) cannot differ from sigma_min(K) by
C     more than a factor of N.
C     The 1-norm of Theta is estimated similarly.
C
C     REFERENCES
C
C     [1] Higham, N.J.
C         FORTRAN codes for estimating the one-norm of a real or
C         complex matrix, with applications to condition estimation.
C         ACM Trans. Math. Softw., 14, pp. 381-396, 1988.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C
C     FURTHER COMMENTS
C
C     When SEP is zero, the routine returns immediately, with THNORM
C     (if requested) not set. In this case, the equation is singular.
C     The option LYAPUN = 'R' may occasionally produce slightly worse
C     or better estimates, and it is much faster than the option 'O'.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Romania,
C     Oct. 1998. Partly based on DGLSVX (and then SB03QD) by P. Petkov,
C     Tech. University of Sofia, March 1998 (and December 1998).
C
C     REVISIONS
C
C     February 13, 1999, V. Sima, Katholieke Univ. Leuven, Belgium.
C     V. Sima, Research Institute for Informatics, Bucharest, Oct. 2004,
C     May 2020.
C
C     KEYWORDS
C
C     Lyapunov equation, orthogonal transformation, real Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, HALF
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0 )
C     ..
C     .. Scalar Arguments ..
      CHARACTER          JOB, LYAPUN, TRANA
      INTEGER            INFO, LDT, LDU, LDWORK, LDX, N
      DOUBLE PRECISION   SEP, THNORM
C     ..
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   DWORK( * ), T( LDT, * ), U( LDU, * ),
     $                   X( LDX, * )
C     ..
C     .. Local Scalars ..
      LOGICAL            NOTRNA, UPDATE, WANTS, WANTT
      CHARACTER          TRANAT, UPLO
      INTEGER            INFO2, ITMP, KASE, NN
      DOUBLE PRECISION   BIGNUM, EST, SCALE
C     ..
C     .. Local Arrays ..
      INTEGER            ISAVE( 3 )
C     ..
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANSY
      EXTERNAL           DLAMCH, DLANSY, LSAME
C     ..
C     .. External Subroutines ..
      EXTERNAL           DLACN2, DLACPY, DSCAL, DSYR2K, MA02ED, MB01RU,
     $                   SB03MY, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     ..
C     .. Executable Statements ..
C
C     Decode and Test input parameters.
C
      WANTS  = LSAME( JOB,    'S' )
      WANTT  = LSAME( JOB,    'T' )
      NOTRNA = LSAME( TRANA,  'N' )
      UPDATE = LSAME( LYAPUN, 'O' )
C
      NN   = N*N
      INFO = 0
      IF( .NOT. ( WANTS .OR. WANTT .OR. LSAME( JOB, 'B' ) ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( NOTRNA .OR. LSAME( TRANA, 'T' ) .OR.
     $                            LSAME( TRANA, 'C' ) ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( UPDATE .OR. LSAME( LYAPUN, 'R' ) ) ) THEN
         INFO = -3
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDT.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDU.LT.1 .OR. ( UPDATE .AND. LDU.LT.N ) ) THEN
         INFO = -8
      ELSE IF( LDX.LT.1 .OR. ( .NOT.WANTS .AND. LDX.LT.N ) ) THEN
         INFO = -10
      ELSE IF( LDWORK.LT.2*NN ) THEN
         INFO = -15
      END IF
C
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB03QY', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 )
     $   RETURN
C
      ITMP = NN + 1
C
      IF( NOTRNA ) THEN
         TRANAT = 'T'
      ELSE
         TRANAT = 'N'
      END IF
C
      IF( .NOT.WANTT ) THEN
C
C        Estimate sep(op(A),-op(A)').
C        Workspace:  2*N*N.
C
         KASE = 0
C
C        REPEAT
   10    CONTINUE
         CALL DLACN2( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE, ISAVE
     $              )
         IF( KASE.NE.0 ) THEN
C
C           Select the triangular part of symmetric matrix to be used.
C
            IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) )
     $          .GE.
     $          DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) )
     $        ) THEN
               UPLO = 'U'
            ELSE
               UPLO = 'L'
            END IF
C
            IF( UPDATE ) THEN
C
C              Transform the right-hand side: RHS := U'*RHS*U.
C
               CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, DWORK,
     $                      N, U, LDU, DWORK, N, DWORK( ITMP ), NN,
     $                      INFO2 )
               CALL DSCAL( N, HALF, DWORK, N+1 )
            END IF
            CALL MA02ED( UPLO, N, DWORK, N )
C
            IF( KASE.EQ.1 ) THEN
C
C              Solve op(T)'*Y + Y*op(T) = scale*RHS.
C
               CALL SB03MY( TRANA, N, T, LDT, DWORK, N, SCALE, INFO2 )
            ELSE
C
C              Solve op(T)*W + W*op(T)' = scale*RHS.
C
               CALL SB03MY( TRANAT, N, T, LDT, DWORK, N, SCALE, INFO2 )
            END IF
C
            IF( INFO2.GT.0 )
     $         INFO = N + 1
C
            IF( UPDATE ) THEN
C
C              Transform back to obtain the solution: Z := U*Z*U', with
C              Z = Y or Z = W.
C
               CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE,
     $                      DWORK, N, U, LDU, DWORK, N, DWORK( ITMP ),
     $                      NN, INFO2 )
               CALL DSCAL( N, HALF, DWORK, N+1 )
C
C              Fill in the remaining triangle of the symmetric matrix.
C
               CALL MA02ED( UPLO, N, DWORK, N )
            END IF
C
            GO TO 10
         END IF
C        UNTIL KASE = 0
C
         IF( EST.GT.SCALE ) THEN
            SEP = SCALE / EST
         ELSE
            BIGNUM = ONE / DLAMCH( 'Safe minimum' )
            IF( SCALE.LT.EST*BIGNUM ) THEN
               SEP = SCALE / EST
            ELSE
               SEP = BIGNUM
            END IF
         END IF
C
C        Return if the equation is singular.
C
         IF( SEP.EQ.ZERO )
     $      RETURN
      END IF
C
      IF( .NOT.WANTS ) THEN
C
C        Estimate norm(Theta).
C        Workspace:  2*N*N.
C
         KASE = 0
C
C        REPEAT
   20    CONTINUE
         CALL DLACN2( NN, DWORK( ITMP ), DWORK, IWORK, EST, KASE, ISAVE
     $              )
         IF( KASE.NE.0 ) THEN
C
C           Select the triangular part of symmetric matrix to be used.
C
            IF( DLANSY( '1-norm', 'Upper', N, DWORK, N, DWORK( ITMP ) )
     $          .GE.
     $          DLANSY( '1-norm', 'Lower', N, DWORK, N, DWORK( ITMP ) )
     $        ) THEN
               UPLO = 'U'
            ELSE
               UPLO = 'L'
            END IF
C
C           Fill in the remaining triangle of the symmetric matrix.
C
            CALL MA02ED( UPLO, N, DWORK, N )
C
C           Compute RHS = op(W)'*X + X*op(W).
C
            CALL DSYR2K( UPLO, TRANAT, N, N, ONE, DWORK, N, X, LDX,
     $                   ZERO, DWORK( ITMP ), N )
            CALL DLACPY( UPLO, N, N, DWORK( ITMP ), N, DWORK, N )
C
            IF( UPDATE ) THEN
C
C              Transform the right-hand side: RHS := U'*RHS*U.
C
               CALL MB01RU( UPLO, 'Transpose', N, N, ZERO, ONE, DWORK,
     $                      N, U, LDU, DWORK, N, DWORK( ITMP ), NN,
     $                      INFO2 )
               CALL DSCAL( N, HALF, DWORK, N+1 )
            END IF
            CALL MA02ED( UPLO, N, DWORK, N )
C
            IF( KASE.EQ.1 ) THEN
C
C              Solve op(T)'*Y + Y*op(T) = scale*RHS.
C
               CALL SB03MY( TRANA, N, T, LDT, DWORK, N, SCALE, INFO2 )
            ELSE
C
C              Solve op(T)*W + W*op(T)' = scale*RHS.
C
               CALL SB03MY( TRANAT, N, T, LDT, DWORK, N, SCALE, INFO2 )
            END IF
C
            IF( INFO2.GT.0 )
     $         INFO = N + 1
C
            IF( UPDATE ) THEN
C
C              Transform back to obtain the solution: Z := U*Z*U', with
C              Z = Y or Z = W.
C
               CALL MB01RU( UPLO, 'No transpose', N, N, ZERO, ONE,
     $                      DWORK, N, U, LDU, DWORK, N, DWORK( ITMP ),
     $                      NN, INFO2 )
               CALL DSCAL( N, HALF, DWORK, N+1 )
C
C              Fill in the remaining triangle of the symmetric matrix.
C
               CALL MA02ED( UPLO, N, DWORK, N )
            END IF
C
            GO TO 20
         END IF
C        UNTIL KASE = 0
C
         IF( EST.LT.SCALE ) THEN
            THNORM = EST / SCALE
         ELSE
            BIGNUM = ONE / DLAMCH( 'Safe minimum' )
            IF( EST.LT.SCALE*BIGNUM ) THEN
               THNORM = EST / SCALE
            ELSE
               THNORM = BIGNUM
            END IF
         END IF
      END IF
C
      RETURN
C *** Last line of SB03QY ***
      END


FUNCTION REXPU() RESULT(fn_val)
!
!     Random-number generator for the exponential distribution
!     Algorithm EA from J. H. Ahrens and U. Dieter,
!     Communications of the ACM, 31 (1988) 1330--1337.
!     Coded by K. G. Hamilton, December 1996, with corrections.
!

IMPLICIT NONE
REAL :: fn_val

REAL, PARAMETER :: alog2 = 0.6931471805599453,  a =  5.7133631526454228,  &
                       b = 3.4142135623730950,  c = -1.6734053240284925,  &
                       p = 0.9802581434685472, aa =  5.6005707569738080,  &
                      bb = 3.3468106480569850, hh =  0.0026106723602095,  &
                      dd = 0.0857864376269050
REAL :: g, u, up, y
!
!       Comment out the following lines if your RNG can never return 0.0
DO
  call random_number(u)
  if (u > 0.0) EXIT               ! Zero-protector
END DO

g = c
DO
  u = u + u
  if (u >= 1.0) EXIT
  g = g + alog2
END DO

u = u - 1.0
if (u <= p) THEN
  fn_val = g + aa/(bb-u)
  return
END IF
DO
  call random_number(u)
  y = a/(b-u)
  call random_number(up)
  if ((up*hh + dd)*(b-u)**2 <= exp(-(y+c))) EXIT
END DO

fn_val = g + y

return
end FUNCTION REXPU

FUNCTION REXPS() RESULT(fn_val)
!
!     Random-number generator for the exponential distribution
!     Algorithm EA from J. H. Ahrens and U. Dieter,
!     Communications of the ACM, 31 (1988) 1330--1337.
!     Coded by K. G. Hamilton, December 1996, with corrections.
!
IMPLICIT NONE
REAL :: fn_val

REAL, PARAMETER :: alog2 = 0.6931471805599453,  a =  5.7133631526454228,  &
                       b = 3.4142135623730950,  c = -1.6734053240284925,  &
                       p = 0.9802581434685472, aa =  5.6005707569738080,  &
                      bb = 3.3468106480569850, hh =  0.0026106723602095,  &
                      dd = 0.0857864376269050
REAL :: g, u, up, y
!
!       Comment out the following lines if your RNG can never return 0.0
DO
  call random_number(u)
  if (u > 0.0) EXIT               ! Zero-protector
END DO

g = c
u = u + u
do while (u < 1.0)
   g = g + alog2
   u = u + u
end do
u = u - 1.0
if (u <= p) then
  fn_val = g + aa/(bb-u)
  return
end if

do
  call random_number(u)
  y = a/(b-u)
  call random_number(up)
  if ((up*hh + dd)*(b-u)**2 <= exp(-(y+c))) then
    fn_val = g + y
    return
  end if
end do

RETURN
end FUNCTION REXPS


module consts

    ! global constants and variables

    use preci, wp => dp
    implicit none

    real, parameter :: pi = 3.14159265358979323846
    real, parameter :: kb = 1.38064852e-23 ! Boltzmann constant
    real, parameter :: avog = 6.023e23 ! Avogadro constant
    real, parameter :: mw_air = 29.2e-3 ! molecular weight of air

    real, parameter :: mw_par = 79.866e-3 ! molecular weight of the particle material
    real, parameter :: den_par = 4230.0 ! density of the particle material

    real, parameter :: temp = 1200.0 ! temperature
    real, parameter :: visc = 1.716e-5 * ((temp/273.15)**(2.0/3.0)) ! viscosity
    real, parameter :: pres = 101325.0 ! pressure
    real, parameter :: mfp_air = visc/pres * sqrt(pi*kb*temp/(2.0*mw_air/avog)) ! mean free path of air

    real, parameter :: beta_star = 8.0*kb*temp/3.0/visc
    ! ß* for non-dimensionalization (ref: Friedlander 2000, pg192, eqn7.18)
    integer, parameter :: regime = 0 ! regime option - default: Fuchs-Sutugin

    real, parameter :: dp1 = 0.4e-9 ! initial particle monomer diameter
    real, parameter :: n_0_dp1 = 1.0e20 ! initial monomer number concentration #/m3
    integer, parameter :: N_ds = 3000 ! ____number of concerned discrete sizes

    real, parameter :: tau = 2.0/beta_star/n_0_dp1 ! default value = 2.0837e-5
    ! t* for non-dimensionalization, ß* instead of K !! (ref: Friedlander 2000, pg194, eqn7.24)

    ! total time is set according to table 1.1 (ref: Friedlander 2000, pg8)
    ! n_0_dp1*t_1_10 = 1.2e16
    ! if (n_0_dp1 == 1.0e20) {
    !     t_1_10 = 1.2e16/n_0_dp1 ! = 1.2e-4
    ! }

    real, parameter :: n_star_min = 1.0/n_0_dp1 ! pyhsically miminimum total number concentration, 1 #/m3, i.e. 1e-20 after non-dimensionalization

end module consts


!
! Example illustrating the use of the frand123 Fortran interface for the
! generation of double precision normally distributed random numbers.
! The example estimates the excess kurtosis of the underlying normal
! distribution with expectation mu = 0.7 and variance sigma = 1.6
!

program kurtosisDouble
   use, intrinsic :: iso_c_binding, only: c_double
   use omp_lib, only: omp_get_wtime
   use frand123, only: frand123State_t, frand123Init, frand123NormDouble
   implicit none

   ! integer kind for large integers
   integer, parameter :: ik = selected_int_kind( 10 )

   ! number of draws used to estimate the excess kurtosis
   integer( kind = ik ), parameter :: numberOfSamples = 1000 * 1000 * 100

   ! expectation and variance of the normal distribution to draw from
   real( kind = c_double ), parameter :: mu = real( 0.7, c_double )
   real( kind = c_double ), parameter :: sigma = real( 1.6, c_double )

   ! state for frand123
   type( frand123State_t ) :: state

   ! timing variables
   real( kind = c_double ) :: startTime, endTime

   ! result variables
   real( kind = c_double ) :: varScalar, varTwo, var1000

   ! initialize state
   call frand123Init( state, 0, 0 )

   ! use excessKurtosisScalar
   startTime = omp_get_wtime()
   varScalar = excessKurtosisScalar( state )
   endTime = omp_get_wtime()
   write(*, '( "Result generating  one random number at a time: ", ES11.4, &
          & " took ", ES11.4, " seconds" )' ) varScalar, endTime - startTime

   ! use excessKurtosisTwo
   startTime = omp_get_wtime()
   varTwo = excessKurtosisTwo( state )
   endTime = omp_get_wtime()
   write(*, '( "Result generating  two random number at a time: ", ES11.4, &
          & " took ", ES11.4, " seconds" )' ) varTwo, endTime - startTime

   ! use excessKurtosis1000
   startTime = omp_get_wtime()
   var1000 = excessKurtosis1000( state )
   endTime = omp_get_wtime()
   write(*, '( "Result generating 1000 random number at a time: ", ES11.4, &
          & " took ", ES11.4, " seconds" )' ) var1000, endTime - startTime

contains

   ! estimate excess kurtosis by drawing a single double precision sample at a
   ! time
   real( kind = c_double ) function excessKurtosisScalar( state )
      implicit none
      type( frand123State_t ), intent( inout ) :: state

      ! local variables
      real( kind = c_double ) :: excessKurtosis
      real( kind = c_double ) :: draw
      integer( kind = ik ) :: i

      ! iterate over samples
      excessKurtosis = real( 0, c_double )
      do i = 1, numberOfSamples
         ! draw random number
         call frand123NormDouble( state, mu, sigma, draw )
         ! centralize
         draw = draw - mu
         ! sum up contributions
         excessKurtosis = excessKurtosis + draw ** 4
      enddo
      ! apply remaining operations
      excessKurtosisScalar = excessKurtosis / &
          ( real( numberOfSamples, c_double) * sigma ** 4 ) - real( 3., c_double )
   end function excessKurtosisScalar

   ! estimate excess kurtosis by drawing two double precision sample at a time
   real( kind = c_double ) function excessKurtosisTwo( state )
      implicit none
      type( frand123State_t ), intent( inout ) :: state

      ! local variables
      real( kind = c_double ) :: excessKurtosis
      real( kind = c_double ), dimension( 2 ) :: draw
      integer( kind = ik ) :: i

      ! iterate over samples
      excessKurtosis = real( 0, c_double )
      do i = 1, numberOfSamples, 2
         ! draw random number
         call frand123NormDouble( state, mu, sigma, draw )
         ! centralize
         draw = draw - mu
         ! sum up contributions
         excessKurtosis = excessKurtosis + sum( draw ** 4 )
      enddo
      ! apply remaining operations
      excessKurtosisTwo = excessKurtosis / &
          ( real( numberOfSamples, c_double) * sigma ** 4 ) - real( 3., c_double )
   end function excessKurtosisTwo

   ! estimate excess kurtosis by drawing 1000 double precision sample at a time
   real( kind = c_double ) function excessKurtosis1000( state )
      implicit none
      type( frand123State_t ), intent( inout ) :: state

      ! local variables
      real( kind = c_double ) :: excessKurtosis
      real( kind = c_double ), dimension( 1000 ) :: draw
      integer( kind = ik ) :: i

      ! iterate over samples
      excessKurtosis = real( 0, c_double )
      do i = 1, numberOfSamples, 1000
         ! draw random number
         call frand123NormDouble( state, mu, sigma, draw )
         ! centralize
         draw = draw - mu
         ! sum up contributions
         excessKurtosis = excessKurtosis + sum( draw ** 4 )
      enddo
      ! apply remaining operations
      excessKurtosis1000 = excessKurtosis / &
          ( real( numberOfSamples, c_double) * sigma ** 4 ) - real( 3., c_double )
   end function excessKurtosis1000
end program kurtosisDouble


subroutine delta_initialize_re(x,y,ny,nsd,adist,snvolume,maxconn,rksh,ninf,inf)
!===========================================
real(8) x(nsd) ! point to be interpolated (RKPM center)
real(8) y(nsd,ny) ! possible surrounding nodes (back round mesh)
integer ny ! number of surrounding nodes
real(8) adist(nsd,ny)
integer nsd ! nsd
real(8) snvolume(ny)
integer maxconn ! max nodes in the support region
real(8) rksh(maxconn) ! rkpm coefficient for point x
integer ninf
integer inf(maxconn) ! node index in support region
!===========================================
real(8) y_tmp(nsd)
real(8) a(nsd)

rksh(:)=0.0d0

ninf=0
inf(:)=0

call getinf_re(inf,ninf,x,y,adist,ny,nsd,maxconn)

if (nsd == 2 ) then
		call correct2d(b,bd,x,y,adist,snvolume,1,inf,ninf,maxconn)
	elseif (nsd ==3 ) then
		call correct3d(b,bd,x,y,adist,snvolume,1,inf,ninf,maxconn)
end if

do n=1,ninf
	nnum=inf(n)
	do isd=1,nsd
		y_tmp(isd)=y(isd,nnum)
		a(isd)=adist(isd,nnum)
	end do
		if (nsd ==2) then
		call RKPMshape2d(shp,b,bd,x,y_tmp,a,snvolume(nnum))
		elseif (nsd ==3) then
		call RKPMshape2d(shp,b,bd,x,y_tmp,a,snvolume(nnum))
		end if
	rksh(n)=shp
end do
return

end subroutine


module stats_mod
implicit none
private
public :: mean
interface mean
   module procedure mean_int, mean_real
end interface mean
contains
pure function mean_int(vec) result(avg)
integer, intent(in) :: vec(:)
real                :: avg
avg = real(sum(vec))/(max(1,size(vec)))
! handles the case of size(vec) = 0
end function mean_int
!
pure function mean_real(vec) result(avg)
real, intent(in)    :: vec(:)
real                :: avg
avg = sum(vec)/(max(1,size(vec)))
end function mean_real
!
end module stats_mod
!
program test_stats
use stats_mod ! import mean, the only PUBLIC entity
implicit none
print*,mean([4,7]),mean([4.0,7.0])
! line below invalid because mean_int PRIVATE
! print*,mean_int([4,7])
end program test_stats


module loglikelihood_module
    use utils_module, only: dp

    contains

    !> Pyramidal likelihood centered on 0.5.
    !!
    !! This is effectively a gaussian loglikelihood with an L_\infty norm
    !!
    !! It is normalised so that it should output an evidence of 1.0 for
    !! effectively infinite priors.
    !!
    !! Note that there is a dimensional component to the argument of the exponential function
    !!
    !! This is chosen so as to ensure that the entropy H(N) ~ O(N)
    !!
    function loglikelihood(theta,phi)
        use utils_module, only: loggamma
        implicit none
        !> Input parameters
        real(dp), intent(in), dimension(:)   :: theta
        !> Output derived parameters
        real(dp), intent(out),  dimension(:) :: phi

        integer,save :: nDims=0
        real(dp), save :: factor=1d0

        real(dp) :: loglikelihood

        real(dp), dimension(size(theta)) :: sigma ! Standard deviation (uncorrelated)
        real(dp), dimension(size(theta)) :: mu    ! Mean

        real(dp), parameter :: logSqrtTwoPi = log(sqrt(8d0*atan(1d0)))
        real(dp), parameter :: PiOverTwo = 2d0*atan(1d0)

        mu= 5d-1   ! mean in the center
        sigma = 1d-1
        if(size(theta)/=nDims) then
            nDims = size(theta)
            factor = exp(-2d0/nDims * loggamma(1d0 + nDims/2d0)) * PiOverTwo
        end if

        ! normalisation
        loglikelihood =   - sum(logSqrtTwoPi+log(sigma))

        ! theta dependence
        loglikelihood = loglikelihood - maxval(abs(theta-mu)/sigma)**2  / factor

    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


	SUBROUTINE SNSINS ( x1, x2, yl1, yl2, ys1, ys2, xint,
     +				yint, iret )
C************************************************************************
C* SNSINS								*
C*									*
C* This subroutine computes the intersection point for an isentrope	*
C* with the surface.							*
C*									*
C* SNSINS ( X1, X2, YL1, YL2, YS1, YS2, XINT, YINT, IRET )		*
C*									*
C* Input parameters:							*
C*	X1		REAL		First x coordinate		*
C*	X2		REAL		Second x coordinate		*
C*	YL1		REAL		Value of line at x1		*
C*	YL2		REAL		Value of line at x2		*
C*	YS1		REAL		Value of surface at x1		*
C*	YS2		REAL		Value of surface at x2		*
C*									*
C* Output parameters:							*
C*	XINT		REAL		X coordinate at intersection	*
C*	YINT		REAL		Y coordinate at intersection	*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C**									*
C* Log:									*
C* M. desJardins/GSFC	12/85						*
C************************************************************************
C------------------------------------------------------------------------
	iret = 0
C
C*	Compute logarithms of the y points.  The lines are assumed to
C*	intersect in LOG-P, X space.
C
	yyl1 = ALOG ( yl1 )
	yyl2 = ALOG ( yl2 )
	yys1 = ALOG ( ys1 )
	yys2 = ALOG ( ys2 )
C
C*	Find slope and y-intercept of line.
C
	al = ( yyl1 - yyl2 ) / ( x1 - x2 )
	bl =   yyl1 - al * x1
C
C*	Find slope and y-intercept of surface.
C
	as = ( yys1 - yys2 ) / ( x1 - x2 )
	bs =   yys1 - as * x1
C
C*	Find the x and y coordinate of the intersection point.
C
	xint = ( bs - bl ) / ( al - as )
	yint =   al * xint + bl
	yint =   EXP ( yint )
C*
	RETURN
	END


program factorial
   implicit none

   ! define variables
   integer :: nfact = 1
   integer :: n = 1

   ! compute factorials
   do while (n <= 10)
      nfact = nfact*n
      n = n + 1
      print *, n, " ", nfact
   end do
end program factorial


       SUBROUTINE W3FS26(JLDAYN,IYEAR,MONTH,IDAY,IDAYWK,IDAYYR)
C$$$   SUBPROGRAM  DOCUMENTATION  BLOCK
C
C SUBPROGRAM: W3FS26         YEAR, MONTH, DAY FROM JULIAN DAY NUMBER
C   AUTHOR: JONES,R.E.       ORG: W342       DATE: 87-03-29
C
C ABSTRACT: COMPUTES YEAR (4 DIGITS), MONTH, DAY, DAY OF WEEK, DAY
C   OF YEAR FROM JULIAN DAY NUMBER. THIS SUBROUTINE WILL WORK
C   FROM 1583 A.D. TO 3300 A.D.
C
C PROGRAM HISTORY LOG:
C   87-03-29  R.E.JONES
C   89-10-25  R.E.JONES   CONVERT TO CRAY CFT77 FORTRAN
C
C USAGE:  CALL W3FS26(JLDAYN,IYEAR,MONTH,IDAY,IDAYWK,IDAYYR)
C
C   INPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     JLDAYN ARG LIST  INTEGER   JULIAN DAY NUMBER
C
C   OUTPUT VARIABLES:
C     NAMES  INTERFACE DESCRIPTION OF VARIABLES AND TYPES
C     ------ --------- -----------------------------------------------
C     IYEAR  ARG LIST  INTEGER   YEAR  (4 DIGITS)
C     MONTH  ARG LIST  INTEGER   MONTH
C     IDAY   ARG LIST  INTEGER   DAY
C     IDAYWK ARG LIST  INTEGER   DAY OF WEEK (1 IS SUNDAY, 7 IS SAT)
C     IDAYYR ARG LIST  INTEGER   DAY OF YEAR (1 TO 366)
C
C   REMARKS: A JULIAN DAY NUMBER CAN BE COMPUTED BY USING ONE OF THE
C     FOLLOWING STATEMENT FUNCTIONS. A DAY OF WEEK CAN BE COMPUTED
C     FROM THE JULIAN DAY NUMBER. A DAY OF YEAR CAN BE COMPUTED FROM
C     A JULIAN DAY NUMBER AND YEAR.
C
C      IYEAR (4 DIGITS)
C
C      JDN(IYEAR,MONTH,IDAY) = IDAY - 32075
C    &            + 1461 * (IYEAR + 4800 + (MONTH - 14) / 12) / 4
C    &            + 367 * (MONTH - 2 - (MONTH -14) / 12 * 12) / 12
C    &            - 3 * ((IYEAR + 4900 + (MONTH - 14) / 12) / 100) / 4
C
C      IYR (4 DIGITS) , IDYR(1-366) DAY OF YEAR
C
C      JULIAN(IYR,IDYR) = -31739 + 1461 * (IYR + 4799) / 4
C    &                    -3 * ((IYR + 4899) / 100) / 4 + IDYR
C
C      DAY OF WEEK FROM JULIAN DAY NUMBER, 1 IS SUNDAY, 7 IS SATURDAY.
C
C      JDAYWK(JLDAYN) = MOD((JLDAYN + 1),7) + 1
C
C      DAY OF YEAR FROM JULIAN DAY NUMBER AND 4 DIGIT YEAR.
C
C      JDAYYR(JLDAYN,IYEAR) = JLDAYN -
C     &  (-31739+1461*(IYEAR+4799)/4-3*((IYEAR+4899)/100)/4)
C
C      THE FIRST FUNCTION WAS IN A LETTER TO THE EDITOR COMMUNICATIONS
C      OF THE ACM  VOLUME 11 / NUMBER 10 / OCTOBER, 1968. THE 2ND
C      FUNCTION WAS DERIVED FROM THE FIRST. THIS SUBROUTINE WAS ALSO
C      INCLUDED IN THE SAME LETTER. JULIAN DAY NUMBER 1 IS
C      JAN 1,4713 B.C. A JULIAN DAY NUMBER CAN BE USED TO REPLACE A
C      DAY OF CENTURY, THIS WILL TAKE CARE OF THE DATE PROBLEM IN
C      THE YEAR 2000, OR REDUCE PROGRAM CHANGES TO ONE LINE CHANGE
C      OF 1900 TO 2000. JULIAN DAY NUMBERS CAN BE USED FOR FINDING
C      RECORD NUMBERS IN AN ARCHIVE OR DAY OF WEEK, OR DAY OF YEAR.
C
C ATTRIBUTES:
C   LANGUAGE: CRAY CFT77 FORTRAN
C   MACHINE:  CRAY Y-MP8/864
C
C$$$
C
       L      = JLDAYN + 68569
       N      = 4 * L / 146097
       L      = L - (146097 * N + 3) / 4
       I      = 4000 * (L + 1) / 1461001
       L      = L - 1461 * I / 4 + 31
       J      = 80 * L / 2447
       IDAY   = L - 2447 * J / 80
       L      = J / 11
       MONTH  = J + 2 - 12 * L
       IYEAR  = 100 * (N - 49) + I + L
       IDAYWK = MOD((JLDAYN + 1),7) + 1
       IDAYYR = JLDAYN -
     &  (-31739 +1461 * (IYEAR+4799) / 4 - 3 * ((IYEAR+4899)/100)/4)
       RETURN
       END


! Sum square difference
!
! By listing the first six prime numbers: 2, 3, 5, 7, 11, and 13, we can see that the 6th prime is 13.
!
! What is the 10 001st prime number?
module Problem7

    implicit none
    private

    public :: solve
contains
    subroutine solve
        write (*, '(A)') 'Problem 7. 10001st prime.'

        write (*, '(A, I)') 'Prime 1: ', prime1()
    end subroutine

    function prime1()
        integer index
        integer count
        integer prime1

        ! initial value
        index = 1
        count = 0

        do while (count < 10001)
            index = index + 1

            if (isPrime(index) == .true.) then
                count = count + 1
            end if
        end do

        prime1 = index
    end function

    function isPrime(number)
        integer number
        integer devider
        logical isPrime

        ! initial value
        isPrime = .true.

        do devider = 2, sqrt(real(number))
            if (mod(number, devider) == 0) then
                isPrime = .false.
                exit
            end if
        end do
    end function
end module


! Filename: unitConversion.f90
! Description: Module of unit conversion utility functions
! Author: Tim Troxler
! Date: 7/17/2015
module unitConversion

    ! Import modules
    use precision
    implicit none

contains

    ! Convert fahrenheit to celsius
    ! c = (f - 32) * 5 / 9
    function celsius(fahrenheit)
        real(kind = qp) :: fahrenheit, celsius
        celsius = (fahrenheit - 32) * 5 / 9
    end function celsius

    ! Convert celsius to fahrenheit
    ! f = (c * 9 / 5) + 32
    function fahrenheit(celsius)
        real(kind = qp) :: fahrenheit, celsius
        fahrenheit = (celsius * 9 / 5) + 32
    end function fahrenheit

end module unitConversion


PROGRAM FRACTAL
    IMPLICIT NONE
    INTEGER X,Y,I,ITER_MAX,XRES,YRES
    REAL XMIN,XMAX,YMIN,YMAX,THRESHOLD
    COMPLEX ZN,C
    PARAMETER (ITER_MAX=255,XMIN=-2,XMAX=1,YMIN=-1,YMAX=1,XRES=90000,YRES=60000,THRESHOLD=4096)
    INTEGER Z_ARRAY(XRES,YRES)
    WRITE(*,*)'Initialize array... '
    Z_ARRAY=ITER_MAX
    WRITE(*,*)'Calculating... '
    !$OMP PARALLEL DEFAULT(PRIVATE) SHARED(Z_ARRAY) NUM_THREADS(20)
    !$OMP DO SCHEDULE(DYNAMIC,1000)
    DO Y=1,YRES
        DO X=1,XRES
            ZN=CMPLX(0,0)
            C=CMPLX(XMIN+(XMAX-XMIN)*X/XRES,YMIN+(YMAX-YMIN)*Y/YRES)
            DO I=0,ITER_MAX
                ZN=(ZN+C)**2 !Mandelbrot
                !ZN=(ABS(REAL(ZN))+CMPLX(0,1)*ABS(AIMAG(ZN)))**2+C !Burning ship
                IF (ABS(ZN)>THRESHOLD)THEN
                    Z_ARRAY(X,Y)=I
                    GOTO 110
                END IF
            END DO
110         CONTINUE
        END DO
    END DO
    !$OMP END DO NOWAIT
    !$OMP END PARALLEL
    WRITE(*,*)'Write file...'
    OPEN(10,file="data.dat",FORM="unformatted",ACCESS='stream')
    WRITE(10)XRES,YRES,Z_ARRAY
    CLOSE(10)
END PROGRAM FRACTAL