subroutine RESCHECK(BANDSWITCH,N,K,NEWTNUM,POLY,COEFFS,ROOTS,ALLROOTS,RESIDUALS)

	implicit none

	integer, intent(in) :: BANDSWITCH,N,K,newtnum
	complex(kind(1d0)), intent(in) :: poly(N),roots(N),coeffs(N,K)
	double precision, intent(inout) :: residuals(N,3*(newtnum+1))
	complex(kind(1d0)), intent(inout) :: allroots(N,newtnum+1)

	if(BANDSWITCH == 0)then

		call COMPRESCHECK(N,newtnum,poly,roots,allroots,residuals)

	else if(BANDSWITCH == 1)then

		call CONGRESCHECK(N,K,NEWTNUM,POLY,COEFFS,ROOTS,ALLROOTS,RESIDUALS)

	else

		write(*,*) "Not a valid argument for BANDSWITCH!"
		return

	end if

end subroutine

! **********************************************
!  August 17, 2012
! **********************************************
!
! This subroutine computes three residuals for each computed root, lambda,
! of a polynomial P(x). It is also capable of applying an arbitrary number
! of Newton iterations to each computed root.
!
! The residuals are |P(lambda)/P'(lambda)|, |P(lambda)/P'(lambda)/lambda|, and
! ||Cv-lambda v||/||C||/||v||, in the inifinity norm where C is the Companion Matrix
! and v is the eigenvectro associated with lambda.
!
! **************************************************************
!
! Input variables:
!
! POLY         complex array of length N, containing the nonleading
!              coefficients of P (ordered with decreasing N). P must be
!	       monic
!
! N            N of polynomial
!
!
! ROOTS        complex array of length N, containing the computed roots
!              of Poly
!
! NEWTNUM      a non-negative integer specifying the number of Newton iterations
!              zero is acceptable.
!
! Output variables:
!
! ALLROOTS     complex array of dimension (N,NEWTNUM+1) contains the original roots
!	       as well as any newton corrections
!
! RESIDUALS    double precision array of dimension (N,3*(NEWTNUM+1)).
!	       each row of RESIDUALS corresponds to one root of POLY.
!	       columns are in sets of three, with the columns 1, 2 and 3 corresponding
!	       to the three residuals mentioned above respectively. Every set of three
!              columns corresponds to a Newton iteration except for the first one.
!
! ***************************************************************

subroutine COMPRESCHECK(N,newtnum,poly,roots,allroots,residuals)

	implicit none

	integer, intent(in) :: N,newtnum
	complex(kind(1d0)), intent(in) :: poly(N),roots(N)
	double precision, intent(inout) :: residuals(N,3*(newtnum+1))
	complex(kind(1d0)), intent(inout) :: allroots(N,newtnum+1)

	integer ii,jj,kk
	double precision :: Cnorm
	complex(kind(1d0)) :: f, fprime, lambda

	! initialize allroots
	allroots = complex(0d0,0d0)
	allroots(:,1) = roots

	! Matrix infinity norms
	Cnorm = 0d0
	do ii=1,N
		Cnorm = Cnorm + abs(poly(ii))
	end do

	Cnorm = dmax1(1d0,Cnorm)

	! Function evaluations and Newton Corrections
	do ii=1,N

		do jj=1,(newtnum+1)
			! Roots inside or on the unit circle
			if(abs(allroots(ii,jj)) <= 1d0)then
				! function evals
				lambda = allroots(ii,jj)
				f = lambda + poly(1)
				fprime = complex(dble(N),0d0)*f - poly(1)
				do kk=2,(N-1)
					f = lambda*f + poly(kk)
					fprime = lambda*fprime + complex(dble(N-kk),0d0)*poly(kk)
				end do
				f = f*lambda + poly(N)

				! Store residuals
				residuals(ii,3*(jj-1)+1) = abs(f/fprime)
				residuals(ii,3*(jj-1)+2) = abs(f/fprime/lambda)
				residuals(ii,3*(jj-1)+3) = abs(f)/Cnorm

				! Newton correction
				if((newtnum+1-jj) > 0)then
					lambda = lambda - f/fprime
					allroots(ii,jj+1) = lambda
				end if
			! Roots outside the unit circle
			else
				! function evals
				lambda = complex(1d0,0d0)/allroots(ii,jj)
				f = poly(N)*lambda + poly(N-1)
				fprime = complex(dble(N),0d0)*f - poly(N-1)
				do kk=2,(N-1)
					f = lambda*f + poly(N-kk)
					fprime = lambda*fprime + complex(dble(N-kk),0d0)*poly(N-kk)
				end do
				f = f*lambda + complex(1d0,0d0)

				! Store residuals
				residuals(ii,3*(jj-1)+1) = abs(f/fprime*lambda*lambda)
				residuals(ii,3*(jj-1)+2) = abs(f/fprime*lambda)
				residuals(ii,3*(jj-1)+3) = abs(f*lambda)/Cnorm

				! Newton correction
				if((newtnum+1-jj) > 0)then
					lambda = lambda - f/fprime
					allroots(ii,jj+1) = complex(1d0,0d0)/lambda
				end if
			end if
		end do
	end do

end subroutine

! **********************************************
!  August 17, 2012
! **********************************************
!
! This subroutine computes three residuals for each computed root, lambda,
! of a polynomial P(x). It is also capable of applying an arbitrary number
! of Newton iterations to each computed root.
!
! The residuals are |P(lambda)/P'(lambda)|, |P(lambda)/P'(lambda)/lambda|, and
! ||Cv-lambda v||/||C||/||v||, in the inifinity norm where C is the Companion Matrix
! and v is the eigenvectro associated with lambda.
!
! **************************************************************
!
! Input variables:
!
! N            degree of polynomial
!
! K            Bandwidth of upper-triangular matrix
!
! POLY         complex array of length N, containing the nonleading
!              coefficients of P (ordered with decreasing N). P must be
!	       monic
!
! COEFFS       complex array of dimension (N,K) containing the recursion
!	       coefficients for the polynomial basis, COEFFS(1,1) must be 1
!
!
! ROOTS        complex array of length N, containing the computed roots
!              of Poly
!
! NEWTNUM      a non-negative integer specifying the number of Newton iterations
!              zero is acceptable.
!
! Output variables:
!
! ALLROOTS     complex array of dimension (N,NEWTNUM+1) contains the original roots
!	       as well as any newton corrections
!
! RESIDUALS    double precision array of dimension (N,3*(NEWTNUM+1)).
!	       each row of RESIDUALS corresponds to one root of POLY.
!	       columns are in sets of three, with the columns 1, 2 and 3 corresponding
!	       to the three residuals mentioned above respectively. Every set of three
!              columns corresponds to a Newton iteration except for the first one.
!
! ***************************************************************

subroutine CONGRESCHECK(N,K,NEWTNUM,POLY,COEFFS,ROOTS,ALLROOTS,RESIDUALS)

	implicit none

	integer, intent(in) :: N,K,newtnum
	complex(kind(1d0)), intent(in) :: poly(N),roots(N),coeffs(N,K)
	double precision, intent(inout) :: residuals(N,3*(newtnum+1))
	complex(kind(1d0)), intent(inout) :: allroots(N,newtnum+1)

	integer ii,jj,kk,ll,length
	double precision :: Cnorm,temp,Pnorm
	complex(kind(1d0)) :: f, fprime, lambda
	complex(kind(1d0)), allocatable :: P(:),Pprime(:)

	! allocate memory
	allocate(P(N+1),Pprime(N+1))

	! initialize residuals
	residuals = 10d0

	! initialize allroots
	allroots = complex(0d0,0d0)
	allroots(:,1) = roots

	! Matrix infinity norm
	P = poly
	P(1:(K-1)) = P(1:(K-1))- Coeffs(1,2:K)

	Cnorm = 0d0
	do ii=1,N
		Cnorm = Cnorm + abs(P(ii))
	end do

	do ii=2,N
		temp = 0d0
		length = min(K,N+2-ii)
		do jj=1,length
			temp = temp + abs(Coeffs(ii,jj))
		end do

		if(temp > Cnorm)then
			Cnorm = temp
		end if
	end do

	! Function evaluations and Newton Corrections
	do ii=1,N

		do jj=1,(newtnum+1)
			! Roots inside or on the unit circle
			if(abs(allroots(ii,jj)) <= 1d0)then
				! function evals
				lambda = allroots(ii,jj)

				! P_k(lambda)
				P(1) = complex(1d0,0d0)

				if(K == 1)then
					P(2) = lambda/Coeffs(N,1)
				else
					P(2) = (lambda - Coeffs(N,2))/Coeffs(N,1)
				end if

				do kk=1,(N-1)
					if(K == 1)then
						P(kk+2) = lambda*P(kk+1)/Coeffs(N-kk,1)
					else
						P(kk+2) = (lambda - Coeffs(N-kk,2))*P(kk+1)

						length=min(kk,K-2)
						do ll=1,length
							P(kk+2) = P(kk+2) - Coeffs(N-kk,2+ll)*P(kk+1-ll)
						end do

						P(kk+2) = P(kk+2)/Coeffs(N-kk,1)
					end if
				end do

				! P'_k(lambda)
				Pprime(1) = complex(0d0,0d0)

				Pprime(2) = complex(1d0,0d0)/Coeffs(N,1)

				do kk=1,(N-1)
					if(K == 1)then
						Pprime(kk+2) = (lambda*Pprime(kk+1) + P(kk+1))/Coeffs(N-kk,1)
					else
						Pprime(kk+2) = (lambda - Coeffs(N-kk,2))*Pprime(kk+1) + P(kk+1)
						length=min(kk,K-2)
						do ll=1,length
							Pprime(kk+2) = Pprime(kk+2) - Coeffs(N-kk,2+ll)*Pprime(kk+1-ll)
						end do

						Pprime(kk+2) = Pprime(kk+2)/Coeffs(N-kk,1)

					end if
				end do

				! compute vector norm
				Pnorm = abs(P(1))
				do kk=2,N+1
					temp = abs(P(kk))
					if(temp > Pnorm)then
						Pnorm = temp
					end if
				end do

				!P(lambda) and P'(lambda)
				f = P(N+1)
				fprime = Pprime(N+1)
				do kk=1,N
					f = f + poly(kk)*P(N+1-kk)
					fprime = fprime + poly(kk)*Pprime(N+1-kk)
				end do

				! Store residuals
				residuals(ii,3*(jj-1)+1) = abs(f/fprime)
				residuals(ii,3*(jj-1)+2) = abs(f/fprime/lambda)
				residuals(ii,3*(jj-1)+3) = abs(f)/Cnorm/Pnorm

				! Newton correction
				if((newtnum+1-jj) > 0)then
					lambda = lambda - f/fprime
					allroots(ii,jj+1) = lambda
				end if
			! Roots outside the unit circle
			else
				! function evals
				lambda = allroots(ii,jj)

				! P_k(lambda)
				P(1) = complex(1d0,0d0)/lambda
				Pprime(1) = complex(0d0,0d0)

				if(K == 1)then
					P(2) = P(1)/Coeffs(N,1)
					Pprime(2) = complex(1d0,0d0)/Coeffs(N,1)/lambda/lambda
				else
					P(2) = (lambda - Coeffs(N,2))*P(1)/Coeffs(N,1)/lambda
					Pprime(2) = complex(1d0,0d0)/Coeffs(N,1)/lambda/lambda
				end if

				P(1) = P(1)/lambda

				do kk=1,(N-1)
					if(K == 1)then
						P(kk+2) = P(kk+1)/Coeffs(N-kk,1)
						Pprime(kk+2) = (lambda*Pprime(kk+1) + P(kk+1))/Coeffs(N-kk,1)
					else
						P(kk+2) = (lambda - Coeffs(N-kk,2))*P(kk+1)/lambda
						Pprime(kk+2) = (lambda - Coeffs(N-kk,2))*Pprime(kk+1) + P(kk+1)

						length=min(kk,K-2)
						do ll=1,length
							P(kk+2) = P(kk+2) - Coeffs(N-kk,2+ll)*P(kk+1-ll)/lambda
							Pprime(kk+2) = Pprime(kk+2) - Coeffs(N-kk,2+ll)*Pprime(kk+1-ll)
						end do

						P(kk+2) = P(kk+2)/Coeffs(N-kk,1)
						Pprime(kk+2) = Pprime(kk+2)/Coeffs(N-kk,1)

					end if

					P(1:kk+1) = P(1:kk+1)/lambda
					Pprime(2:kk+2) = Pprime(2:kk+2)/lambda

				end do

				! compute vector norm
				Pnorm = abs(P(1))
				do kk=2,N+1
					temp = abs(P(kk))
					if(temp > Pnorm)then
						Pnorm = temp
					end if
				end do

				!P(lambda) and P'(lambda)
				f = P(N+1)
				fprime = Pprime(N+1)

				do kk=1,N
					f = f + poly(kk)*P(N+1-kk)
					fprime = fprime + poly(kk)*Pprime(N+1-kk)
				end do

				! Store residuals
				residuals(ii,3*(jj-1)+1) = abs(f/fprime)
				residuals(ii,3*(jj-1)+2) = abs(f/fprime/lambda)
				residuals(ii,3*(jj-1)+3) = abs(f)/Cnorm/Pnorm

				! Newton correction
				if((newtnum+1-jj) > 0)then
					lambda = lambda - f/fprime
					allroots(ii,jj+1) = lambda
				end if
			end if
		end do
	end do

	! free memory
	deallocate(P,Pprime)

end subroutine


program testRandNormSingle
   use frand123
   use, intrinsic :: iso_c_binding, only: c_float
   implicit none

   integer, parameter :: numRndNbrs = 1000 * 1000 * 100
   real( kind = c_float ), parameter :: mu = 0.d0
   real( kind = c_float ), parameter :: sigma = 1.d0

   type( frand123State_t ) :: state
   integer( kind = c_int64_t ), dimension( 2 ) :: seed
   real( kind = c_float ), dimension(:), allocatable :: res

   integer :: out_unit
   real :: startTime, stopTime

   seed = (/ 0, 0 /)
   call frand123Init( state, 0, 0, seed )

   allocate( res( numRndNbrs ) )

   call cpu_time(startTime)
   call frand123NormSingle( state, mu, sigma, res )
   call cpu_time(stopTime)

   write(*,'("time elapsed: ", e13.6)') stopTime - startTime

   open( newunit = out_unit, file = './tests/rand_norm_single.out', access = 'stream' )
   write( out_unit ) res
   close( out_unit )
end program


module particles_mod
    use, intrinsic :: iso_fortran_env, only : sp => REAL32, dp => REAL64
    use :: random_mod
    implicit none

    private
    type, public :: particles_type
        real(kind=dp), dimension(:), allocatable :: x, y, z, &
                                                    v_x, v_y, v_z, &
                                                    mass
        integer, dimension(:), allocatable :: charge
    end type particles_type
    public :: init_particles, print_particles, delete_particles

contains

    subroutine init_particles(p, N)
        implicit none
        type(particles_type), intent(out) :: p
        integer, intent(in) :: N
        integer :: i
        real(kind=dp) :: r

        allocate(p%x(N))
        allocate(p%y(N))
        allocate(p%z(N))
        allocate(p%v_x(N))
        allocate(p%v_y(N))
        allocate(p%v_z(N))
        allocate(p%mass(N))
        allocate(p%charge(N))

        call random_number(p%x)
        call random_number(p%y)
        call random_number(p%z)
        call random_number(p%v_x)
        call random_number(p%v_y)
        call random_number(p%v_z)
        do i = 1, N
            call random_number(r)
            if (r < 0.5) then
                p%charge(i) = -1
            else
                p%charge(i) = 1
            end if
        end do
    end subroutine init_particles

    subroutine print_particle(p, i)
        implicit none
        type(particles_type), intent(in) :: p
        integer, intent(in) :: i
        character(len=200) :: fmt_str = "(7(E10.3, ','), I2)"

        print fmt_str, p%x(i), p%y(i), p%z(i), &
                       p%v_x(i), p%v_y(i), p%v_z(i), &
                       p%mass(i), p%charge(i)
    end subroutine print_particle

    subroutine print_particles(p)
        implicit none
        type(particles_type), intent(in) :: p
        integer :: i, N

        print "(A, 7(',', A))", 'x', 'y', 'z', 'v_x', 'v_y', 'v_z', &
                                'mass', 'charge'
        N = size(p%x)
        do i = 1, N
            call print_particle(p, i)
        end do
    end subroutine print_particles

    subroutine delete_particles(p)
        implicit none
        type(particles_type), intent(inout) :: p
        integer :: i, N

        deallocate(p%x)
        deallocate(p%y)
        deallocate(p%z)
        deallocate(p%v_x)
        deallocate(p%v_y)
        deallocate(p%v_z)
        deallocate(p%mass)
        deallocate(p%charge)

    end subroutine delete_particles

end module particles_mod


program main

use test, only: test_value
use io, only: stdout

use sort

implicit none

double precision :: array(10), array2(10)
integer :: array_int(10), array2_int(10)
real :: array_real(10), array2_real(10)

array(1)  =  14.060924487405954d0
array(2)  =  21.957872304818064d0
array(3)  =  45.959846554673334d0
array(4)  =  47.141085165458485d0
array(5)  =  0.21841768184381499d0
array(6)  =  70.945978939022865d0
array(7)  =  89.068091092152471d0
array(8)  =  67.407064819599611d0
array(9)  =  10.538482810065107d0
array(10) =  20.280598112373479d0
array2 = array
call quicksort(array2,10)
call test_value(array2(1), 0.21841768184381499d0,'quicksort_dp: array(1)')
call test_value(array2(2), 10.538482810065107d0, 'quicksort_dp: array(2)')
call test_value(array2(3), 14.060924487405954d0, 'quicksort_dp: array(3)')
call test_value(array2(4), 20.280598112373479d0, 'quicksort_dp: array(4)')
call test_value(array2(5), 21.957872304818064d0, 'quicksort_dp: array(5)')
call test_value(array2(6), 45.959846554673334d0, 'quicksort_dp: array(6)')
call test_value(array2(7), 47.141085165458485d0, 'quicksort_dp: array(7)')
call test_value(array2(8), 67.407064819599611d0, 'quicksort_dp: array(8)')
call test_value(array2(9), 70.945978939022865d0, 'quicksort_dp: array(9)')
call test_value(array2(10),89.068091092152471d0, 'quicksort_dp: array(10)')
array2 = array
call heapsort(array2,10)
call test_value(array2(1), 0.21841768184381499d0,'heapsort_dp: array(1)')
call test_value(array2(2), 10.538482810065107d0, 'heapsort_dp: array(2)')
call test_value(array2(3), 14.060924487405954d0, 'heapsort_dp: array(3)')
call test_value(array2(4), 20.280598112373479d0, 'heapsort_dp: array(4)')
call test_value(array2(5), 21.957872304818064d0, 'heapsort_dp: array(5)')
call test_value(array2(6), 45.959846554673334d0, 'heapsort_dp: array(6)')
call test_value(array2(7), 47.141085165458485d0, 'heapsort_dp: array(7)')
call test_value(array2(8), 67.407064819599611d0, 'heapsort_dp: array(8)')
call test_value(array2(9), 70.945978939022865d0, 'heapsort_dp: array(9)')
call test_value(array2(10),89.068091092152471d0, 'heapsort_dp: array(10)')

array_real(1)  =  14.0609245e0
array_real(2)  =  21.9578723e0
array_real(3)  =  45.9598466e0
array_real(4)  =  47.1410852e0
array_real(5)  =  0.218417682e0
array_real(6)  =  70.9459789e0
array_real(7)  =  89.0680911e0
array_real(8)  =  67.4070648e0
array_real(9)  =  10.5384828e0
array_real(10) =  20.2805981e0
array2_real = array_real
call quicksort(array2_real,10)
call test_value(array2_real(1), 0.218417682e0,'quicksort_real: array(1)')
call test_value(array2_real(2), 10.5384828e0, 'quicksort_real: array(2)')
call test_value(array2_real(3), 14.0609245e0, 'quicksort_real: array(3)')
call test_value(array2_real(4), 20.2805981e0, 'quicksort_real: array(4)')
call test_value(array2_real(5), 21.9578723e0, 'quicksort_real: array(5)')
call test_value(array2_real(6), 45.9598466e0, 'quicksort_real: array(6)')
call test_value(array2_real(7), 47.1410852e0, 'quicksort_real: array(7)')
call test_value(array2_real(8), 67.4070648e0, 'quicksort_real: array(8)')
call test_value(array2_real(9), 70.9459789e0, 'quicksort_real: array(9)')
call test_value(array2_real(10),89.0680911e0, 'quicksort_real: array(10)')
array2_real = array_real
call heapsort(array2_real,10)
call test_value(array2_real(1), 0.218417682e0,'heapsort_real: array(1)')
call test_value(array2_real(2), 10.5384828e0, 'heapsort_real: array(2)')
call test_value(array2_real(3), 14.0609245e0, 'heapsort_real: array(3)')
call test_value(array2_real(4), 20.2805981e0, 'heapsort_real: array(4)')
call test_value(array2_real(5), 21.9578723e0, 'heapsort_real: array(5)')
call test_value(array2_real(6), 45.9598466e0, 'heapsort_real: array(6)')
call test_value(array2_real(7), 47.1410852e0, 'heapsort_real: array(7)')
call test_value(array2_real(8), 67.4070648e0, 'heapsort_real: array(8)')
call test_value(array2_real(9), 70.9459789e0, 'heapsort_real: array(9)')
call test_value(array2_real(10),89.0680911e0, 'heapsort_real: array(10)')

array_int(1)  =  14
array_int(2)  =  22
array_int(3)  =  46
array_int(4)  =  47
array_int(5)  =   0
array_int(6)  =  71
array_int(7)  =  89
array_int(8)  =  67
array_int(9)  =  11
array_int(10) =  20
array2_int = array_int
call quicksort(array2_int,10)
call test_value(array2_int(1),  0,'quicksort_int: array(1)')
call test_value(array2_int(2), 11, 'quicksort_int: array(2)')
call test_value(array2_int(3), 14, 'quicksort_int: array(3)')
call test_value(array2_int(4), 20, 'quicksort_int: array(4)')
call test_value(array2_int(5), 22, 'quicksort_int: array(5)')
call test_value(array2_int(6), 46, 'quicksort_int: array(6)')
call test_value(array2_int(7), 47, 'quicksort_int: array(7)')
call test_value(array2_int(8), 67, 'quicksort_int: array(8)')
call test_value(array2_int(9), 71, 'quicksort_int: array(9)')
call test_value(array2_int(10),89, 'quicksort_int: array(10)')
array2_int = array_int
call heapsort(array2_int,10)
call test_value(array2_int(1),  0,'heapsort_int: array(1)')
call test_value(array2_int(2), 11, 'heapsort_int: array(2)')
call test_value(array2_int(3), 14, 'heapsort_int: array(3)')
call test_value(array2_int(4), 20, 'heapsort_int: array(4)')
call test_value(array2_int(5), 22, 'heapsort_int: array(5)')
call test_value(array2_int(6), 46, 'heapsort_int: array(6)')
call test_value(array2_int(7), 47, 'heapsort_int: array(7)')
call test_value(array2_int(8), 67, 'heapsort_int: array(8)')
call test_value(array2_int(9), 71, 'heapsort_int: array(9)')
call test_value(array2_int(10),89, 'heapsort_int: array(10)')

write(stdout,*) 'sort_module unit test passed'
end


subroutine fintersect(ids, nids, idsadd, nc1, c1, nc2, c2)
    implicit none
    integer ids
    integer nids
    integer nc1
    integer nc2
    double precision c1
    double precision c2
    dimension ids(nids,2)
    dimension c1(nc1,3)
    dimension c2(nc2,3)
    integer idsadd
!f2py intent(out) :: idsadd
!f2py intent(out) :: ids
!f2py intent(in) :: nids
!f2py intent(in) :: c1
!f2py intent(in) :: nc1
!f2py intent(in) :: c2
!f2py intent(in) :: nc2

    integer n, i, j
    double precision dr, R2, EPS2
    dimension dr(3)

    ! Subroutine declarations
    double precision dot3
    logical inlist

    EPS2 = 1.0D-4
    ids = -1

    ! we take the shorter one as the reference
    n = nc1
    if (nc2 .lt. nc1) then
        n = nc2
    endif

    ! linear search first but only through the shorter one of
    ! the lists
    idsadd = 1
    do i = 1, n
        dr = c1(i,:) - c2(i,:)
        R2 = dot3(dr, dr)
        if (R2 .lt. EPS2) then
            ids(idsadd,1) = i
            ids(idsadd,2) = i
            idsadd = idsadd +1
        endif
    enddo

    ! now we just do a pair-wise comparison for the
    ! rest of the coordinates
    do i = 1, nc1
        if (inlist(i, nids, ids(:,1))) then
            goto 100
        endif

        do j = 1, nc2
            if (inlist(j, nids, ids(:,2))) then
                goto 95
            endif

            dr = c1(i,:) - c2(j,:)
            R2 = dot3(dr,dr)
            if (R2 .lt. EPS2) then
                 ids(idsadd,1) = i
                 ids(idsadd,2) = j
                 idsadd = idsadd +1
                 goto 100
            end if
 95         continue
        enddo
 100    continue
    enddo

    ! return python-style indexing
    idsadd = idsadd - 1
    ids = ids - 1

    return
end subroutine

function dot3( U, V )
    implicit none
    double precision U, V
    dimension U(3), V(3)
    double precision dot3
    dot3 = U(1)*V(1) + U(2)*V(2) + U(3)*V(3)
    return
end function

function inlist( ival, n, ilist )
    implicit none
    integer ival, ilist, n, i
    logical inlist
    dimension ilist(n)
    inlist = .false.
    do i=1,n
        if (ilist(i) .eq. ival) then
            inlist = .true.
            exit
        endif
    enddo
    return
end function


      SUBROUTINE ZPBEQU( UPLO, N, KD, AB, LDAB, S, SCOND, AMAX, INFO )
*
*  -- LAPACK routine (version 3.2) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          UPLO
      INTEGER            INFO, KD, LDAB, N
      DOUBLE PRECISION   AMAX, SCOND
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   S( * )
      COMPLEX*16         AB( LDAB, * )
*     ..
*
*  Purpose
*  =======
*
*  ZPBEQU computes row and column scalings intended to equilibrate a
*  Hermitian positive definite band matrix A and reduce its condition
*  number (with respect to the two-norm).  S contains the scale factors,
*  S(i) = 1/sqrt(A(i,i)), chosen so that the scaled matrix B with
*  elements B(i,j) = S(i)*A(i,j)*S(j) has ones on the diagonal.  This
*  choice of S puts the condition number of B within a factor N of the
*  smallest possible condition number over all possible diagonal
*  scalings.
*
*  Arguments
*  =========
*
*  UPLO    (input) CHARACTER*1
*          = 'U':  Upper triangular of A is stored;
*          = 'L':  Lower triangular of A is stored.
*
*  N       (input) INTEGER
*          The order of the matrix A.  N >= 0.
*
*  KD      (input) INTEGER
*          The number of superdiagonals of the matrix A if UPLO = 'U',
*          or the number of subdiagonals if UPLO = 'L'.  KD >= 0.
*
*  AB      (input) COMPLEX*16 array, dimension (LDAB,N)
*          The upper or lower triangle of the Hermitian band matrix A,
*          stored in the first KD+1 rows of the array.  The j-th column
*          of A is stored in the j-th column of the array AB as follows:
*          if UPLO = 'U', AB(kd+1+i-j,j) = A(i,j) for max(1,j-kd)<=i<=j;
*          if UPLO = 'L', AB(1+i-j,j)    = A(i,j) for j<=i<=min(n,j+kd).
*
*  LDAB     (input) INTEGER
*          The leading dimension of the array A.  LDAB >= KD+1.
*
*  S       (output) DOUBLE PRECISION array, dimension (N)
*          If INFO = 0, S contains the scale factors for A.
*
*  SCOND   (output) DOUBLE PRECISION
*          If INFO = 0, S contains the ratio of the smallest S(i) to
*          the largest S(i).  If SCOND >= 0.1 and AMAX is neither too
*          large nor too small, it is not worth scaling by S.
*
*  AMAX    (output) DOUBLE PRECISION
*          Absolute value of largest matrix element.  If AMAX is very
*          close to overflow or very close to underflow, the matrix
*          should be scaled.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value.
*          > 0:  if INFO = i, the i-th diagonal element is nonpositive.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            UPPER
      INTEGER            I, J
      DOUBLE PRECISION   SMIN
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
*     ..
*     .. External Subroutines ..
      EXTERNAL           XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          DBLE, MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      UPPER = LSAME( UPLO, 'U' )
      IF( .NOT.UPPER .AND. .NOT.LSAME( UPLO, 'L' ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( KD.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDAB.LT.KD+1 ) THEN
         INFO = -5
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'ZPBEQU', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 ) THEN
         SCOND = ONE
         AMAX = ZERO
         RETURN
      END IF
*
      IF( UPPER ) THEN
         J = KD + 1
      ELSE
         J = 1
      END IF
*
*     Initialize SMIN and AMAX.
*
      S( 1 ) = DBLE( AB( J, 1 ) )
      SMIN = S( 1 )
      AMAX = S( 1 )
*
*     Find the minimum and maximum diagonal elements.
*
      DO 10 I = 2, N
         S( I ) = DBLE( AB( J, I ) )
         SMIN = MIN( SMIN, S( I ) )
         AMAX = MAX( AMAX, S( I ) )
   10 CONTINUE
*
      IF( SMIN.LE.ZERO ) THEN
*
*        Find the first non-positive diagonal element and return.
*
         DO 20 I = 1, N
            IF( S( I ).LE.ZERO ) THEN
               INFO = I
               RETURN
            END IF
   20    CONTINUE
      ELSE
*
*        Set the scale factors to the reciprocals
*        of the diagonal elements.
*
         DO 30 I = 1, N
            S( I ) = ONE / SQRT( S( I ) )
   30    CONTINUE
*
*        Compute SCOND = min(S(I)) / max(S(I))
*
         SCOND = SQRT( SMIN ) / SQRT( AMAX )
      END IF
      RETURN
*
*     End of ZPBEQU
*
      END


!
!    Copyright 2013 Guy Munhoven
!
!    This file is part of SolveSAPHE.

!    SolveSAPHE is free software: you can redistribute it and/or modify
!    it under the terms of the GNU Lesser General Public License as published by
!    the Free Software Foundation, either version 3 of the License, or
!    (at your option) any later version.
!
!    SolveSAPHE 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 Lesser General Public License for more details.
!
!    You should have received a copy of the GNU Lesser General Public License
!    along with SolveSAPHE.  If not, see <http://www.gnu.org/licenses/>.
!

MODULE MOD_RANDOM

IMPLICIT NONE

CONTAINS

!===============================================================================
SUBROUTINE RANDOM_NUMBER_NORMAL(p_rand)
!===============================================================================

! Returns a standard normal random variate (zero mean, unit variance)
! Uses Marsaglia's polar form of the Box-Muller transform

USE MOD_PRECISION

IMPLICIT NONE

!--------------------!
! Argument variables !
!--------------------!

REAL(KIND=wp), INTENT(OUT) :: p_rand

!-----------------!
! Local variables !
!-----------------!

LOGICAL                    :: l_leftover = .FALSE.
REAL(KIND=wp)              :: zrand_leftover = 0._wp

REAL(KIND=wp)              :: zu, zv, zs, zsqroot

!==============================================================================

IF(l_leftover) THEN

  p_rand = zrand_leftover
  l_leftover = .FALSE.

ELSE

  DO
    CALL RANDOM_NUMBER(zu)             ! Get U(0,1) variate
    CALL RANDOM_NUMBER(zv)             ! Get U(0,1) variate

    zu = 2._wp*zu - 1._wp              ! Transform to U(-1,1)
    zv = 2._wp*zv - 1._wp              ! Transform to U(-1,1)

    zs = zu*zu + zv*zv

    IF((zs >= 0._wp) .AND. (zs < 1._wp)) EXIT

  ENDDO

  zsqroot = SQRT(-2._wp*LOG(zs)/zs)

  p_rand = zu*zsqroot

  zrand_leftover = zv*zsqroot
  l_leftover = .TRUE.

ENDIF

RETURN

!===============================================================================
END SUBROUTINE RANDOM_NUMBER_NORMAL
!===============================================================================

!===============================================================================
SUBROUTINE RANDOM_NUMBER_UNIFORM(p_rand)
!===============================================================================

! Returns a uniformly distributed random variate, with zero mean and unit variance

USE MOD_PRECISION

IMPLICIT NONE

!------------------!
! Local parameters !
!------------------!

! Square root of 3:
! from http://apod.nasa.gov/htmltest/gifcity/sqrt3.1mil; also http://oeis.org/A002194;
! rounded to 20 significant figures here
REAL(KIND=wp), PARAMETER  :: pp_sqrt3 = 1.7320508075688772935_wp

!--------------------!
! Argument variables !
!--------------------!

REAL(KIND=wp), INTENT(OUT) :: p_rand

!-----------------!
! Local variables !
!-----------------!

REAL(KIND=wp)              :: z_rand

!==============================================================================

 CALL RANDOM_NUMBER(z_rand)                ! Get one U(0,1) variate

 p_rand = (2._wp*z_rand - 1._wp)*pp_sqrt3  ! Transform to U(-SQRT(3),SQRT(3)),
                                           ! which has unit variance and zero mean

RETURN

!===============================================================================
END SUBROUTINE RANDOM_NUMBER_UNIFORM
!===============================================================================

END MODULE MOD_RANDOM


subroutine init_RNG
	use params
	integer :: i, un, n, irand, istat
	integer, allocatable :: seed(:)
	call random_seed(size = n)
	allocate(seed(n))
	open(newunit=un, file="/dev/urandom", access="stream", &
	form="unformatted", action="read", status="old", iostat=istat)
	if (istat == 0) then
		read(un) seed
		close(un)
	else
		write (8, *) 'No /dev/urandom. Falling back to time as random seed'
		do i = 1, n
			call system_clock(seed(i))
		end do
	end if
	write (8, *) 'Initialised RNG with seed: ', seed
	call random_seed(put=seed)
	flush(8)
end subroutine

subroutine add_noise
	use params
	implicit none
	double precision :: rn1,rn2
	integer :: i,j,k,seed
	call random_number(rn1)
	call random_number(rn2)
	do i = -NX/2, NX/2
		do j = -NY/2, NY/2
			do k = -NZ/2, NZ/2
			GRID(i,j,k) = GRID(i,j,k) + GRID(i,j,k)*CMPLX((rn1*noiseamp)&
									-(noiseamp/2.0d0),(rn2*noiseamp)-(noiseamp/2.0d0))
			end do
		end do
	end do
end subroutine

!Approx - homogeneous!
subroutine initCond
	use params
	implicit none
	integer :: i,j,k
	if(initialCondType .eq. 0) then
		if (RHSType .eq. 0) then
			GRID =  1.00d0
		end if
		if (RHSType .eq. 1) then
			do i = -NX/2, NX/2
				do j = -NY/2, NY/2
					do k = -NZ/2, NZ/2
						GRID(i,j,k) = (harm_osc_mu - OBJPOT(i,j,k))/harm_osc_C
						if(DBLE(GRID(i,j,k)) < 0) GRID(i,j,k) = 0.0d0
					end do
				end do
			end do
			GRID = SQRT(GRID)
		end if
	else if(initialCondType .eq. 1) then
		call makeRandomPhase
	else if(initialCondType .eq. 2) then
		call loadPreviousState
		call calc_OBJPOT
	end if
end subroutine
!!!!!!!!!!!!!!!!!!!!!!
subroutine loadPreviousState
	use params
	use output
	implicit none
	call read_wf_file(icr_filename)
	INITSSTEP = RESUMESTEP
	TIME = RESUMETIME
end subroutine

subroutine makeRandomPhase
	use params
	implicit none
	double precision :: phi, rand
	complex*16, dimension(-NX/2:NX/2,-NY/2:NY/2,-NZ/2:NZ/2) :: a
	integer :: i, j, k, ii2, jj2, kk2

	call calc_rpKC_rpAMP

	write (8, *) 'Complex amplitude=', rpAMP
	write (8, *) 'Cutoff wavenumber=', rpKC
	flush(8)

	do k=-NZ/2,NZ/2
		if (k <= 0) then
			kk2 = (NZ/2+k)**2
		else
			kk2 = (-NZ/2+k)**2
		end if
		do j=-NY/2,NY/2
			if (j <= 0) then
				jj2 = (NY/2+j)**2
			else
				jj2 = (-NY/2+j)**2
			end if
			do i=-NX/2,NX/2
				if (i <= 0) then
					ii2 = (NX/2+i)**2
				else
					ii2 = (-NX/2+i)**2
				end if
				if ((ii2 + jj2 + kk2) <= rpKC) then
					call random_number(phi)
					a(i,j,k) = rpAMP*exp(2.0*PI*EYE*phi)
				else
					a(i,j,k) = 0.0d0
				end if
			end do
		end do
	end do

	call fft(a, GRID, 'backward')

end subroutine

subroutine calc_rpKC_rpAMP
	use params
	implicit none
	double precision :: ev
	ev = ((0.5*NX/PI)**2.0)*ENERV
	rpAMP = sqrt(((0.11095279993106999d0*NV**2.5d0)*(NX*NY*NZ)) / (ev**1.5d0))
	rpKC = (1.666666666666666d0*ev)/NV
end subroutine

subroutine calc_norm
	use params
	implicit none
	integer :: i,j
	double precision :: int_grid_3D
	NORM=int_grid_3D(DBLE(GRID*CONJG(GRID)))
	!write(6,*)NORM
end subroutine

function int_grid_3D(intThing)
	use params
	implicit none
	integer :: k,l
	double precision ::  simpsons_int_grid,int_grid_3D,a(3),b
	double precision, dimension(-NX/2:NX/2,-NY/2:NY/2,-NZ/2:NZ/2) :: intThing

	a(1) = simpsons_int_grid(intThing(:,:,-NZ/2))
	a(2) = 0.0d0
	do k = -NZ/2+1, NZ/2-1
		l = k + NZ/2
		if(modulo(l,2) == 0) then
			b = 2
		else
			b = 4
		end if
		a(2) = a(2) + b*simpsons_int_grid(intThing(:,:,k))
	end do
	a(3) = simpsons_int_grid(intThing(:,:,-NZ/2))
	int_grid_3D = (DSPACE/3.0d0)*(a(1)+a(2)+a(3))
end function

function simpsons_int_grid(intThing)
	use params
	implicit none
	double precision :: simpsons_int_grid,a(16)
	double precision, dimension(-NX/2:NX/2,-NY/2:NY/2) :: intThing

	a(1) = intThing(-NX/2,-NY/2)
	a(2) = intThing(-NX/2,NY/2)
	a(3) = intThing(NX/2,-NY/2)
	a(4) = intThing(NX/2,NY/2)

	a(5) = 4.0d0*sum(intThing(-NX/2,-NY/2+1:NY/2-1:2))
	a(6) = 2.0d0*sum(intThing(-NX/2,-NY/2+2:NY/2-1:2))
	a(7) = 4.0d0*sum(intThing(NX/2,-NY/2+1:NY/2-1:2))
	a(8) = 2.0d0*sum(intThing(NX/2,-NY/2+2:NY/2-1:2))

	a(9) = 4.0d0*sum(intThing(-NX/2+1:NX/2-1:2,-NY/2))
  a(10) = 2.0d0*sum(intThing(-NX/2+2:NX/2-1:2,-NY/2))
  a(11) = 4.0d0*sum(intThing(-NX/2+1:NX/2-1:2,NY/2))
  a(12) = 2.0d0*sum(intThing(-NX/2+2:NX/2-1:2,NY/2))

  a(13) = 16.0d0*sum(intThing(-NX/2+1:NX/2-1:2,-NY/2+1:NY/2-1:2))
  a(14) = 8.0d0* sum(intThing(-NX/2+1:NX/2-1:2,-NY/2+2:NY/2-1:2))
  a(15) = 8.0d0* sum(intThing(-NX/2+2:NX/2-1:2,-NY/2+1:NY/2-1:2))
  a(16) = 4.0d0*sum(intThing(-NX/2+2:NX/2-1:2,-NY/2+2:NY/2-1:2))

   simpsons_int_grid = (1.0d0/9.0d0)*(DSPACE*DSPACE)*sum(a)
end function

subroutine calc_misc
	use params
	implicit none
	double precision :: energy
	call calc_energy(energy)
    write (unit=8,fmt="(f7.2,f16.8)") time,energy
    flush(8)
end subroutine

subroutine calc_energy(energy)
	use params
	implicit none
	integer :: i,j,k
	COMPLEX*16 :: uux,uuy,uuz,ddx,ddy,ddz
	double precision :: energy,ep1,ep2
	double precision :: int_grid_3D
	double precision, dimension(-NX/2:NX/2,-NY/2:NY/2,-NZ/2:NZ/2) :: dpsi2
	!$OMP PARALLEL DO
	do i = -NX/2, NX/2
		do j = -NY/2, NY/2
			do k = -NZ/2, NZ/2
				uux = ddx(GRID,i,j,k)
				uuy = ddy(GRID,i,j,k)
				uuz = ddz(GRID,i,j,k)
				dpsi2(i,j,k) = dble(uux*conjg(uux) + uuy*conjg(uuy) + uuz*conjg(uuz))
			end do
		end do
	end do
	!$OMP END PARALLEL DO
	ep1 = int_grid_3D(dpsi2)
	ep2 = int_grid_3D(DBLE(GRID*CONJG(GRID)*GRID*CONJG(GRID)))
	energy = 0.5d0*ep1 + 0.5d0*ep2
end subroutine

subroutine insert_vortex_line_with_ghosts_xy(xloc,yloc,zloc,circ,rot,amp1,amp2,kk,ll,k3,dtheta)
	use params
	implicit none
	integer :: i,j,k,rot,circ
	double precision :: xloc,yloc,zloc,amp1,amp2,kk,ll,dtheta,rs,xx,yy,zz,cd,sd,k3
	call insert_vortex_line(xloc,yloc,zloc,circ,rot,amp1,amp2,kk,ll,k3,dtheta)
	call insert_vortex_line(xloc+(NX*DSPACE),yloc,zloc,circ,rot,amp1,amp2,kk,ll,k3,dtheta)
	call insert_vortex_line(xloc,yloc+(NY*DSPACE),zloc,circ,rot,amp1,amp2,kk,ll,k3,dtheta)
	call insert_vortex_line(xloc-(NX*DSPACE),yloc,zloc,circ,rot,amp1,amp2,kk,ll,k3,dtheta)
	call insert_vortex_line(xloc,yloc-(NY*DSPACE),zloc,circ,rot,amp1,amp2,kk,ll,k3,dtheta)

end subroutine

subroutine insert_vortex_line(xloc,yloc,zloc,circ,rot,amp1,amp2,kk,ll,k3,dtheta)
	use params
	implicit none
	integer :: i,j,k,rot,circ
	double precision :: xloc,yloc,zloc,amp1,amp2,kk,ll,dtheta,rs,xx,yy,zz,cd,sd,k3
	double precision, dimension(-NX/2:NX/2,-NY/2:NY/2,-NZ/2:NZ/2) :: R
	complex*16, dimension(-NX/2:NX/2,-NY/2:NY/2,-NZ/2:NZ/2) :: phse

	do i = -NX/2, NX/2
		do j = -NY/2, NY/2
			do k = -NZ/2, NZ/2
				if (rot .eq. 0) then
					xx = (i*DSPACE) - xloc
					yy = (j*DSPACE) - yloc
					zz = (k*DSPACE) - zloc
				else if (rot .eq. 1) then
					yy = (i*DSPACE) - xloc
					zz = (j*DSPACE) - yloc
					xx = (k*DSPACE) - zloc
				else if (rot .eq. 2) then
					zz = (i*DSPACE) - xloc
					xx = (j*DSPACE) - yloc
					yy = (k*DSPACE) - zloc
				end if
				if(abs(zz) < k3) then
					cd = amp1*cos(2.0d0*PI*zz/kk)
					sd = amp2*sin(2.0d0*PI*zz/ll)
				else
					cd = 0
					sd = 0
				end if

				rs=(xx-sd)**2.0d0 + (yy-cd)**2.0d0;
				phse(i,j,k) = exp(circ*EYE*(ATAN2(yy-cd,xx-sd) + dtheta*zz))
				R(i,j,k) = sqrt(rs*(0.3437+0.0286*rs)/(1+0.3333*rs+0.0286*rs*rs));
			end do
		end do
	end do
	GRID = GRID*R*phse;
end subroutine

subroutine insert_vortex_ring(x0,y0,z0,r0,dir,rot)
	use params
	implicit none
	integer :: i,j,k,dir,rot,n,m
	double precision :: x0,y0,z0,r0,xx,yy,zz
	complex*16, dimension(-NX/2:NX/2,-NY/2:NY/2,-NZ/2:NZ/2) :: vortex_ring
	double precision, dimension(-NX/2:NX/2,-NY/2:NY/2,-NZ/2:NZ/2) :: rr1,rr2,d1,d2
	double precision, dimension(:,:), ALLOCATABLE :: s

	if (rot .eq. 0) then
		ALLOCATE(s(-NX/2:NX/2,-NY/2:NY/2))
		do j=-NY/2,NY/2
		  do i=-NX/2,NX/2
		  	xx = (i*DSPACE) - x0
			yy = (j*DSPACE) - y0
			s(i,j) = sqrt(xx**2 + yy**2)
		  end do
		end do
	else if (rot .eq. 1) then
		ALLOCATE(s(-NZ/2:NZ/2,-NX/2:NX/2))
		do i=-NX/2,NX/2
		  do k=-NZ/2,NZ/2
		  	yy = (i*DSPACE) - x0
			xx = (k*DSPACE) - z0
			s(k,i) = sqrt(xx**2 + yy**2)
		  end do
		end do
	else if (rot .eq. 2) then
		ALLOCATE(s(-NY/2:NY/2,-NZ/2:NZ/2))
		do k=-NZ/2,NZ/2
		  do j=-NY/2,NY/2
			xx = (j*DSPACE) - y0
			yy = (k*DSPACE) - z0
			s(j,k) = sqrt(xx**2 + yy**2)
		  end do
		end do
	end if

    do k=-NZ/2,NZ/2
      do j=-NY/2,NY/2
        do i=-NX/2,NX/2
          if (rot .eq. 0) then
          	n=i
          	m=j
			zz = (k*DSPACE) - z0
          else if (rot .eq. 1) then
            n=k
          	m=i
			zz = (j*DSPACE) - y0
          else if (rot .eq. 2) then
            n=j
            m=k
			zz = (i*DSPACE) - x0
          end if
          d1(i,j,k) = sqrt( (zz)**2 + (s(n,m)+r0)**2 )
          d2(i,j,k) = sqrt( (zz)**2 + (s(n,m)-r0)**2 )
        end do
      end do
    end do

    rr1 = sqrt( ((0.3437d0+0.0286d0*d1**2)) / &
      (1.0d0+(0.3333d0*d1**2)+(0.0286d0*d1**4)) )
    rr2 = sqrt( ((0.3437d0+0.0286d0*d2**2)) / &
      (1.0d0+(0.3333d0*d2**2)+(0.0286d0*d2**4)) )

    do k=-NZ/2,NZ/2
      do j=-NY/2,NY/2
        do i=-NX/2,NX/2
          if (rot .eq. 0) then
          	n=i
          	m=j
			zz = (k*DSPACE) - z0
          else if (rot .eq. 1) then
            n=k
          	m=i
			zz = (j*DSPACE) - y0
          else if (rot .eq. 2) then
            n=j
            m=k
			zz = (i*DSPACE) - x0
          end if
          vortex_ring(i,j,k) =  rr1(i,j,k)*(zz+dir*EYE*(s(n,m)+r0)) * &
                                rr2(i,j,k)*(zz-dir*EYE*(s(n,m)-r0))
        end do
      end do
    end do
	GRID = GRID*vortex_ring
end subroutine

subroutine fft(in_var, out_var, dir)
	! Calculate the FFT (or inverse) of a variable
	use params
	use omp_lib
	use, intrinsic :: iso_c_binding
	implicit none
	include 'fftw3.f03'

	complex*16, dimension(-NX/2:NX/2,-NY/2:NY/2,-NZ/2:NZ/2), intent(inout) :: in_var
	complex*16, dimension(-NX/2:NX/2,-NY/2:NY/2,-NZ/2:NZ/2), intent(out) :: out_var
	character(*), intent(in) :: dir
	integer :: i, j, k
	integer iret
	integer*8 :: plan
	!call dfftw_init_threads(iret)
	!call dfftw_plan_with_nthreads(omp_get_max_threads())

	select case (dir)
	case ('forward')
		call dfftw_plan_dft_3d(plan, NX+1, NY+1, NZ+1, in_var, out_var, FFTW_FORWARD, FFTW_ESTIMATE)
	case ('backward')
		call dfftw_plan_dft_3d(plan, NX+1, NY+1, NZ+1, in_var, out_var, FFTW_BACKWARD, FFTW_ESTIMATE)
	case default
		write(6,*) 'ERROR: Not a valid direction for FFT!'
	end select

	call dfftw_execute_dft(plan, in_var, out_var)
	call dfftw_destroy_plan(plan)

	! Renormalise
	out_var = out_var / sqrt(dble((NX+1)*(NY+1)*(NZ+1)))
end subroutine fft


PROGRAM SUBDEM

real A
integer B
B = 2
A = 3.23

print *, (A ** A)
print *, (A ** B)
print *, (B ** B)
print *, (B ** A)

end program SUBDEM


      PROGRAM Y0TEST
C--------------------------------------------------------------------
C  Fortran 77 program to test BESY0
C
C  Data required
C
C     None
C
C  Subprograms required from this package
C
C     MACHAR - an environmental inquiry program providing
C              information on the floating-point arithmetic
C              system.  Note that the call to MACHAR can
C              be deleted provided the following five
C              parameters are assigned the values indicated
C
C                 IBETA  - the radix of the floating-point system
C                 IT     - the number of base-IBETA digits in the
C                          significand of a floating-point number
C                 MINEXP - the largest in magnitude negative
C                          integer such that  FLOAT(IBETA)**MINEXP
C                          is a positive floating-point number
C                 EPS    - the smallest positive floating-point
C                          number such that 1.0+EPS .NE. 1.0
C                 EPSNEG - the smallest positive floating-point
C                          number such that 1.0-EPSNEG .NE. 1.0
C
C     REN(K) - a function subprogram returning random real
C              numbers uniformly distributed over (0,1)
C
C
C  Intrinsic functions required are:
C
C         ABS, DBLE, LOG, MAX, REAL, SQRT
C
C  Reference: "Performance evaluation of programs for certain
C              Bessel functions", W. J. Cody and L. Stoltz,
C              ACM Trans. on Math. Software, Vol. 15, 1989,
C              pp 41-48.
C
C  Latest modification: March 13, 1992
C
C  Author: W. J. Cody
C          Mathematics and Computer Science Division
C          Argonne National Laboratory
C          Argonne, IL 60439
C
C--------------------------------------------------------------------
      LOGICAL SFLAG,TFLAG
      INTEGER I,IBETA,IEXP,II,IND,IOUT,IRND,IT,J,JT,K1,K2,K3,
     1        MACHEP,MAXEXP,MB,MINEXP,N,NDUM,NEGEP,NGRD
CS    REAL
      DOUBLE PRECISION
     1   A,AIT,ALBETA,ALL9,B,BESY0,BESY1,BETA,C,CONV,DEL,EIGHT,
     2   EPS,EPSNEG,FIVE5,HALF,HUND,ONE,REN,R6,R7,SIXTEN,SUM,T,
     3   T1,THREE,TWENTY,TWO56,U,W,X,XI,XL,XLAM,XMAX,XMB,XMIN,
     4   X1,Y,YX,Z,ZERO,ZZ
      DIMENSION U(560),XI(3),YX(3)
CS    DATA ZERO,ONE,THREE,FIVE5/0.0E0,1.0E0,3.0E0,5.5E0/,
CS   1   EIGHT,TWENTY,ALL9,TWO56/8.0E0,20.0E0,-999.0E0,256.0E0/,
CS   2   HALF,SIXTEN,XLAM,HUND/0.5E0,16.0E0,0.9375E0,100.0D0/
CS    DATA XI/228.0E0,1013.0E0,1814.0E0/
CS    DATA YX(1)/-2.6003 14272 29334 87915 E-3/,
CS   1     YX(2)/ 2.6053 45491 14567 74983 E-4/,
CS   2     YX(3)/-3.4079 44871 47955 52077 E-5/
      DATA ZERO,ONE,THREE,FIVE5/0.0D0,1.0D0,3.0D0,5.5D0/,
     1   EIGHT,TWENTY,ALL9,TWO56/8.0D0,20.0D0,-999.0D0,256.0D0/,
     2   HALF,SIXTEN,XLAM,HUND/0.5D0,16.0D0,0.9375D0,100.0D0/
      DATA XI/228.0D0,1013.0D0,1814.0D0/
      DATA YX(1)/-2.6003142722933487915D-3/,
     1     YX(2)/ 2.6053454911456774983D-4/,
     2     YX(3)/-3.4079448714795552077D-5/
      DATA IOUT/6/
C--------------------------------------------------------------------
C  Statement functions for conversion between integer and float
C--------------------------------------------------------------------
CS    CONV(NDUM) = REAL(NDUM)
      CONV(NDUM) = DBLE(NDUM)
C--------------------------------------------------------------------
C  Determine machine parameters and set constants
C--------------------------------------------------------------------
      CALL MACHAR(IBETA,IT,IRND,NGRD,MACHEP,NEGEP,IEXP,MINEXP,
     1            MAXEXP,EPS,EPSNEG,XMIN,XMAX)
      BETA = CONV(IBETA)
      ALBETA = LOG(BETA)
      AIT = CONV(IT)
      JT = 0
      A = EPS
      B = THREE
      N = 2000
C--------------------------------------------------------------------
C  Random argument accuracy tests based on the multiplication theorem
C--------------------------------------------------------------------
      DO 300 J = 1, 4
         SFLAG = (J .EQ. 1) .AND. (MAXEXP/IT .LE. 5)
         K1 = 0
         K2 = 0
         K3 = 0
         X1 = ZERO
         R6 = ZERO
         R7 = ZERO
         DEL = (B - A) / CONV(N)
         XL = A
         DO 200 I = 1, N
            X = DEL * REN(JT) + XL
C--------------------------------------------------------------------
C  Carefully purify arguments
C--------------------------------------------------------------------
            Y = X/XLAM
            W = SIXTEN * Y
            Y = (W + Y) - W
            X = Y * XLAM
C--------------------------------------------------------------------
C  Generate Bessel functions with forward recurrence
C--------------------------------------------------------------------
            U(1) = BESY0(Y)
            U(2) = BESY1(Y)
            TFLAG = SFLAG .AND. (Y .LT. HALF)
            IF (TFLAG) THEN
               U(1) = U(1) * EPS
               U(2) = U(2) * EPS
            END IF
            MB = 1
            XMB = ONE
            Y = Y * HALF
            W = (ONE-XLAM)*(ONE+XLAM)
            C = W * Y
            T = ABS(U(1)+C*U(2))
            T1 = EPS/HUND
            DO 110 II = 3, 60
               Z = ABS(U(II-1))
               IF (Z/T1 .LT. T) GO TO 120
               IF (Y .LT. XMB) THEN
                  IF (Z .GT. XMAX*(Y/XMB)) THEN
                     A = X
                     XL = XL + DEL
                     GO TO  200
                  END IF
               END IF
               U(II) = XMB/Y * U(II-1) - U(II-2)
               IF (T1 .GT. ONE/EPS) THEN
                  T = T * T1
                  T1 = ONE
               END IF
               T1 = XMB * T1 / C
               XMB = XMB + ONE
               MB = MB + 1
  110       CONTINUE
C--------------------------------------------------------------------
C  Evaluate Bessel series expansion
C--------------------------------------------------------------------
  120       SUM = U(MB)
            IND = MB
            DO 155 II = 2, MB
               IND = IND - 1
               XMB = XMB - ONE
               SUM = SUM * W * Y / XMB + U(IND)
  155       CONTINUE
            ZZ = SUM
            IF (TFLAG) ZZ = ZZ / EPS
            Z = BESY0(X)
            Y = Z
            IF (ABS(U(1)) .GT. ABS(Y)) Y = U(1)
C--------------------------------------------------------------------
C  Accumulate results
C--------------------------------------------------------------------
            W = (Z - ZZ) / Y
            IF (W .GT. ZERO) THEN
                  K1 = K1 + 1
               ELSE IF (W .LT. ZERO) THEN
                  K3 = K3 + 1
               ELSE
                  K2 = K2 + 1
            END IF
            W = ABS(W)
            IF (W .GT. R6) THEN
               R6 = W
               X1 = X
            END IF
            R7 = R7 + W * W
            XL = XL + DEL
  200    CONTINUE
C--------------------------------------------------------------------
C  Gather and print statistics
C--------------------------------------------------------------------
         N = K1 + K2 + K3
         R7 = SQRT(R7/CONV(N))
         WRITE (IOUT,1000)
         WRITE (IOUT,1010) N,A,B
         WRITE (IOUT,1011) K1,K2,K3
         WRITE (IOUT,1020) IT,IBETA
         W = ALL9
         IF (R6 .NE. ZERO) W = LOG(ABS(R6))/ALBETA
         IF (J .EQ. 4) THEN
               WRITE (IOUT,1024) R6,IBETA,W,X1
            ELSE
               WRITE (IOUT,1021) R6,IBETA,W,X1
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
         W = ALL9
         IF (R7 .NE. ZERO) W = LOG(ABS(R7))/ALBETA
         IF (J .EQ. 4) THEN
               WRITE (IOUT,1025) R7,IBETA,W
            ELSE
               WRITE (IOUT,1023) R7,IBETA,W
         END IF
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1022) IBETA,W
C--------------------------------------------------------------------
C  Initialize for next test
C--------------------------------------------------------------------
         A = B
         IF (J .EQ. 1) THEN
               B = FIVE5
               N = 2000
            ELSE IF (J .EQ. 2) THEN
               B = EIGHT
               N = 2000
            ELSE
               B = TWENTY
               N = 500
         END IF
  300 CONTINUE
C--------------------------------------------------------------------
C  Special tests
C--------------------------------------------------------------------
      WRITE (IOUT,1030)
      WRITE (IOUT,1031) IBETA
      DO 330 I = 1, 3
         X = XI(I)/TWO56
         Y = BESY0(X)
         W = ALL9
         T = (Y-YX(I))/YX(I)
         IF (T .NE. ZERO) W = LOG(ABS(T))/ALBETA
         W = MAX(AIT+W,ZERO)
         WRITE (IOUT,1032) X,Y,W
  330 CONTINUE
C--------------------------------------------------------------------
C  Test of error returns
C--------------------------------------------------------------------
      WRITE (IOUT,1033)
      X = XMIN
      WRITE (IOUT,1035) X
      Y = BESY0(X)
      WRITE (IOUT,1036) Y
      X = ZERO
      WRITE (IOUT,1034) X
      Y = BESY0(X)
      WRITE (IOUT,1036) Y
      X = XMAX
      WRITE (IOUT,1034) X
      Y = BESY0(X)
      WRITE (IOUT,1036) Y
      WRITE (IOUT,1100)
      STOP
 1000 FORMAT('1Test of Y0(X) VS Multiplication Theorem'  //)
 1010 FORMAT(I7,' random arguments were tested from the interval ',
     1 '(',F5.1,',',F5.1,')'//)
 1011 FORMAT(' ABS(Y0(X)) was larger',I6,' times', /
     1   15X,' agreed',I6,' times, and'/
     1   11X,'was smaller',I6,' times.'//)
 1020 FORMAT(' There are',I4,' base',I4,
     1    ' significant digits in a floating-point number.' //)
 1021 FORMAT(' The maximum relative error of',E15.4E3,' = ',I4,' **',
     1  F7.2/4X,'occurred for X =',E13.6E3)
 1022 FORMAT(' The estimated loss of base',I4,
     1  ' significant digits is',F7.2//)
 1023 FORMAT(' The root mean square relative error was',E15.4E3,
     1    ' = ',I4,' **',F7.2)
 1024 FORMAT(' The maximum absolute error of',E15.4E3,' = ',I4,' **',
     1  F7.2/4X,'occurred for X =',E13.6E3)
 1025 FORMAT(' The root mean square absolute error was',E15.4E3,
     1    ' = ',I4,' **',F7.2)
 1030 FORMAT('1Special Tests'//)
 1031 FORMAT(' Accuracy near zeros'//10X,'X',15X,'BESY0(X)',
     1    13X,'Loss of base',I3,' digits'/)
 1032 FORMAT(E20.10E3,E25.15E3,8X,F7.2/)
 1033 FORMAT(//' Test with extreme arguments'/)
 1034 FORMAT(' Y0 will be called with the argument ',E17.10E3/
     1     ' This may stop execution.'//)
 1035 FORMAT(' Y0 will be called with the argument ',E17.10E3/
     1     ' This should not stop execution.'//)
 1036 FORMAT(' Y0 returned the value',E25.17E3/)
 1100 FORMAT(' This concludes the tests.')
C---------- Last card of BESY0 test program ----------
      END


program b
    use percolation
    use utilities
    implicit none

    integer, dimension(:), allocatable :: Ls, sample_sizes
    integer :: i, j, k, number_of_samples, number_of_probabilities, L
    real(kind=dp), dimension(:), allocatable :: P, PI
    real(kind=dp), dimension(:), allocatable :: probabilities
    character(len=:), allocatable :: fmtstring, Pfile, PIfile, filebase
    integer :: Punit, PIunit

    Ls = [ (2**i, i=1, 7) ]
    sample_sizes = [10, 100, 1000] !, 2000]

    number_of_probabilities = 101
    probabilities = linspace(0.0d0,1.0d0,number_of_probabilities)

    fmtstring = "(f0.6,x,f0.6)"

    do i = 1, size(sample_sizes)
        number_of_samples = sample_sizes(i)
        do j = 1, size(Ls)
            L = Ls(j)
            write(*,*) "L = ", L, ", samples = ", number_of_samples
            P  = [ (spanning_density(probabilities(k), L, number_of_samples),&
                        k = 1, number_of_probabilities) ]
            PI = [ (spanning_probability(probabilities(k), L, number_of_samples), &
                        k = 1, number_of_probabilities) ]
            filebase = stringfromint(number_of_samples) // "_" // stringfromint(L) // ".dat"
            Pfile = "tmp/P_" // filebase
            PIfile = "tmp/PI_" // filebase

            open(newunit=Punit, file=Pfile, status="replace")
            open(newunit=PIunit, file=PIfile, status="replace")
            do k = 1, number_of_probabilities
                write(unit=Punit,fmt=fmtstring) probabilities(k), P(k)
                write(unit=PIunit,fmt=fmtstring) probabilities(k), PI(k)
            end do
            close(unit=Punit)
            close(unit=PIunit)
        end do
    end do

end program b


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      MODULE m_od_kptsgen
      CONTAINS
      SUBROUTINE od_kptsgen (nkpt)

!          generates a kpts file in a half of the
!       one-dimensional Brillouin zone, uniform distribution
!                      Y. Mokrousov Dec 2005

      IMPLICIT NONE

      INTEGER, INTENT(IN) :: nkpt

!  local
      INTEGER i,j
      REAL   , ALLOCATABLE :: kpts(:,:)
      REAL    scale

      scale = 1.0

      ALLOCATE ( kpts(3,nkpt) )

      OPEN (41,file='kpts',form='formatted',status='new')
      WRITE (41,FMT=8110) nkpt,scale,.false.

      DO i = 1,nkpt

         kpts(1,i) = 0.
         kpts(2,i) = 0.
         IF (nkpt.EQ.1) THEN
            kpts(3,i) = 0.0
         ELSE
            kpts(3,i) = scale*(i-1)/(2.*(nkpt-1))
         ENDIF

         WRITE (41,FMT=8040) (kpts(j,i),j=1,3)

      END DO

 8110 FORMAT (i5,f20.10,3x,l1)
 8040 FORMAT (4f10.5)

      CLOSE (41)

      DEALLOCATE ( kpts )

      END SUBROUTINE od_kptsgen
      END MODULE m_od_kptsgen


program intrinsic_mmloc_2
  real a(-1:1), b(2:3), c(1:2)
  integer, dimension(1):: i
  real (kind = 8), dimension(-1:1) :: vc

  a = 0
  b = 0
  c = 0
  a(-1) = 1
  b(2) = 1
  c(1) = 1

  if (maxloc (a, 1) .ne. 1) call abort()
  if (maxloc (b, 1) .ne. 1) call abort()
  if (maxloc (c, 1) .ne. 1) call abort()

  ! We were giving MINLOC and MAXLOC the wrong return type
  vc = (/4.0d0, 2.50d1, 1.0d1/)
  i = minloc (vc)
  if (i(1) .ne. 1) call abort()
END PROGRAM


! How to remove ^M in source code on linux %s/^M//g (^M = Ctrl+v+m)
! Note on subroutine random_number
! Returns a single pseudorandom number or an array of pseudorandom numbers from the uniform distribution over the range [0, 1).
! The runtime-library implements the xorshift1024* random number generator(RNG). This generator has a period of 2^{1024} - 1,
! and when using multiple threads up to 2^{512} threads can each generate 2^{512} random numbers before any aliasing occurs.

module parameters
    integer, parameter :: latt_leng = 80
    integer, parameter :: EXCH_CONST = 1 ! exchange constant
    integer, parameter :: n_T_step = 1000
    double precision, parameter :: T_start = 2.0d0
    double precision, parameter :: T_end = 2.5d0
    integer, dimension(-1 : latt_leng, -1 : latt_leng) :: spin_of ! (-1 ... latt_leng) X (-1 ... latt_leng)
    double precision, dimension(-2 : 2) :: accept_prob_chart
end module

program Ising_Model ! computes the Tc of 2D Ising Model, EXCH_CONST = 1
    use parameters
    implicit none ! Require all variables to be explicitly declared
    integer :: T_step
    integer(kind = 8), parameter :: MC_max = 1E11  ! number of iteration of MC simulation per temperature ~n^3 to equilibriate
    double precision, dimension(0 : n_T_step) :: avg_E !(0 ... n_T_increments), Ensemble average of E per site
    double precision, dimension(0 : n_T_step) :: avg_M !(0 ... n_T_increments), Ensemble average of M per site
    double precision, dimension(0 : n_T_step) :: avg_Cv !(0 ... n_T_increments), Ensemble average of Cv per site
    double precision :: T, del_T, Tc_avg_E, Tc_avg_M, Tc_avg_Cv, avg_en, avg_mag, avg_cap ! Unit = kT/J, Tc computed with each of the physical observables

    call create_lattice_aligned !Integrate create_lattice routines
    del_T = (T_end - T_start) / n_T_step
    do T_step = 0, n_T_step
        T = T_start + del_T * T_step ! update T, unit = kT/J
        if(EXCH_CONST == -1) then ! Anti-ferromagnetic, EXCH_CONST = -1
            accept_prob_chart = (/ exp(-8d0 / T), exp(-4d0 / T), &
            1d0, exp(4d0 / T), exp(8d0 / T) /) ! Acceptance probability chart
        else ! Ferromagnetic, EXCH_CONST = 1
            accept_prob_chart = (/ exp(8d0 / T), exp(4d0 / T), &
            1d0, exp(-4d0 / T), exp(-8d0 / T) /)
        end if
        call flip_sites_metropolis(T, MC_max, avg_en, avg_mag, avg_cap) ! Iterate MC simulation MC_max times per temperature
        avg_E(T_step) = avg_en ! Ensemble average of E per site
        avg_M(T_step) = avg_mag  ! Ensemble average of M per site
        avg_Cv(T_step) = avg_cap ! (<E**2>-<E>**2)/T**2
    end do
    call compute_Tc_with_E_or_M(avg_E, Tc_avg_E) ! Find maximum slope
    call compute_Tc_with_E_or_M(avg_M, Tc_avg_M)
    call compute_Tc_with_Cv(avg_Cv, Tc_avg_Cv) ! Find maximum value
    call print_data(1, avg_E, Tc_avg_E)
    call print_data(2, avg_M, Tc_avg_M)
    call print_data(3, avg_Cv, Tc_avg_Cv)
    call make_data_file(1, avg_E, Tc_avg_E)
    call make_data_file(2, avg_M, Tc_avg_M)
    call make_data_file(3, avg_Cv, Tc_avg_Cv)
end program

subroutine create_lattice_random
    use parameters
    integer :: x, y
    double precision :: u

    do x = 0, latt_leng - 1
        do y = 0, latt_leng - 1
            call random_number(u) ! Return random real number in [0,1)
            if (u >= 0.5) then
                spin_of(x, y) = 1 ! Assign random spin values
            else
                spin_of(x, y) = -1
            end if
        end do
    end do

    do x = 0, latt_leng - 1 ! Assign spins to top and bottom line of padding sites to make it periodic
        spin_of(x, -1) = spin_of(x, latt_leng - 1)
        spin_of(x, latt_leng) = spin_of(x, 0)
    end do
    do y = 0, latt_leng -1  ! Assign spins to left and right line of padding sites to make it periodic
        spin_of(-1, y) = spin_of(latt_leng - 1, y)
        spin_of(latt_leng, y) = spin_of(0, y)
    end do
end subroutine

subroutine create_lattice_aligned
    use parameters
    integer :: x, y

    do x = 0, latt_leng - 1 ! Assign spins on each site
        do y = 0, latt_leng - 1
            spin_of(x, y) = 1 ! All up spins
        end do
    end do

    do x = 0, latt_leng - 1 ! Assign spins to top and bottom line of padding sites to make it periodic
        spin_of(x, -1) = spin_of(x, latt_leng - 1)
        spin_of(x, latt_leng) = spin_of(x, 0)
    end do
    do y = 0, latt_leng -1  ! Assign spins to left and right line of padding sites to make it periodic
        spin_of(-1, y) = spin_of(latt_leng - 1, y)
        spin_of(latt_leng, y) = spin_of(0, y)
    end do
end subroutine

subroutine flip_sites_metropolis(T, MC_max, avg_en, avg_mag, avg_en2)
    use parameters
    integer :: x, y, sum_spin_nbr, sum_nbr_spin, n_sample
    integer(kind = 8) :: MC_step
    integer(kind = 8), intent(in) :: MC_max
    double precision, intent(in) :: T
    double precision, intent(out) :: avg_en, avg_en2, avg_mag
    double precision :: accept_prob, tot_en, tot_mag, tot_en2, tot_E, tot_M, tot_E2, sum_tot_E, sum_tot_M, sum_tot_E2
    double precision :: u, v, r

    n_sample = 0 ! Initialize variable to be used in averaging samples
    sum_tot_E = 0d0
    sum_tot_M = 0d0
    sum_tot_E2 = 0d0
    call compute_tot_E_M_E2(tot_en, tot_mag, tot_en2) ! Compute initial values of physical observables
    tot_E = tot_en
    tot_M = tot_mag
    tot_E2 = tot_en2
    do MC_step = 0, MC_max - 1
        call random_number(u) ! Return random real number in [0,1)
        call random_number(v)
        x = FLOOR(u * latt_leng) ! Pick random site, [0, latt_leng - 1]
        y = FLOOR(v * latt_leng)
        sum_nbr_spin = spin_of(x - 1, y) + spin_of(x + 1, y) + spin_of(x, y + 1) + spin_of(x, y - 1)
        accept_prob = accept_prob_chart((spin_of(x, y) * sum_nbr_spin)/2) ! Sigma(SS) = spin_of(x, y) * sum_surrounding = -4, -2 , 0, 2, 4
        call random_number(r) ![0, 1)
        if (r < accept_prob) then
            spin_of(x, y) = - spin_of(x, y) ! If random number < accept_prob => flip site

            if (x == 0) then ! Update padding sites
                spin_of(latt_leng, y) = spin_of(x, y)
            else if (x == latt_leng - 1) then
                spin_of(-1, y) = spin_of(x, y)
            end if
            if (y == 0) then
                spin_of(x, latt_leng) = spin_of(x, y)
            else if (y == latt_leng - 1) then
                spin_of(x, -1) = spin_of(x, y)
            end if

            tot_M = tot_M + 2*spin_of(x, y) ! Update physical observables
            sum_spin_nbr = spin_of(x + 1, y) + spin_of(x - 1, y) + spin_of(x, y + 1) + spin_of(x, y - 1)
            tot_E = tot_E + (- EXCH_CONST) * spin_of(x, y) * sum_spin_nbr
            tot_E2 = tot_E**2
        end if

        if (MC_step > MC_step / 2 .and. MOD(MC_step, latt_leng**2) == 0) then
            sum_tot_E = sum_tot_E + tot_E
            sum_tot_M = sum_tot_M + abs(tot_M) ! The value M can flip due to fluctuation
            sum_tot_E2 = sum_tot_E2 + tot_E2
            n_sample = n_sample + 1
        end if
    end do
    avg_en = sum_tot_E / real(n_sample, 8) / latt_leng**2 ! Ensemble average of E per site
    avg_mag = sum_tot_M / real(n_sample, 8) / latt_leng**2 ! Ensemble average of M per site
    avg_en2 = (sum_tot_E2 / real(n_sample, 8) / latt_leng**2 - latt_leng**2 * avg_en**2) / T**2 ! Ensemble average of Cv per site, Cv = (<E**2>-<E>**2)/T**2
end subroutine

subroutine compute_tot_E_M_E2(tot_E, tot_M, tot_E2)
    use parameters
    integer :: x, y, sum_spin_nbr
    double precision, intent(out) :: tot_E, tot_M, tot_E2

    tot_E = 0d0
    tot_M = 0d0
    tot_E2 = 0d0
    do x = 0, latt_leng - 1
        do y = 0, latt_leng - 1
            tot_M = tot_M + spin_of(x, y)
            sum_spin_nbr = spin_of(x + 1, y) + spin_of(x - 1, y) + spin_of(x, y + 1) + spin_of(x, y - 1)
            tot_E = tot_E + (- EXCH_CONST) * spin_of(x, y) * sum_spin_nbr
        end do
    end do
    tot_E = tot_E / 2
    tot_E2 = tot_E**2
end subroutine

subroutine compute_Tc_with_E_or_M(phys_obsv, Tc) ! Compute Tc by calculating T where dp_q / dT is max.
    use parameters
    integer :: T_step
    double precision :: max_slope, slope, del_T, T
    double precision, intent(out) :: Tc
    double precision, dimension(0 : n_T_step), intent(in) :: phys_obsv

    max_slope = 0d0
    slope = 0d0
    del_T = (T_end - T_start) / n_T_step
    do T_step = 0, n_T_step - 1
        T = T_start + del_T * T_step
        slope = (phys_obsv(T_step + 1) - phys_obsv(T_step)) / del_T
        if (slope > max_slope) then
            max_slope = slope
            Tc = T + 0.5*del_T
        end if
    end do
end subroutine

subroutine compute_Tc_with_Cv(Cv, Tc)
    use parameters
    integer :: T_step
    double precision :: max_value, del_T, T
    double precision, intent(out) :: Tc
    double precision, dimension(0 : n_T_step), intent(in) :: Cv

    max_value = 0d0
    del_T = (T_end - T_start) / n_T_step
    do T_step = 0, n_T_step
        T = T_start + del_T * T_step
        if (Cv(T_step) > max_value) then
            max_value = Cv(T_step)
            Tc = T
        end if
    end do
end subroutine

subroutine print_data(switch, phys_obsv, Tc)
    use parameters
    integer :: T_step
    integer, intent(in) :: switch
    double precision :: T, del_T
    double precision, intent(in) :: Tc
    double precision, dimension(0 : n_T_step), intent(in) :: phys_obsv

    del_T = (T_end - T_start) / n_T_step
    do T_step = 0, n_T_step
        T = T_start + del_T * T_step
        print *, "kT/J = ", T
        if (switch == 1) then
            print *, "<E> = ", phys_obsv(T_step)
        else if (switch == 2) then
            print *, "<M> = ", phys_obsv(T_step)
        else if (switch == 3) then
            print *, "<Cv> = ", phys_obsv(T_step)
        end if
        print *, "--------------"
    end do
    print *, "Tc  = ", Tc, " (kT/J)"
end subroutine

subroutine make_data_file(switch, phys_obsv, Tc)
    use parameters
    integer :: T_step
    integer, intent(in) :: switch
    integer, parameter :: out_unit1 = 10, out_unit2 = 20
    double precision :: del_T, T
    double precision, intent(in) :: Tc
    double precision, dimension(0 : n_T_step), intent(in) :: phys_obsv

    del_T = (T_end - T_start) / n_T_step
    if (switch == 1) then
        open (out_unit1, FILE = 'output_ising_model_avg_E_change.txt', action = "write", STATUS = 'replace')
    else if (switch == 2) then
        open (out_unit1, FILE = 'output_ising_model_avg_M_change.txt', action = "write", STATUS = 'replace')
    else if (switch == 3) then
        open (out_unit1, FILE = 'output_ising_model_avg_Cv_change.txt', action = "write", STATUS = 'replace')
    end if

    write (out_unit1,*) "T (kT/J) / avg_"
    if (switch == 1) then
        write (out_unit1,*)  "E (no units)"
    else if (switch == 2) then
        write (out_unit1,*)  "M (no units)"
    else if (switch == 3) then
        write (out_unit1,*)  "Cv (no units)"
    end if
    do T_step = 0, n_T_step
        T = T_start + del_T * T_step
        write (out_unit1,*) T, " ", phys_obsv(T_step)
    end do
    if (switch == 1) then
        write (out_unit1,*)  "Tc_computed_with_avg_E = ", Tc,  " (kT/J)"
    else if (switch == 2) then
        write (out_unit1,*)  "Tc_computed_with_avg_M = ", Tc,  " (kT/J)"
    else if (switch == 3) then
        write (out_unit1,*)  "Tc_computed_with_avg_Cv = ", Tc,  " (kT/J)"
    end if
    close(out_unit1)

    if (switch == 1) then
        open (out_unit2, FILE = 'output_ising_model_avg_E_change_plot.txt', action = "write", STATUS = 'replace')
    else if (switch == 2) then
        open (out_unit2, FILE = 'output_ising_model_avg_M_change_plot.txt', action = "write", STATUS = 'replace')
    else if (switch == 3) then
        open (out_unit2, FILE = 'output_ising_model_avg_Cv_change_plot.txt', action = "write", STATUS = 'replace')
    end if
    do T_step = 0, n_T_step
        T = T_start + del_T * T_step
        write (out_unit2,*) T, " ", phys_obsv(T_step)
    end do
    close(out_unit2)
end subroutine


!==============================================================================!
  subroutine Pressure_Matrix_Projection(grid, dt)
!------------------------------------------------------------------------------!
!   Forms the pressure system matrix for the fractional step method.           !
!------------------------------------------------------------------------------!
!----------------------------------[Modules]-----------------------------------!
  use Flow_Mod
  use Grid_Mod
!------------------------------------------------------------------------------!
  implicit none
!---------------------------------[Arguments]----------------------------------!
  type(Grid_Type) :: grid
  real            :: dt
!-----------------------------------[Locals]-----------------------------------!
  real    :: a12
  integer :: c, c1, c2, s
!==============================================================================!

  do c = 1, a % row(grid % n_cells+1)  ! this is number of nozero entries + 1
    a % val(c) = 0.0
  end do

  !-----------------------------!
  !   Calculate system matrix   !
  !-----------------------------!
  do s = 1, grid % n_faces

    c1 = grid % faces_c(1,s)
    c2 = grid % faces_c(2,s)

    if(c2 > 0) then
      a12 = dt * f_coef(s)
      a % val(a % pos(1,s)) = -a12
      a % val(a % pos(2,s)) = -a12
      a % val(a % dia(c1))  =              &
      a % val(a % dia(c1))  +  a12
      a % val(a % dia(c2))  =              &
      a % val(a % dia(c2))  +  a12
    end if

  end do ! through faces

  end subroutine


      SUBROUTINE CGGEVX( BALANC, JOBVL, JOBVR, SENSE, N, A, LDA, B, LDB,
     $                   ALPHA, BETA, VL, LDVL, VR, LDVR, ILO, IHI,
     $                   LSCALE, RSCALE, ABNRM, BBNRM, RCONDE, RCONDV,
     $                   WORK, LWORK, RWORK, IWORK, BWORK, INFO )
*
*  -- LAPACK driver routine (version 3.0) --
*     Univ. of Tennessee, Univ. of California Berkeley, NAG Ltd.,
*     Courant Institute, Argonne National Lab, and Rice University
*     June 30, 1999
*
*     .. Scalar Arguments ..
      CHARACTER          BALANC, JOBVL, JOBVR, SENSE
      INTEGER            IHI, ILO, INFO, LDA, LDB, LDVL, LDVR, LWORK, N
      REAL               ABNRM, BBNRM
*     ..
*     .. Array Arguments ..
      LOGICAL            BWORK( * )
      INTEGER            IWORK( * )
      REAL               LSCALE( * ), RCONDE( * ), RCONDV( * ),
     $                   RSCALE( * ), RWORK( * )
      COMPLEX            A( LDA, * ), ALPHA( * ), B( LDB, * ),
     $                   BETA( * ), VL( LDVL, * ), VR( LDVR, * ),
     $                   WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  CGGEVX computes for a pair of N-by-N complex nonsymmetric matrices
*  (A,B) the generalized eigenvalues, and optionally, the left and/or
*  right generalized eigenvectors.
*
*  Optionally, it also computes a balancing transformation to improve
*  the conditioning of the eigenvalues and eigenvectors (ILO, IHI,
*  LSCALE, RSCALE, ABNRM, and BBNRM), reciprocal condition numbers for
*  the eigenvalues (RCONDE), and reciprocal condition numbers for the
*  right eigenvectors (RCONDV).
*
*  A generalized eigenvalue for a pair of matrices (A,B) is a scalar
*  lambda or a ratio alpha/beta = lambda, such that A - lambda*B is
*  singular. It is usually represented as the pair (alpha,beta), as
*  there is a reasonable interpretation for beta=0, and even for both
*  being zero.
*
*  The right eigenvector v(j) corresponding to the eigenvalue lambda(j)
*  of (A,B) satisfies
*                   A * v(j) = lambda(j) * B * v(j) .
*  The left eigenvector u(j) corresponding to the eigenvalue lambda(j)
*  of (A,B) satisfies
*                   u(j)**H * A  = lambda(j) * u(j)**H * B.
*  where u(j)**H is the conjugate-transpose of u(j).
*
*
*  Arguments
*  =========
*
*  BALANC  (input) CHARACTER*1
*          Specifies the balance option to be performed:
*          = 'N':  do not diagonally scale or permute;
*          = 'P':  permute only;
*          = 'S':  scale only;
*          = 'B':  both permute and scale.
*          Computed reciprocal condition numbers will be for the
*          matrices after permuting and/or balancing. Permuting does
*          not change condition numbers (in exact arithmetic), but
*          balancing does.
*
*  JOBVL   (input) CHARACTER*1
*          = 'N':  do not compute the left generalized eigenvectors;
*          = 'V':  compute the left generalized eigenvectors.
*
*  JOBVR   (input) CHARACTER*1
*          = 'N':  do not compute the right generalized eigenvectors;
*          = 'V':  compute the right generalized eigenvectors.
*
*  SENSE   (input) CHARACTER*1
*          Determines which reciprocal condition numbers are computed.
*          = 'N': none are computed;
*          = 'E': computed for eigenvalues only;
*          = 'V': computed for eigenvectors only;
*          = 'B': computed for eigenvalues and eigenvectors.
*
*  N       (input) INTEGER
*          The order of the matrices A, B, VL, and VR.  N >= 0.
*
*  A       (input/output) COMPLEX array, dimension (LDA, N)
*          On entry, the matrix A in the pair (A,B).
*          On exit, A has been overwritten. If JOBVL='V' or JOBVR='V'
*          or both, then A contains the first part of the complex Schur
*          form of the "balanced" versions of the input A and B.
*
*  LDA     (input) INTEGER
*          The leading dimension of A.  LDA >= max(1,N).
*
*  B       (input/output) COMPLEX array, dimension (LDB, N)
*          On entry, the matrix B in the pair (A,B).
*          On exit, B has been overwritten. If JOBVL='V' or JOBVR='V'
*          or both, then B contains the second part of the complex
*          Schur form of the "balanced" versions of the input A and B.
*
*  LDB     (input) INTEGER
*          The leading dimension of B.  LDB >= max(1,N).
*
*  ALPHA   (output) COMPLEX array, dimension (N)
*  BETA    (output) COMPLEX array, dimension (N)
*          On exit, ALPHA(j)/BETA(j), j=1,...,N, will be the generalized
*          eigenvalues.
*
*          Note: the quotient ALPHA(j)/BETA(j) ) may easily over- or
*          underflow, and BETA(j) may even be zero.  Thus, the user
*          should avoid naively computing the ratio ALPHA/BETA.
*          However, ALPHA will be always less than and usually
*          comparable with norm(A) in magnitude, and BETA always less
*          than and usually comparable with norm(B).
*
*  VL      (output) COMPLEX array, dimension (LDVL,N)
*          If JOBVL = 'V', the left generalized eigenvectors u(j) are
*          stored one after another in the columns of VL, in the same
*          order as their eigenvalues.
*          Each eigenvector will be scaled so the largest component
*          will have abs(real part) + abs(imag. part) = 1.
*          Not referenced if JOBVL = 'N'.
*
*  LDVL    (input) INTEGER
*          The leading dimension of the matrix VL. LDVL >= 1, and
*          if JOBVL = 'V', LDVL >= N.
*
*  VR      (output) COMPLEX array, dimension (LDVR,N)
*          If JOBVR = 'V', the right generalized eigenvectors v(j) are
*          stored one after another in the columns of VR, in the same
*          order as their eigenvalues.
*          Each eigenvector will be scaled so the largest component
*          will have abs(real part) + abs(imag. part) = 1.
*          Not referenced if JOBVR = 'N'.
*
*  LDVR    (input) INTEGER
*          The leading dimension of the matrix VR. LDVR >= 1, and
*          if JOBVR = 'V', LDVR >= N.
*
*  ILO,IHI (output) INTEGER
*          ILO and IHI are integer values such that on exit
*          A(i,j) = 0 and B(i,j) = 0 if i > j and
*          j = 1,...,ILO-1 or i = IHI+1,...,N.
*          If BALANC = 'N' or 'S', ILO = 1 and IHI = N.
*
*  LSCALE  (output) REAL array, dimension (N)
*          Details of the permutations and scaling factors applied
*          to the left side of A and B.  If PL(j) is the index of the
*          row interchanged with row j, and DL(j) is the scaling
*          factor applied to row j, then
*            LSCALE(j) = PL(j)  for j = 1,...,ILO-1
*                      = DL(j)  for j = ILO,...,IHI
*                      = PL(j)  for j = IHI+1,...,N.
*          The order in which the interchanges are made is N to IHI+1,
*          then 1 to ILO-1.
*
*  RSCALE  (output) REAL array, dimension (N)
*          Details of the permutations and scaling factors applied
*          to the right side of A and B.  If PR(j) is the index of the
*          column interchanged with column j, and DR(j) is the scaling
*          factor applied to column j, then
*            RSCALE(j) = PR(j)  for j = 1,...,ILO-1
*                      = DR(j)  for j = ILO,...,IHI
*                      = PR(j)  for j = IHI+1,...,N
*          The order in which the interchanges are made is N to IHI+1,
*          then 1 to ILO-1.
*
*  ABNRM   (output) REAL
*          The one-norm of the balanced matrix A.
*
*  BBNRM   (output) REAL
*          The one-norm of the balanced matrix B.
*
*  RCONDE  (output) REAL array, dimension (N)
*          If SENSE = 'E' or 'B', the reciprocal condition numbers of
*          the selected eigenvalues, stored in consecutive elements of
*          the array.
*          If SENSE = 'V', RCONDE is not referenced.
*
*  RCONDV  (output) REAL array, dimension (N)
*          If JOB = 'V' or 'B', the estimated reciprocal condition
*          numbers of the selected eigenvectors, stored in consecutive
*          elements of the array. If the eigenvalues cannot be reordered
*          to compute RCONDV(j), RCONDV(j) is set to 0; this can only
*          occur when the true value would be very small anyway.
*          If SENSE = 'E', RCONDV is not referenced.
*          Not referenced if JOB = 'E'.
*
*  WORK    (workspace/output) COMPLEX array, dimension (LWORK)
*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK. LWORK >= max(1,2*N).
*          If SENSE = 'N' or 'E', LWORK >= 2*N.
*          If SENSE = 'V' or 'B', LWORK >= 2*N*N+2*N.
*
*          If LWORK = -1, then a workspace query is assumed; the routine
*          only calculates the optimal size of the WORK array, returns
*          this value as the first entry of the WORK array, and no error
*          message related to LWORK is issued by XERBLA.
*
*  RWORK   (workspace) REAL array, dimension (6*N)
*          Real workspace.
*
*  IWORK   (workspace) INTEGER array, dimension (N+2)
*          If SENSE = 'E', IWORK is not referenced.
*
*  BWORK   (workspace) LOGICAL array, dimension (N)
*          If SENSE = 'N', BWORK is not referenced.
*
*  INFO    (output) INTEGER
*          = 0:  successful exit
*          < 0:  if INFO = -i, the i-th argument had an illegal value.
*          = 1,...,N:
*                The QZ iteration failed.  No eigenvectors have been
*                calculated, but ALPHA(j) and BETA(j) should be correct
*                for j=INFO+1,...,N.
*          > N:  =N+1: other than QZ iteration failed in CHGEQZ.
*                =N+2: error return from CTGEVC.
*
*  Further Details
*  ===============
*
*  Balancing a matrix pair (A,B) includes, first, permuting rows and
*  columns to isolate eigenvalues, second, applying diagonal similarity
*  transformation to the rows and columns to make the rows and columns
*  as close in norm as possible. The computed reciprocal condition
*  numbers correspond to the balanced matrix. Permuting rows and columns
*  will not change the condition numbers (in exact arithmetic) but
*  diagonal scaling will.  For further explanation of balancing, see
*  section 4.11.1.2 of LAPACK Users' Guide.
*
*  An approximate error bound on the chordal distance between the i-th
*  computed generalized eigenvalue w and the corresponding exact
*  eigenvalue lambda is
*
*       chord(w, lambda) <= EPS * norm(ABNRM, BBNRM) / RCONDE(I)
*
*  An approximate error bound for the angle between the i-th computed
*  eigenvector VL(i) or VR(i) is given by
*
*       EPS * norm(ABNRM, BBNRM) / DIF(i).
*
*  For further explanation of the reciprocal condition numbers RCONDE
*  and RCONDV, see section 4.11 of LAPACK User's Guide.
*
*  =====================================================================
*
*     .. Parameters ..
      REAL               ZERO, ONE
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0 )
      COMPLEX            CZERO, CONE
      PARAMETER          ( CZERO = ( 0.0E+0, 0.0E+0 ),
     $                   CONE = ( 1.0E+0, 0.0E+0 ) )
*     ..
*     .. Local Scalars ..
      LOGICAL            ILASCL, ILBSCL, ILV, ILVL, ILVR, LQUERY,
     $                   WANTSB, WANTSE, WANTSN, WANTSV
      CHARACTER          CHTEMP
      INTEGER            I, ICOLS, IERR, IJOBVL, IJOBVR, IN, IROWS,
     $                   ITAU, IWRK, IWRK1, J, JC, JR, M, MAXWRK, MINWRK
      REAL               ANRM, ANRMTO, BIGNUM, BNRM, BNRMTO, EPS,
     $                   SMLNUM, TEMP
      COMPLEX            X
*     ..
*     .. Local Arrays ..
      LOGICAL            LDUMMA( 1 )
*     ..
*     .. External Subroutines ..
      EXTERNAL           CGEQRF, CGGBAK, CGGBAL, CGGHRD, CHGEQZ, CLACPY,
     $                   CLASCL, CLASET, CTGEVC, CTGSNA, CUNGQR, CUNMQR,
     $                   SLABAD, SLASCL, XERBLA
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      INTEGER            ILAENV
      REAL               CLANGE, SLAMCH
      EXTERNAL           LSAME, ILAENV, CLANGE, SLAMCH
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, AIMAG, MAX, REAL, SQRT
*     ..
*     .. Statement Functions ..
      REAL               ABS1
*     ..
*     .. Statement Function definitions ..
      ABS1( X ) = ABS( REAL( X ) ) + ABS( AIMAG( X ) )
*     ..
*     .. Executable Statements ..
*
*     Decode the input arguments
*
      IF( LSAME( JOBVL, 'N' ) ) THEN
         IJOBVL = 1
         ILVL = .FALSE.
      ELSE IF( LSAME( JOBVL, 'V' ) ) THEN
         IJOBVL = 2
         ILVL = .TRUE.
      ELSE
         IJOBVL = -1
         ILVL = .FALSE.
      END IF
*
      IF( LSAME( JOBVR, 'N' ) ) THEN
         IJOBVR = 1
         ILVR = .FALSE.
      ELSE IF( LSAME( JOBVR, 'V' ) ) THEN
         IJOBVR = 2
         ILVR = .TRUE.
      ELSE
         IJOBVR = -1
         ILVR = .FALSE.
      END IF
      ILV = ILVL .OR. ILVR
*
      WANTSN = LSAME( SENSE, 'N' )
      WANTSE = LSAME( SENSE, 'E' )
      WANTSV = LSAME( SENSE, 'V' )
      WANTSB = LSAME( SENSE, 'B' )
*
*     Test the input arguments
*
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
      IF( .NOT.( LSAME( BALANC, 'N' ) .OR. LSAME( BALANC,
     $    'S' ) .OR. LSAME( BALANC, 'P' ) .OR. LSAME( BALANC, 'B' ) ) )
     $     THEN
         INFO = -1
      ELSE IF( IJOBVL.LE.0 ) THEN
         INFO = -2
      ELSE IF( IJOBVR.LE.0 ) THEN
         INFO = -3
      ELSE IF( .NOT.( WANTSN .OR. WANTSE .OR. WANTSB .OR. WANTSV ) )
     $          THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDVL.LT.1 .OR. ( ILVL .AND. LDVL.LT.N ) ) THEN
         INFO = -13
      ELSE IF( LDVR.LT.1 .OR. ( ILVR .AND. LDVR.LT.N ) ) THEN
         INFO = -15
      END IF
*
*     Compute workspace
*      (Note: Comments in the code beginning "Workspace:" describe the
*       minimal amount of workspace needed at that point in the code,
*       as well as the preferred amount for good performance.
*       NB refers to the optimal block size for the immediately
*       following subroutine, as returned by ILAENV. The workspace is
*       computed assuming ILO = 1 and IHI = N, the worst case.)
*
      MINWRK = 1
      IF( INFO.EQ.0 .AND. ( LWORK.GE.1 .OR. LQUERY ) ) THEN
         MAXWRK = N + N*ILAENV( 1, 'CGEQRF', ' ', N, 1, N, 0 )
         IF( WANTSE ) THEN
            MINWRK = MAX( 1, 2*N )
         ELSE IF( WANTSV .OR. WANTSB ) THEN
            MINWRK = 2*N*N + 2*N
            MAXWRK = MAX( MAXWRK, 2*N*N+2*N )
         END IF
         WORK( 1 ) = MAXWRK
      END IF
*
      IF( LWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
         INFO = -25
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'CGGEVX', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Get machine constants
*
      EPS = SLAMCH( 'P' )
      SMLNUM = SLAMCH( 'S' )
      BIGNUM = ONE / SMLNUM
      CALL SLABAD( SMLNUM, BIGNUM )
      SMLNUM = SQRT( SMLNUM ) / EPS
      BIGNUM = ONE / SMLNUM
*
*     Scale A if max element outside range [SMLNUM,BIGNUM]
*
      ANRM = CLANGE( 'M', N, N, A, LDA, RWORK )
      ILASCL = .FALSE.
      IF( ANRM.GT.ZERO .AND. ANRM.LT.SMLNUM ) THEN
         ANRMTO = SMLNUM
         ILASCL = .TRUE.
      ELSE IF( ANRM.GT.BIGNUM ) THEN
         ANRMTO = BIGNUM
         ILASCL = .TRUE.
      END IF
      IF( ILASCL )
     $   CALL CLASCL( 'G', 0, 0, ANRM, ANRMTO, N, N, A, LDA, IERR )
*
*     Scale B if max element outside range [SMLNUM,BIGNUM]
*
      BNRM = CLANGE( 'M', N, N, B, LDB, RWORK )
      ILBSCL = .FALSE.
      IF( BNRM.GT.ZERO .AND. BNRM.LT.SMLNUM ) THEN
         BNRMTO = SMLNUM
         ILBSCL = .TRUE.
      ELSE IF( BNRM.GT.BIGNUM ) THEN
         BNRMTO = BIGNUM
         ILBSCL = .TRUE.
      END IF
      IF( ILBSCL )
     $   CALL CLASCL( 'G', 0, 0, BNRM, BNRMTO, N, N, B, LDB, IERR )
*
*     Permute and/or balance the matrix pair (A,B)
*     (Real Workspace: need 6*N)
*
      CALL CGGBAL( BALANC, N, A, LDA, B, LDB, ILO, IHI, LSCALE, RSCALE,
     $             RWORK, IERR )
*
*     Compute ABNRM and BBNRM
*
      ABNRM = CLANGE( '1', N, N, A, LDA, RWORK( 1 ) )
      IF( ILASCL ) THEN
         RWORK( 1 ) = ABNRM
         CALL SLASCL( 'G', 0, 0, ANRMTO, ANRM, 1, 1, RWORK( 1 ), 1,
     $                IERR )
         ABNRM = RWORK( 1 )
      END IF
*
      BBNRM = CLANGE( '1', N, N, B, LDB, RWORK( 1 ) )
      IF( ILBSCL ) THEN
         RWORK( 1 ) = BBNRM
         CALL SLASCL( 'G', 0, 0, BNRMTO, BNRM, 1, 1, RWORK( 1 ), 1,
     $                IERR )
         BBNRM = RWORK( 1 )
      END IF
*
*     Reduce B to triangular form (QR decomposition of B)
*     (Complex Workspace: need N, prefer N*NB )
*
      IROWS = IHI + 1 - ILO
      IF( ILV .OR. .NOT.WANTSN ) THEN
         ICOLS = N + 1 - ILO
      ELSE
         ICOLS = IROWS
      END IF
      ITAU = 1
      IWRK = ITAU + IROWS
      CALL CGEQRF( IROWS, ICOLS, B( ILO, ILO ), LDB, WORK( ITAU ),
     $             WORK( IWRK ), LWORK+1-IWRK, IERR )
*
*     Apply the unitary transformation to A
*     (Complex Workspace: need N, prefer N*NB)
*
      CALL CUNMQR( 'L', 'C', IROWS, ICOLS, IROWS, B( ILO, ILO ), LDB,
     $             WORK( ITAU ), A( ILO, ILO ), LDA, WORK( IWRK ),
     $             LWORK+1-IWRK, IERR )
*
*     Initialize VL and/or VR
*     (Workspace: need N, prefer N*NB)
*
      IF( ILVL ) THEN
         CALL CLASET( 'Full', N, N, CZERO, CONE, VL, LDVL )
         CALL CLACPY( 'L', IROWS-1, IROWS-1, B( ILO+1, ILO ), LDB,
     $                VL( ILO+1, ILO ), LDVL )
         CALL CUNGQR( IROWS, IROWS, IROWS, VL( ILO, ILO ), LDVL,
     $                WORK( ITAU ), WORK( IWRK ), LWORK+1-IWRK, IERR )
      END IF
*
      IF( ILVR )
     $   CALL CLASET( 'Full', N, N, CZERO, CONE, VR, LDVR )
*
*     Reduce to generalized Hessenberg form
*     (Workspace: none needed)
*
      IF( ILV .OR. .NOT.WANTSN ) THEN
*
*        Eigenvectors requested -- work on whole matrix.
*
         CALL CGGHRD( JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB, VL,
     $                LDVL, VR, LDVR, IERR )
      ELSE
         CALL CGGHRD( 'N', 'N', IROWS, 1, IROWS, A( ILO, ILO ), LDA,
     $                B( ILO, ILO ), LDB, VL, LDVL, VR, LDVR, IERR )
      END IF
*
*     Perform QZ algorithm (Compute eigenvalues, and optionally, the
*     Schur forms and Schur vectors)
*     (Complex Workspace: need N)
*     (Real Workspace: need N)
*
      IWRK = ITAU
      IF( ILV .OR. .NOT.WANTSN ) THEN
         CHTEMP = 'S'
      ELSE
         CHTEMP = 'E'
      END IF
*
      CALL CHGEQZ( CHTEMP, JOBVL, JOBVR, N, ILO, IHI, A, LDA, B, LDB,
     $             ALPHA, BETA, VL, LDVL, VR, LDVR, WORK( IWRK ),
     $             LWORK+1-IWRK, RWORK, IERR )
      IF( IERR.NE.0 ) THEN
         IF( IERR.GT.0 .AND. IERR.LE.N ) THEN
            INFO = IERR
         ELSE IF( IERR.GT.N .AND. IERR.LE.2*N ) THEN
            INFO = IERR - N
         ELSE
            INFO = N + 1
         END IF
         GO TO 90
      END IF
*
*     Compute Eigenvectors and estimate condition numbers if desired
*     CTGEVC: (Complex Workspace: need 2*N )
*             (Real Workspace:    need 2*N )
*     CTGSNA: (Complex Workspace: need 2*N*N if SENSE='V' or 'B')
*             (Integer Workspace: need N+2 )
*
      IF( ILV .OR. .NOT.WANTSN ) THEN
         IF( ILV ) THEN
            IF( ILVL ) THEN
               IF( ILVR ) THEN
                  CHTEMP = 'B'
               ELSE
                  CHTEMP = 'L'
               END IF
            ELSE
               CHTEMP = 'R'
            END IF
*
            CALL CTGEVC( CHTEMP, 'B', LDUMMA, N, A, LDA, B, LDB, VL,
     $                   LDVL, VR, LDVR, N, IN, WORK( IWRK ), RWORK,
     $                   IERR )
            IF( IERR.NE.0 ) THEN
               INFO = N + 2
               GO TO 90
            END IF
         END IF
*
         IF( .NOT.WANTSN ) THEN
*
*           compute eigenvectors (STGEVC) and estimate condition
*           numbers (STGSNA). Note that the definition of the condition
*           number is not invariant under transformation (u,v) to
*           (Q*u, Z*v), where (u,v) are eigenvectors of the generalized
*           Schur form (S,T), Q and Z are orthogonal matrices. In order
*           to avoid using extra 2*N*N workspace, we have to
*           re-calculate eigenvectors and estimate the condition numbers
*           one at a time.
*
            DO 20 I = 1, N
*
               DO 10 J = 1, N
                  BWORK( J ) = .FALSE.
   10          CONTINUE
               BWORK( I ) = .TRUE.
*
               IWRK = N + 1
               IWRK1 = IWRK + N
*
               IF( WANTSE .OR. WANTSB ) THEN
                  CALL CTGEVC( 'B', 'S', BWORK, N, A, LDA, B, LDB,
     $                         WORK( 1 ), N, WORK( IWRK ), N, 1, M,
     $                         WORK( IWRK1 ), RWORK, IERR )
                  IF( IERR.NE.0 ) THEN
                     INFO = N + 2
                     GO TO 90
                  END IF
               END IF
*
               CALL CTGSNA( SENSE, 'S', BWORK, N, A, LDA, B, LDB,
     $                      WORK( 1 ), N, WORK( IWRK ), N, RCONDE( I ),
     $                      RCONDV( I ), 1, M, WORK( IWRK1 ),
     $                      LWORK-IWRK1+1, IWORK, IERR )
*
   20       CONTINUE
         END IF
      END IF
*
*     Undo balancing on VL and VR and normalization
*     (Workspace: none needed)
*
      IF( ILVL ) THEN
         CALL CGGBAK( BALANC, 'L', N, ILO, IHI, LSCALE, RSCALE, N, VL,
     $                LDVL, IERR )
*
         DO 50 JC = 1, N
            TEMP = ZERO
            DO 30 JR = 1, N
               TEMP = MAX( TEMP, ABS1( VL( JR, JC ) ) )
   30       CONTINUE
            IF( TEMP.LT.SMLNUM )
     $         GO TO 50
            TEMP = ONE / TEMP
            DO 40 JR = 1, N
               VL( JR, JC ) = VL( JR, JC )*TEMP
   40       CONTINUE
   50    CONTINUE
      END IF
*
      IF( ILVR ) THEN
         CALL CGGBAK( BALANC, 'R', N, ILO, IHI, LSCALE, RSCALE, N, VR,
     $                LDVR, IERR )
         DO 80 JC = 1, N
            TEMP = ZERO
            DO 60 JR = 1, N
               TEMP = MAX( TEMP, ABS1( VR( JR, JC ) ) )
   60       CONTINUE
            IF( TEMP.LT.SMLNUM )
     $         GO TO 80
            TEMP = ONE / TEMP
            DO 70 JR = 1, N
               VR( JR, JC ) = VR( JR, JC )*TEMP
   70       CONTINUE
   80    CONTINUE
      END IF
*
*     Undo scaling if necessary
*
      IF( ILASCL )
     $   CALL CLASCL( 'G', 0, 0, ANRMTO, ANRM, N, 1, ALPHA, N, IERR )
*
      IF( ILBSCL )
     $   CALL CLASCL( 'G', 0, 0, BNRMTO, BNRM, N, 1, BETA, N, IERR )
*
   90 CONTINUE
      WORK( 1 ) = MAXWRK
*
      RETURN
*
*     End of CGGEVX
*
      END


program main
    use iso_c_binding
    implicit none
    include "fftw3.f03" ! FFTW3 est une librairie. Voir www.fftw.org
    integer :: nx, nfft
    integer, parameter :: nxmax=256
    integer, parameter :: mykind=c_double
    real(mykind), pointer, contiguous :: tablein(:,:,:)
    real(c_double) :: t0,t1
    complex(mykind), pointer, contiguous :: tableout(:,:,:)
    type(c_ptr) :: fftwplan
    real(mykind), target :: bigin(nxmax,nxmax,nxmax)
    complex(mykind), target :: bigout(nxmax/2+1,nxmax,nxmax)
    integer :: i
    open(11,file='planingtime')
    open(10,file='ffttime')
    ! look at http://www.fftw.org/doc/Planner-Flags.html
    do nx=2,nxmax ! size of the fft in each direction
        print*,"n=",nx ! size of the fft in each direction
        tablein => bigin(1:nx,1:nx,1:nx)
        tableout => bigout(1:nx,1:nx,1:nx)
        tablein = 0.
        tableout=cmplx(0.,0.)
        call cpu_time(t0) ! timing the planer
        call dfftw_plan_dft_r2c_3d( fftwplan, nx, nx, nx, tablein, tableout, FFTW_ESTIMATE) ! see http://www.fftw.org/doc/Planner-Flags.html
        call cpu_time(t1)
        print*,"It took me",t1-t0,"seconds to optimize FFTW3 to your hardware for this kind of real to complex."
        write(11,*) nx, t1-t0
        tablein = 0
        tableout = 0
        call cpu_time(t0)
        nfft = 10
        print*,"C'est parti pour",nfft," FFT de reel à complex de",nx,"^3"
        do i=1,nfft
            call dfftw_execute( fftwplan )
        end do
        call cpu_time(t1)
        print*,"It took me",(t1-t0)/real(nfft,c_double),"seconds per FFT real to complex of size",nx,"^3"
        print*,
        write(10,*) nx, (t1-t0)/real(nfft,c_double)
        call dfftw_destroy_plan( fftwplan )
    end do
end program main


! this module implements the F.R. de Hoog, J.H. Knight, and A.N. Stokes
! numerical inverse Laplace transform algorithm.
! see "An improved method for numerical inversion of Laplace
!     transforms", SIAM J. Sci. Stat. Comp., 3, 357-366, 1982.

module invlaptrans

contains

    function invlap2( t, tmin, tmax, fp, M, gamma, N ) result (ft)

        real(kind=8), intent(in), dimension(N) :: t   ! vector of times
        real(kind=8), intent(in) :: tmin, tmax
        complex(kind=8), intent(in), dimension(0:2*M) :: fp
        integer, intent(in) :: M, N
        real(kind=8), intent(in) :: gamma
        real(kind=8), dimension(N) :: ft

        ft(:) = 3.d0

    end function invlap2

    function invlap( t, tmin, tmax, fp, M, gamma, Nt ) result (ft)

        real(kind=8), intent(in), dimension(Nt) :: t   ! vector of times
        real(kind=8), intent(in) :: tmin, tmax
        complex(kind=8), intent(in), dimension(0:2*M) :: fp
        integer, intent(in) :: M, Nt
        real(kind=8), intent(in) :: gamma
        real(kind=8), dimension(Nt) :: ft

        complex(kind=8), dimension(0:2*M,0:M) :: e
        complex(kind=8), dimension(0:2*M-1,0:M) :: q  ! column 0 is not used
        complex(kind=8), dimension(0:2*M) :: d
        complex(kind=8), dimension(0:2*M+1,Nt) :: A,B
        complex(kind=8), dimension(Nt) :: z,h2M,R2Mz
        integer :: r, rq, n, M
        real(kind=8) :: pi, bigt

        pi = 3.1415926535897931d0
        bigt = 2.d0 * tmax

        !a[0] = a[0] / 2.0  # zero term is halved

        ! build up e and q tables. superscript is now row index, subscript column
        e(:,:) = cmplx(0.d0,0.d0,kind=8)
        q(:,:) = cmplx(0.d0,0.d0,kind=8)
        q(0,1) = fp(1)/(fp(0)/2.0) ! half first term
        q(1:2*M-1,1) = fp(2:2*M) / fp(1:2*M-1)
        !q(:,1) = fp(1:2*M) / fp(0:2*M-1)

        do r = 1,M  ! step through columns
            e(0:2*(M-r+1)-2,r) = q(1:2*(M-r+1)-1,r) - q(0:2*(M-r+1)-2,r) + e(1:2*(M-r+1)-1,r-1)
            if (r < M) then  ! one column fewer for q
                rq = r+1
                q(0:2*(M-rq+1)-1,rq) = q(1:2*(M-rq+1),rq-1) * e(1:2*(M-rq+1),rq-1) / e(0:2*(M-rq+1)-1,rq-1)
            endif
        end do

        ! build up d vector (index shift: 1)
        d(:) = cmplx(0.d0,0.d0,kind=8)
        d(0) = fp(0)/2.0 ! half first term
        d(1:2*M-1:2) = -q(0,1:M) ! these 2 lines changed after niclas
        d(2:2*M:2) = -e(0,1:M)

        ! build A and B vectors (Hollenbeck claims an index shift of 2, but that may be related to the matlab code)
        ! now make into matrices, one row for each time
        A(:,:) = cmplx(0.d0,0.d0,kind=8)
        B(:,:) = cmplx(0.d0,0.d0,kind=8)
        A(1,:) = d(0)
        B(0:1,:) = cmplx(1.d0,0.d0,kind=8)

        z = exp( cmplx(0.d0,1.d0,kind=8) * pi * t / bigt )
        ! after niclas back to the paper (not: z = exp(-i*pi*t/T))
        do n = 2, 2*M+1
            A(n,:) = A(n-1,:) + d(n-1) * z * A(n-2,:)  ! different index
            B(n,:) = B(n-1,:) + d(n-1) * z * B(n-2,:)  ! shift for d!
        end do

        ! double acceleration
        h2M = 0.5d0 * ( 1.d0 + ( d(2*M-1) -d(2*M) ) * z )
        R2Mz = -h2M * ( 1.d0 - sqrt( 1.d0 + d(2*M) * z / h2M**2 ) )

        A(2*M+1,:) = A(2*M,:) + R2Mz * A(2*M-1,:)
        B(2*M+1,:) = B(2*M,:) + R2Mz * B(2*M-1,:)

        ! inversion
        ft = ( 1.d0/bigt * exp(gamma*t) * real( A(2*M+1,:) / B(2*M+1,:) ) )

    end function invlap

end module invlaptrans

program invlaptest
    use invlaptrans
    implicit none

    real(kind=8) :: tmin, tmax, alpha, tol, bigt, gamma, pi
    real(kind=8), dimension(3) :: t, ft
    real(kind=8), dimension(0:40) :: run
    complex(kind=8), dimension(0:40) :: p, a
    integer :: M, i, Nt

    pi = 3.1415926535897931d0
    M = 20
    Nt = 3
    t(1) = 1.d0; t(2) = 2.d0; t(3) = 3.d0
    tmin = 1.d0
    tmax = 3.d0
    alpha = 0.d0
    tol = 1.d-9
    do i=0,2*M
        run(i) = float(i)
    end do
    bigt = 2.d0 * tmax
    gamma = alpha - log(tol) / (bigt/2.d0)
    p(:) = gamma + cmplx(0.d0,1.d0,kind=8) * pi * run(:) / bigt
    !print *,p
    a = 1.d0 / p**2
    !a(0) = a(0) / 2.d0
    ft = invlap( t, tmin, tmax, a, M, gamma, Nt )
    print *,'ft ',ft

end