module normal_rand
implicit none

contains

function r8_uniform_01 ( seed )

  implicit none

  integer ( kind = 4 ) k
  real ( kind = 8 ) r8_uniform_01
  integer ( kind = 4 ) seed

  k = seed / 127773

  seed = 16807 * ( seed - k * 127773 ) - k * 2836

  if ( seed < 0 ) then
    seed = seed + 2147483647
  end if
!
!  Although SEED can be represented exactly as a 32 bit integer,
!  it generally cannot be represented exactly as a 32 bit real number!
!
  r8_uniform_01 = real ( seed, kind = 8 ) * 4.656612875D-10

  return
end function r8_uniform_01

  function r8_normal_ab ( a, b, seed )

!*****************************************************************************80
!
!! R8_NORMAL_AB returns a scaled pseudonormal R8.
!
!  Discussion:
!
!    The normal probability distribution function (PDF) is sampled,
!    with mean A and standard deviation B.
!
  implicit none

  real ( kind = 8 ) a
  real ( kind = 8 ) b
  real ( kind = 8 ) r1
  real ( kind = 8 ) r2
  real ( kind = 8 ) r8_normal_ab
  real ( kind = 8 ), parameter :: r8_pi = 3.141592653589793D+00
  real ( kind = 8 ) r8_uniform_01
  integer ( kind = 4 ) seed
  real ( kind = 8 ) x

  r1 = r8_uniform_01 ( seed )
  r2 = r8_uniform_01 ( seed )
  x = sqrt ( - 2.0D+00 * log ( r1 ) ) * cos ( 2.0D+00 * r8_pi * r2 )

  r8_normal_ab = a + b * x

  return
  end function r8_normal_ab

end program


program betaPlaneGaussian

use NumberKindsModule
use UtilitiesModule
use OutputWriterModule
use LoggerModule
use ParticlesModule
use EdgesModule
use FacesModule
use PolyMesh2dModule
use FieldModule
use MPISetupModule
use PlaneGeomModule
use BetaPlaneMeshModule
use BetaPlaneSolverModule
use RefinementModule
use BIVARRemeshModule

implicit none

include 'mpif.h'

! mesh variables
type(BetaPlaneMesh) :: betaPlane
integer(kint) :: initNest
integer(kint) :: maxNest
integer(kint) :: amrLimit
real(kreal) :: lat0
real(kreal) :: rotationRate

! AMR variables
type(RefineSetup) :: refinement
logical(klog) :: AMR
integer(kint) :: nParticlesBefore
integer(kint) :: nParticlesAfter

namelist /meshDefine/ initNest, amrLimit, maxNest, lat0, rotationRate

! test case variables
real(kreal), allocatable, dimension(:) :: kineticEnergy, enstrophy
real(kreal) :: shapeParam
real(kreal) :: vorticityMax
real(kreal), parameter :: vortInitX = 0.5_kreal
real(kreal) :: vortInitY
real(kreal) :: flowMapVarTol
real(kreal) :: circulationTol
namelist /gaussVort/ shapeParam, vorticityMax, vortInitY, flowMapVarTol, circulationTol

! remeshing
integer(kint) :: remeshInterval
type(BetaPlaneMesh) :: tempMesh

! timestepping
type(BetaPlaneSolver) :: solver
real(kreal) :: dt
real(kreal) :: t
real(kreal) :: tfinal
integer(kint) :: nTimesteps
integer(kint) :: timeJ
namelist /timestepping/ dt, tfinal, remeshInterval

! i/o
character(len=MAX_STRING_LENGTH) :: outputDir
character(len=MAX_STRING_LENGTH) :: outputRoot
character(len=MAX_STRING_LENGTH) :: vtkFile
character(len=MAX_STRING_LENGTH) :: matlabFile
character(len=MAX_STRING_LENGTH) :: vtkRoot
character(len=MAX_STRING_LENGTH) :: meshString
integer(kint) :: frameOut
integer(kint) :: frameCounter
namelist /fileIO/ outputDir, outputRoot, frameOut

! computing environment / general
type(Logger) :: exeLog
character(len=MAX_STRING_LENGTH) :: logString
integer(kint), parameter :: logLevel = DEBUG_LOGGING_LEVEL
character(len=28) :: logKey = "bPlaneGaussVort"
integer(kint) :: mpiErrCode
real(kreal) :: timeStart, timeEnd
integer(kint) :: i
real(kreal), dimension(3) :: vec3

!--------------------------------
!	initialize : setup computing environment
!--------------------------------
call MPI_INIT(mpiErrCode)
call MPI_COMM_SIZE(MPI_COMM_WORLD, numProcs, mpiErrCode)
call MPI_COMM_RANK(MPI_COMM_WORLD, procRank, mpiErrCode)

call InitLogger(exeLog, procRank)

timeStart = MPI_WTIME()

call ReadNamelistFile( procRank )

!
!	initialize mesh and spatial fields
!
t = 0.0_kreal
call New( betaPlane, initNest, maxNest, amrLimit, lat0, rotationRate )
call SetInitialVorticityOnMesh( betaPlane, GaussianVortexVorticity)

AMR = (amrLimit > 0 )
if ( AMR ) then
	!call LogMessage(exeLog, DEBUG_LOGGING_LEVEL, trim(logKey)//" ", "starting adaptive refinement...")

	call StartSection(exeLog, "--- Initial refinement ---")

	call New(refinement, betaPlane%mesh%faces%N_Max)

	call SetAbsoluteTolerances( betaPlane, circulationTol, flowMapVarTol )
	call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logKey)//" circulation tol = ", circulationTol)
	call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logKey)//" flowMapVarTol = ", flowMapVarTol)

	do i = 1, amrLimit
		call IterateMeshRefinementOneVariableAndFlowMap( refinement, betaPlane%mesh, betaPlane%relVort, &
			ScalarIntegralRefinement, circulationTol, "circulation refinement", flowMapVarTol, &
			nParticlesBefore, nParticlesAfter)
		call SetInitialVorticityOnMesh( betaPlane, GaussianVortexVorticity)
	enddo
	call LoadBalance(betaPlane%mpiParticles, betaPlane%mesh%particles%N, numProcs)
	call EndSection(exeLog)
endif

call SetStreamFunctionsOnMesh(betaPlane)
call SetVelocityOnMesh(betaPlane)

!
!	output initial state
!
frameCounter = 0
if ( procRank == 0 ) then
	call LogStats(betaPlane, exeLog)

	if ( AMR ) then
		write(meshString,'(A,I1,A,I2,A)') "_betaPlaneAMR", initNest, "to", initNest + amrLimit, "_"
	else
		write(meshString,'(A,I1,A)') "_betaPlane", initNest, "_"
	endif

	write(vtkRoot,'(4A)') trim(outputDir), '/vtkOut/', trim(outputRoot), trim(meshString)
	write(vtkFile,'(A,I0.4,A)') trim(vtkRoot), frameCounter, '.vtk'
	write(vtkRoot,'(4A)') trim(outputDir), '/vtkOut/', trim(outputRoot), trim(meshString)
	write(vtkFile,'(A,I0.4,A)') trim(vtkRoot), frameCounter, '.vtk'

	call OutputToVTK(betaPlane, vtkFile)
	frameCounter = frameCounter + 1

	call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logkey)//" t = ", t)
endif

!
!	initialize timestepping
!
call New(solver, betaPlane)
nTimesteps = floor(tfinal / dt)
allocate(kineticEnergy(nTimesteps+1))
allocate(enstrophy(nTimesteps+1))
kineticEnergy(1) = TotalKE(betaPlane)
enstrophy(1) = TotalEnstrophy(betaPlane)

!--------------------------------
!	run : evolve the problem in time
!--------------------------------

do timeJ = 0, nTimesteps - 1

	if ( mod(timeJ + 1, remeshInterval) == 0 ) then
		call LogMessage(exeLog, DEBUG_LOGGING_LEVEL, trim(logKey)//" remesh : ", "remesh built.")

		call New( tempMesh, initNest, maxNest, amrLimit, lat0, rotationRate )

		call LogMessage(exeLog, DEBUG_LOGGING_LEVEL, trim(logKey)//" remesh : ", "new mesh built.")

		call LagrangianRemeshBetaPlaneWithVorticityFunction( betaPlane, tempMesh, AMR, GaussianVortexVorticity, &
				ScalarIntegralRefinement, circulationTol, "circulation refinement", RefineFlowMapYN = .TRUE., &
				flowMapVarTol = flowMapVarTol )

		call Copy(betaPlane, tempMesh)

		call Delete(solver)
		call Delete(tempMesh)

		call New(solver, betaPlane)
	endif

	call Timestep(solver, betaPlane, dt)
	t = real(timeJ + 1, kreal) * dt
	betaPlane%mesh%t = t

	kineticEnergy(timeJ + 2) = TotalKE(betaPlane)
	enstrophy(timeJ + 2) = TotalEnstrophy(betaPlane)

	if ( procRank == 0 .AND. mod(timeJ+1, frameOut) == 0 ) then
		write(vtkFile,'(A,I0.4,A)') trim(vtkRoot), frameCounter, '.vtk'
		call OutputToVTK(betaPlane, vtkFile)
		frameCounter = frameCounter + 1
		call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logKey)//" t = ", t)
	endif
enddo

!
!	write t = tfinal output
!
if ( procRank == 0 ) then
	write(matlabFile, '(5A)') trim(outputDir), '/', trim(outputRoot), trim(meshString), '.m'
	open(unit=WRITE_UNIT_1, file=matlabFile, status='REPLACE', action='WRITE')
		write(WRITE_UNIT_1,'(A,F12.9,A,F12.6,A)') "t = 0:", dt,":", tfinal, ";"
		call WriteToMatlab(kineticEnergy, WRITE_UNIT_1, "kineticEnergy")
		call WriteToMatlab(enstrophy, WRITE_UNIT_1, "enstrophy")
	close(WRITE_UNIT_1)
endif

!--------------------------------
!	finalize : clean up
!--------------------------------

timeEnd = MPI_WTIME()
write(logstring,'(A,F12.2,A)') "PROGRAM COMPLETE : elapsed time ", timeEnd - timeStart, " seconds."
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logKey)//" ", logstring)

deallocate(kineticEnergy)
deallocate(enstrophy)
call Delete(solver)
call Delete(betaPlane)

call MPI_FINALIZE(mpiErrCode)

contains

subroutine SetAbsoluteTolerances( betaPlane, circTol, lagVarTol )
	type(BetaPlaneMesh), intent(in) :: betaPlane
	real(kreal), intent(inout) :: circTol
	real(kreal), intent(inout) :: lagVarTol
	!
	circTol = circTol * MaxCirculationMagnitudePerFace(betaPlane)
	lagVarTol = lagVarTol * MaxLagrangianVariationPerFace(betaPlane%mesh)
end subroutine

function GaussianVortexVorticity( x, y )
	real(kreal) :: GaussianVortexVorticity
	real(kreal), intent(in) :: x, y
	GaussianVortexVorticity = vorticityMax * exp( - shapeParam * shapeParam * ( (x - vortInitX)**2  + (y - vortInitY)**2 ))
end function

subroutine ReadNamelistFile( rank )
	integer(kint), intent(in) :: rank
	!
	character(len=MAX_STRING_LENGTH) :: namelistFilename
	integer(kint), parameter :: initBcast_intSize = 5
	integer(kint), parameter :: initBcast_realSize = 9
	integer(kint), dimension(initBcast_intSize) :: bcastIntegers
	real(kreal), dimension(initBcast_realSize) :: bcastReals
	integer(kint) :: mpiErrCode, readStat

	if ( COMMAND_ARGUMENT_COUNT() /= 1 ) then
		call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logKey), " ERROR: expected namelist file as 1st argument.")
		stop
	endif

	if ( rank == 0 ) then
		call GET_COMMAND_ARGUMENT(1, namelistFilename)

		open(unit=READ_UNIT, file=namelistFilename, status='OLD', action='READ', iostat=readStat)
			if ( readStat /= 0 ) then
				call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logKey), " ERROR: cannot read namelist file.")
				stop
			endif

			read(READ_UNIT, nml=meshDefine)
			rewind(READ_UNIT)
			read(READ_UNIT, nml=gaussVort)
			rewind(READ_UNIT)
			read(READ_UNIT, nml=timestepping)
			rewind(READ_UNIT)
			read(READ_UNIT, nml=fileIO)
		close(READ_UNIT)

		bcastIntegers(1) = initNest
		bcastIntegers(2) = maxNest
		bcastIntegers(3) = amrLimit
		bcastIntegers(4) = frameOut
		bcastIntegers(5) = remeshInterval

		bcastReals(1) = dt
		bcastReals(2) = tfinal
		bcastReals(3) = shapeParam
		bcastReals(4) = rotationRate
		bcastReals(5) = vorticityMax
		bcastReals(6) = lat0
		bcastReals(7) = vortInitY
		bcastReals(8) = circulationTol
		bcastReals(9) = flowMapVarTol
	endif

	call MPI_BCAST(bcastIntegers, initBCAST_intSize, MPI_INTEGER, 0, MPI_COMM_WORLD, mpiErrCode)
	if ( mpiErrCode /= 0 ) then
		call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logKey)//" bcastIntegers, MPI_BCAST ERROR : ", mpiErrCode)
	endif

	call MPI_BCAST(bcastReals, initBCAST_realSize, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, mpiErrCode)
	if ( mpiErrCode /= 0 ) then
		call LogMessage(exeLog, ERROR_LOGGING_LEVEL, trim(logKey)//" bcastReals, MPI_BCAST ERROR : ", mpiErrCode)
	endif

	initNest = bcastIntegers(1)
	maxNest = bcastIntegers(2)
	amrLimit = bcastIntegers(3)
	frameOut = bcastIntegers(4)
	remeshInterval = bcastIntegers(5)

	dt = bcastReals(1)
	tfinal = bcastReals(2)
	shapeParam = bcastReals(3)
	rotationRate = bcastReals(4)
	vorticityMax = bcastReals(5)
	lat0 = bcastReals(6)
	vortInitY = bcastReals(7)
	circulationTol = bcastReals(8)
	flowMapVarTol = bcastReals(9)
end subroutine

subroutine InitLogger(log, rank)
	type(Logger), intent(inout) :: log
	integer(kint), intent(in) :: rank
	if ( rank == 0 ) then
		call New(log, logLevel)
	else
		call New(log, ERROR_LOGGING_LEVEL)
	endif
	write(logKey,'(A,I0.2,A)') trim(logKey)//"_", rank, ":"
end subroutine

end program


PROGRAM fib_serial
  IMPLICIT NONE
  INTEGER :: fib
  INTEGER :: N, res
  REAL :: t_start, t_end
  N=44
  CALL cpu_time(t_start)
  res=fib(N)
  CALL cpu_time(t_end)

  WRITE(*,*) "result = ",res
  WRITE(*,*) "Expended wall clock time = ",t_end-t_start

END PROGRAM fib_serial

RECURSIVE FUNCTION fib(n) RESULT(res)
  IMPLICIT NONE

  INTEGER, INTENT(IN) :: n
  INTEGER :: res

  INTEGER :: x,y

  IF (n<2) THEN
     res=n
  ELSE
     x = fib(n-1)
     y = fib(n-2)
     res=x+y
  END IF
END FUNCTION fib


!> @brief Module containing subroutines for generating 1-D and 2-D Hammersley quasi-Monte Carlo sequences.
!! @details The algorithm and code for generating the 1-D Hammersley sequence was developed by John Burkardt at the Florida State University.
!! Visit "https://people.sc.fsu.edu/~jburkardt/f_src/hammersley/hammersley.html" for more information.
!! The algorithm and code for generating the 2-D Hammersley sequence was developed by L. Carbajal at the Oak Ridge National Lab.
MODULE korc_hammersley_generator
  use korc_types

  IMPLICIT NONE

  PUBLIC :: hammersley,&
       generate_2D_hammersley_sequence
  PRIVATE :: hammersley_inverse,&
       hammersley_sequence,&
       r8mat_print,&
       r8mat_print_some,&
       timestamp,&
       prime

CONTAINS

  !> @brief Subroutine for generating a 2-D Hammersley sequence.
  !! @details This subroutine uses the algorithm for generating a 1-D Hammersley sequence.
  !! Each MPI process in KORC generates a (different) subset of pairs (X,Y) of a 2-D Hammersley sequence. The total number of pairs (X,Y)
  !! is NMPIS*N, where NMPIS is the number of MPI processes in the simulation and N is the number of particles followed by each MPI process.
  !! Each subset of pairs (X,Y) has N elements.
  !!
  !! @param[in,out] X 1-D array with elements of a 2-D Hammersley sequence.
  !! @param[in,out] Y 1-D array with elements of a 2-D Hammersley sequence.
  !! @param[in] ID MPI rank of MPI process.
  !! @param[in] NMPIS Total number of MPI processes in the simulation.
  !! @param N Number of particles per MPI process.
  !! @param offset An offset to indicate the subroutine what subset of the 2-D Harmmersley sequence will be generated.
  !! @param ii Particle iterator.
  subroutine generate_2D_hammersley_sequence(ID,NMPIS,X,Y)
    REAL(rp), DIMENSION(:), INTENT(INOUT) 	:: X
    REAL(rp), DIMENSION(:), INTENT(INOUT) 	:: Y
    INTEGER, INTENT(IN) 					:: ID
    INTEGER, INTENT(IN) 					:: NMPIS
    INTEGER(4) 								:: N
    INTEGER(4) 								:: offset
    REAL(8), DIMENSION(2) 					:: R
    INTEGER(4) 								:: ii

    N = INT(SIZE(X),4)
    offset = (INT(ID+1_idef,4) - 1_4)*N

    !	write(output_unit_write,'("MPI process: ",I5," offset: ",I5)') ID, offset

    do ii=1_4,N
       call hammersley(ii+INT(offset,4),2_4,N*INT(NMPIS,4),R)

       X(ii) = REAL(R(1),rp)
       Y(ii) = REAL(R(2),rp)
    end do
  end subroutine generate_2D_hammersley_sequence

  !> @brief For more info please visit "https://people.sc.fsu.edu/~jburkardt/f_src/hammersley/hammersley.html".
  subroutine hammersley ( i, m, n, r )
    !*****************************************************************************80
    !
    !! HAMMERSLEY computes an element of a Hammersley sequence.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    20 August 2016
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    John Hammersley,
    !    Monte Carlo methods for solving multivariable problems,
    !    Proceedings of the New York Academy of Science,
    !    Volume 86, 1960, pages 844-874.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) I, the index of the element of the sequence.
    !    0 <= I.
    !
    !    Input, integer ( kind = 4 ) M, the spatial dimension.
    !
    !    Input, integer ( kind = 4 ) N, the "base" for the first component.
    !    1 <= N.
    !
    !    Output, real ( kind = 8 ) R(M), the element of the sequence with index I.
    !
    implicit none

    integer ( kind = 4 ) m

    integer ( kind = 4 ) d
    integer ( kind = 4 ) i
    integer ( kind = 4 ) i1
    integer ( kind = 4 ) j
    integer ( kind = 4 ) n
    !  integer ( kind = 4 ) prime
    real ( kind = 8 ) prime_inv(2:m)
    real ( kind = 8 ) r(m)
    integer ( kind = 4 ) t(2:m)

    t(2:m) = abs ( i )
    !
    !  Carry out the computation.
    !
    do i1 = 2, m
       prime_inv(i1) = 1.0D+00 / real ( prime ( i1 - 1 ), kind = 8 )
    end do

    r(1) = real ( mod ( i, n + 1 ), kind = 8 ) / real ( n, kind = 8 )

    r(2:m) = 0.0D+00

    do while ( any ( t(2:m) /= 0 ) )
       do j = 2, m
          d = mod ( t(j), prime ( j - 1 ) )
          r(j) = r(j) + real ( d, kind = 8 ) * prime_inv(j)
          prime_inv(j) = prime_inv(j) / real ( prime ( j - 1 ), kind = 8 )
          t(j) = ( t(j) / prime ( j - 1 ) )
       end do
    end do

    return
  end subroutine hammersley

  !> @brief For more info please visit "https://people.sc.fsu.edu/~jburkardt/f_src/hammersley/hammersley.html".
  subroutine hammersley_inverse ( r, m, n, i )

    !*****************************************************************************80
    !
    !! HAMMERSLEY_INVERSE inverts an element of the Hammersley sequence.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    20 August 2016
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    Input, real ( kind = 8 ) R(M), the I-th element of the Hammersley sequence.
    !    0 <= R < 1.0
    !
    !    Input, integer ( kind = 4 ) M, the spatial dimension.
    !
    !    Input, integer ( kind = 4 ) N, the "base" for the first component.
    !    1 <= N.
    !
    !    Output, integer ( kind = 4 ) I, the index of the element of the sequence.
    !
    implicit none

    integer ( kind = 4 ) m

    integer ( kind = 4 ) d
    integer ( kind = 4 ) i
    integer ( kind = 4 ) n
    integer ( kind = 4 ) p
    real ( kind = 8 ) r(m)
    real ( kind = 8 ) t

    if ( any ( r(1:m) < 0.0D+00 ) .or. any ( 1.0D+00 < r(1:m) ) ) then
       write ( *, '(a)' ) ''
       write ( *, '(a)' ) 'HAMMERSLEY_INVERSE - Fatal error!'
       write ( *, '(a)' ) '  0 <= R <= 1.0 is required.'
       stop 1
    end if

    if ( m < 1 ) then
       write ( *, '(a)' ) ''
       write ( *, '(a)' ) 'HAMMERSLEY_INVERSE - Fatal error!'
       write ( *, '(a)' ) '  1 <= M is required.'
       stop 1
    end if

    if ( n < 1 ) then
       write ( *, '(a)' ) ''
       write ( *, '(a)' ) 'HAMMERSLEY_INVERSE - Fatal error!'
       write ( *, '(a)' ) '  1 <= N is required.'
       stop 1
    end if
    !
    !  Invert using the second component only, because working with base
    !  2 is accurate.
    !
    if ( 2 <= m ) then

       i = 0
       t = r(2)
       p = 1

       do while ( t /= 0.0D+00 )
          t = t * 2.0D+00
          d = int ( t )
          i = i + d * p
          p = p * 2
          t = mod ( t, 1.0D+00 )
       end do

    else

       i = nint ( real ( n, kind = 8 ) * r(1) )

    end if

    return
  end subroutine hammersley_inverse

  !> @brief For more info please visit "https://people.sc.fsu.edu/~jburkardt/f_src/hammersley/hammersley.html".
  function prime ( n )
    !*****************************************************************************80
    !
    !! PRIME returns any of the first PRIME_MAX prime numbers.
    !
    !  Discussion:
    !
    !    PRIME_MAX is 1600, and the largest prime stored is 13499.
    !
    !    Thanks to Bart Vandewoestyne for pointing out a typo, 18 February 2005.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    18 February 2005
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    Milton Abramowitz, Irene Stegun,
    !    Handbook of Mathematical Functions,
    !    US Department of Commerce, 1964, pages 870-873.
    !
    !    Daniel Zwillinger,
    !    CRC Standard Mathematical Tables and Formulae,
    !    30th Edition,
    !    CRC Press, 1996, pages 95-98.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) N, the index of the desired prime number.
    !    In general, is should be true that 0 <= N <= PRIME_MAX.
    !    N = -1 returns PRIME_MAX, the index of the largest prime available.
    !    N = 0 is legal, returning PRIME = 1.
    !
    !    Output, integer ( kind = 4 ) PRIME, the N-th prime.  If N is out of range,
    !    PRIME is returned as -1.
    !
    implicit none

    integer ( kind = 4 ), parameter :: prime_max = 1600

    integer ( kind = 4 ), save :: icall = 0
    integer ( kind = 4 ) n
    integer ( kind = 4 ), save, dimension ( prime_max ) :: npvec
    integer ( kind = 4 ) prime

    if ( icall == 0 ) then

       icall = 1

       npvec(1:100) = (/ &
            2,    3,    5,    7,   11,   13,   17,   19,   23,   29, &
            31,   37,   41,   43,   47,   53,   59,   61,   67,   71, &
            73,   79,   83,   89,   97,  101,  103,  107,  109,  113, &
            127,  131,  137,  139,  149,  151,  157,  163,  167,  173, &
            179,  181,  191,  193,  197,  199,  211,  223,  227,  229, &
            233,  239,  241,  251,  257,  263,  269,  271,  277,  281, &
            283,  293,  307,  311,  313,  317,  331,  337,  347,  349, &
            353,  359,  367,  373,  379,  383,  389,  397,  401,  409, &
            419,  421,  431,  433,  439,  443,  449,  457,  461,  463, &
            467,  479,  487,  491,  499,  503,  509,  521,  523,  541 /)

       npvec(101:200) = (/ &
            547,  557,  563,  569,  571,  577,  587,  593,  599,  601, &
            607,  613,  617,  619,  631,  641,  643,  647,  653,  659, &
            661,  673,  677,  683,  691,  701,  709,  719,  727,  733, &
            739,  743,  751,  757,  761,  769,  773,  787,  797,  809, &
            811,  821,  823,  827,  829,  839,  853,  857,  859,  863, &
            877,  881,  883,  887,  907,  911,  919,  929,  937,  941, &
            947,  953,  967,  971,  977,  983,  991,  997, 1009, 1013, &
            1019, 1021, 1031, 1033, 1039, 1049, 1051, 1061, 1063, 1069, &
            1087, 1091, 1093, 1097, 1103, 1109, 1117, 1123, 1129, 1151, &
            1153, 1163, 1171, 1181, 1187, 1193, 1201, 1213, 1217, 1223 /)

       npvec(201:300) = (/ &
            1229, 1231, 1237, 1249, 1259, 1277, 1279, 1283, 1289, 1291, &
            1297, 1301, 1303, 1307, 1319, 1321, 1327, 1361, 1367, 1373, &
            1381, 1399, 1409, 1423, 1427, 1429, 1433, 1439, 1447, 1451, &
            1453, 1459, 1471, 1481, 1483, 1487, 1489, 1493, 1499, 1511, &
            1523, 1531, 1543, 1549, 1553, 1559, 1567, 1571, 1579, 1583, &
            1597, 1601, 1607, 1609, 1613, 1619, 1621, 1627, 1637, 1657, &
            1663, 1667, 1669, 1693, 1697, 1699, 1709, 1721, 1723, 1733, &
            1741, 1747, 1753, 1759, 1777, 1783, 1787, 1789, 1801, 1811, &
            1823, 1831, 1847, 1861, 1867, 1871, 1873, 1877, 1879, 1889, &
            1901, 1907, 1913, 1931, 1933, 1949, 1951, 1973, 1979, 1987 /)

       npvec(301:400) = (/ &
            1993, 1997, 1999, 2003, 2011, 2017, 2027, 2029, 2039, 2053, &
            2063, 2069, 2081, 2083, 2087, 2089, 2099, 2111, 2113, 2129, &
            2131, 2137, 2141, 2143, 2153, 2161, 2179, 2203, 2207, 2213, &
            2221, 2237, 2239, 2243, 2251, 2267, 2269, 2273, 2281, 2287, &
            2293, 2297, 2309, 2311, 2333, 2339, 2341, 2347, 2351, 2357, &
            2371, 2377, 2381, 2383, 2389, 2393, 2399, 2411, 2417, 2423, &
            2437, 2441, 2447, 2459, 2467, 2473, 2477, 2503, 2521, 2531, &
            2539, 2543, 2549, 2551, 2557, 2579, 2591, 2593, 2609, 2617, &
            2621, 2633, 2647, 2657, 2659, 2663, 2671, 2677, 2683, 2687, &
            2689, 2693, 2699, 2707, 2711, 2713, 2719, 2729, 2731, 2741 /)

       npvec(401:500) = (/ &
            2749, 2753, 2767, 2777, 2789, 2791, 2797, 2801, 2803, 2819, &
            2833, 2837, 2843, 2851, 2857, 2861, 2879, 2887, 2897, 2903, &
            2909, 2917, 2927, 2939, 2953, 2957, 2963, 2969, 2971, 2999, &
            3001, 3011, 3019, 3023, 3037, 3041, 3049, 3061, 3067, 3079, &
            3083, 3089, 3109, 3119, 3121, 3137, 3163, 3167, 3169, 3181, &
            3187, 3191, 3203, 3209, 3217, 3221, 3229, 3251, 3253, 3257, &
            3259, 3271, 3299, 3301, 3307, 3313, 3319, 3323, 3329, 3331, &
            3343, 3347, 3359, 3361, 3371, 3373, 3389, 3391, 3407, 3413, &
            3433, 3449, 3457, 3461, 3463, 3467, 3469, 3491, 3499, 3511, &
            3517, 3527, 3529, 3533, 3539, 3541, 3547, 3557, 3559, 3571 /)

       npvec(501:600) = (/ &
            3581, 3583, 3593, 3607, 3613, 3617, 3623, 3631, 3637, 3643, &
            3659, 3671, 3673, 3677, 3691, 3697, 3701, 3709, 3719, 3727, &
            3733, 3739, 3761, 3767, 3769, 3779, 3793, 3797, 3803, 3821, &
            3823, 3833, 3847, 3851, 3853, 3863, 3877, 3881, 3889, 3907, &
            3911, 3917, 3919, 3923, 3929, 3931, 3943, 3947, 3967, 3989, &
            4001, 4003, 4007, 4013, 4019, 4021, 4027, 4049, 4051, 4057, &
            4073, 4079, 4091, 4093, 4099, 4111, 4127, 4129, 4133, 4139, &
            4153, 4157, 4159, 4177, 4201, 4211, 4217, 4219, 4229, 4231, &
            4241, 4243, 4253, 4259, 4261, 4271, 4273, 4283, 4289, 4297, &
            4327, 4337, 4339, 4349, 4357, 4363, 4373, 4391, 4397, 4409 /)

       npvec(601:700) = (/ &
            4421, 4423, 4441, 4447, 4451, 4457, 4463, 4481, 4483, 4493, &
            4507, 4513, 4517, 4519, 4523, 4547, 4549, 4561, 4567, 4583, &
            4591, 4597, 4603, 4621, 4637, 4639, 4643, 4649, 4651, 4657, &
            4663, 4673, 4679, 4691, 4703, 4721, 4723, 4729, 4733, 4751, &
            4759, 4783, 4787, 4789, 4793, 4799, 4801, 4813, 4817, 4831, &
            4861, 4871, 4877, 4889, 4903, 4909, 4919, 4931, 4933, 4937, &
            4943, 4951, 4957, 4967, 4969, 4973, 4987, 4993, 4999, 5003, &
            5009, 5011, 5021, 5023, 5039, 5051, 5059, 5077, 5081, 5087, &
            5099, 5101, 5107, 5113, 5119, 5147, 5153, 5167, 5171, 5179, &
            5189, 5197, 5209, 5227, 5231, 5233, 5237, 5261, 5273, 5279 /)

       npvec(701:800) = (/ &
            5281, 5297, 5303, 5309, 5323, 5333, 5347, 5351, 5381, 5387, &
            5393, 5399, 5407, 5413, 5417, 5419, 5431, 5437, 5441, 5443, &
            5449, 5471, 5477, 5479, 5483, 5501, 5503, 5507, 5519, 5521, &
            5527, 5531, 5557, 5563, 5569, 5573, 5581, 5591, 5623, 5639, &
            5641, 5647, 5651, 5653, 5657, 5659, 5669, 5683, 5689, 5693, &
            5701, 5711, 5717, 5737, 5741, 5743, 5749, 5779, 5783, 5791, &
            5801, 5807, 5813, 5821, 5827, 5839, 5843, 5849, 5851, 5857, &
            5861, 5867, 5869, 5879, 5881, 5897, 5903, 5923, 5927, 5939, &
            5953, 5981, 5987, 6007, 6011, 6029, 6037, 6043, 6047, 6053, &
            6067, 6073, 6079, 6089, 6091, 6101, 6113, 6121, 6131, 6133 /)

       npvec(801:900) = (/ &
            6143, 6151, 6163, 6173, 6197, 6199, 6203, 6211, 6217, 6221, &
            6229, 6247, 6257, 6263, 6269, 6271, 6277, 6287, 6299, 6301, &
            6311, 6317, 6323, 6329, 6337, 6343, 6353, 6359, 6361, 6367, &
            6373, 6379, 6389, 6397, 6421, 6427, 6449, 6451, 6469, 6473, &
            6481, 6491, 6521, 6529, 6547, 6551, 6553, 6563, 6569, 6571, &
            6577, 6581, 6599, 6607, 6619, 6637, 6653, 6659, 6661, 6673, &
            6679, 6689, 6691, 6701, 6703, 6709, 6719, 6733, 6737, 6761, &
            6763, 6779, 6781, 6791, 6793, 6803, 6823, 6827, 6829, 6833, &
            6841, 6857, 6863, 6869, 6871, 6883, 6899, 6907, 6911, 6917, &
            6947, 6949, 6959, 6961, 6967, 6971, 6977, 6983, 6991, 6997 /)

       npvec(901:1000) = (/ &
            7001, 7013, 7019, 7027, 7039, 7043, 7057, 7069, 7079, 7103, &
            7109, 7121, 7127, 7129, 7151, 7159, 7177, 7187, 7193, 7207, &
            7211, 7213, 7219, 7229, 7237, 7243, 7247, 7253, 7283, 7297, &
            7307, 7309, 7321, 7331, 7333, 7349, 7351, 7369, 7393, 7411, &
            7417, 7433, 7451, 7457, 7459, 7477, 7481, 7487, 7489, 7499, &
            7507, 7517, 7523, 7529, 7537, 7541, 7547, 7549, 7559, 7561, &
            7573, 7577, 7583, 7589, 7591, 7603, 7607, 7621, 7639, 7643, &
            7649, 7669, 7673, 7681, 7687, 7691, 7699, 7703, 7717, 7723, &
            7727, 7741, 7753, 7757, 7759, 7789, 7793, 7817, 7823, 7829, &
            7841, 7853, 7867, 7873, 7877, 7879, 7883, 7901, 7907, 7919 /)

       npvec(1001:1100) = (/ &
            7927, 7933, 7937, 7949, 7951, 7963, 7993, 8009, 8011, 8017, &
            8039, 8053, 8059, 8069, 8081, 8087, 8089, 8093, 8101, 8111, &
            8117, 8123, 8147, 8161, 8167, 8171, 8179, 8191, 8209, 8219, &
            8221, 8231, 8233, 8237, 8243, 8263, 8269, 8273, 8287, 8291, &
            8293, 8297, 8311, 8317, 8329, 8353, 8363, 8369, 8377, 8387, &
            8389, 8419, 8423, 8429, 8431, 8443, 8447, 8461, 8467, 8501, &
            8513, 8521, 8527, 8537, 8539, 8543, 8563, 8573, 8581, 8597, &
            8599, 8609, 8623, 8627, 8629, 8641, 8647, 8663, 8669, 8677, &
            8681, 8689, 8693, 8699, 8707, 8713, 8719, 8731, 8737, 8741, &
            8747, 8753, 8761, 8779, 8783, 8803, 8807, 8819, 8821, 8831 /)

       npvec(1101:1200) = (/ &
            8837, 8839, 8849, 8861, 8863, 8867, 8887, 8893, 8923, 8929, &
            8933, 8941, 8951, 8963, 8969, 8971, 8999, 9001, 9007, 9011, &
            9013, 9029, 9041, 9043, 9049, 9059, 9067, 9091, 9103, 9109, &
            9127, 9133, 9137, 9151, 9157, 9161, 9173, 9181, 9187, 9199, &
            9203, 9209, 9221, 9227, 9239, 9241, 9257, 9277, 9281, 9283, &
            9293, 9311, 9319, 9323, 9337, 9341, 9343, 9349, 9371, 9377, &
            9391, 9397, 9403, 9413, 9419, 9421, 9431, 9433, 9437, 9439, &
            9461, 9463, 9467, 9473, 9479, 9491, 9497, 9511, 9521, 9533, &
            9539, 9547, 9551, 9587, 9601, 9613, 9619, 9623, 9629, 9631, &
            9643, 9649, 9661, 9677, 9679, 9689, 9697, 9719, 9721, 9733 /)

       npvec(1201:1300) = (/ &
            9739, 9743, 9749, 9767, 9769, 9781, 9787, 9791, 9803, 9811, &
            9817, 9829, 9833, 9839, 9851, 9857, 9859, 9871, 9883, 9887, &
            9901, 9907, 9923, 9929, 9931, 9941, 9949, 9967, 9973,10007, &
            10009,10037,10039,10061,10067,10069,10079,10091,10093,10099, &
            10103,10111,10133,10139,10141,10151,10159,10163,10169,10177, &
            10181,10193,10211,10223,10243,10247,10253,10259,10267,10271, &
            10273,10289,10301,10303,10313,10321,10331,10333,10337,10343, &
            10357,10369,10391,10399,10427,10429,10433,10453,10457,10459, &
            10463,10477,10487,10499,10501,10513,10529,10531,10559,10567, &
            10589,10597,10601,10607,10613,10627,10631,10639,10651,10657 /)

       npvec(1301:1400) = (/ &
            10663,10667,10687,10691,10709,10711,10723,10729,10733,10739, &
            10753,10771,10781,10789,10799,10831,10837,10847,10853,10859, &
            10861,10867,10883,10889,10891,10903,10909,10937,10939,10949, &
            10957,10973,10979,10987,10993,11003,11027,11047,11057,11059, &
            11069,11071,11083,11087,11093,11113,11117,11119,11131,11149, &
            11159,11161,11171,11173,11177,11197,11213,11239,11243,11251, &
            11257,11261,11273,11279,11287,11299,11311,11317,11321,11329, &
            11351,11353,11369,11383,11393,11399,11411,11423,11437,11443, &
            11447,11467,11471,11483,11489,11491,11497,11503,11519,11527, &
            11549,11551,11579,11587,11593,11597,11617,11621,11633,11657 /)

       npvec(1401:1500) = (/ &
            11677,11681,11689,11699,11701,11717,11719,11731,11743,11777, &
            11779,11783,11789,11801,11807,11813,11821,11827,11831,11833, &
            11839,11863,11867,11887,11897,11903,11909,11923,11927,11933, &
            11939,11941,11953,11959,11969,11971,11981,11987,12007,12011, &
            12037,12041,12043,12049,12071,12073,12097,12101,12107,12109, &
            12113,12119,12143,12149,12157,12161,12163,12197,12203,12211, &
            12227,12239,12241,12251,12253,12263,12269,12277,12281,12289, &
            12301,12323,12329,12343,12347,12373,12377,12379,12391,12401, &
            12409,12413,12421,12433,12437,12451,12457,12473,12479,12487, &
            12491,12497,12503,12511,12517,12527,12539,12541,12547,12553 /)

       npvec(1501:1600) = (/ &
            12569,12577,12583,12589,12601,12611,12613,12619,12637,12641, &
            12647,12653,12659,12671,12689,12697,12703,12713,12721,12739, &
            12743,12757,12763,12781,12791,12799,12809,12821,12823,12829, &
            12841,12853,12889,12893,12899,12907,12911,12917,12919,12923, &
            12941,12953,12959,12967,12973,12979,12983,13001,13003,13007, &
            13009,13033,13037,13043,13049,13063,13093,13099,13103,13109, &
            13121,13127,13147,13151,13159,13163,13171,13177,13183,13187, &
            13217,13219,13229,13241,13249,13259,13267,13291,13297,13309, &
            13313,13327,13331,13337,13339,13367,13381,13397,13399,13411, &
            13417,13421,13441,13451,13457,13463,13469,13477,13487,13499 /)

    end if

    if ( n == -1 ) then
       prime = prime_max
    else if ( n == 0 ) then
       prime = 1
    else if ( n <= prime_max ) then
       prime = npvec(n)
    else
       prime = -1
       write ( *, '(a)' ) ' '
       write ( *, '(a)' ) 'PRIME - Fatal error!'
       write ( *, '(a,i8)' ) '  Illegal prime index N = ', n
       write ( *, '(a,i8)' ) '  N should be between 1 and PRIME_MAX =', prime_max
       stop 1
    end if

    return
  end function prime

  !> @brief For more info please visit "https://people.sc.fsu.edu/~jburkardt/f_src/hammersley/hammersley.html".
  subroutine hammersley_sequence ( i1, i2, m, n, r )
    !*****************************************************************************80
    !
    !! HAMMERSLEY_SEQUENCE computes elements I1 through I2 of a Hammersley sequence.
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    20 August 2016
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Reference:
    !
    !    John Hammersley,
    !    Monte Carlo methods for solving multivariable problems,
    !    Proceedings of the New York Academy of Science,
    !    Volume 86, 1960, pages 844-874.
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) I1, I2, the indices of the first and last
    !    elements of the sequence.  0 <= I1, I2.
    !
    !    Input, integer ( kind = 4 ) M, the spatial dimension.
    !
    !    Input, integer ( kind = 4 ) N, the "base" for the first component.
    !    1 <= N.
    !
    !    Output, real ( kind = 8 ) R(M,abs(I1-I2)+1), the elements of the sequence
    !    with indices I1 through I2.
    !
    implicit none

    integer ( kind = 4 ) m

    integer ( kind = 4 ) d
    integer ( kind = 4 ) i
    integer ( kind = 4 ) i1
    integer ( kind = 4 ) i2
    integer ( kind = 4 ) i3
    integer ( kind = 4 ) j
    integer ( kind = 4 ) k
    integer ( kind = 4 ) l
    integer ( kind = 4 ) n
    !  integer ( kind = 4 ) prime
    real ( kind = 8 ) prime_inv(2:m)
    real ( kind = 8 ) r(m,abs(i1-i2)+1)
    integer ( kind = 4 ) t(2:m)

    if ( i1 <= i2 ) then
       i3 = +1
    else
       i3 = -1
    end if

    l = abs ( i2 - i1 ) + 1
    r(1:m,1:l) = 0.0D+00
    k = 0

    do i = i1, i2, i3

       t(2:m) = i
       !
       !  Carry out the computation.
       !
       do j = 2, m
          prime_inv(j) = 1.0D+00 / real ( prime ( j - 1 ), kind = 8 )
       end do

       k = k + 1;

       r(1,k) = real ( mod ( i, n + 1 ), kind = 8 ) / real ( n, kind = 8 )

       do while ( any ( t(2:m) /= 0 ) )
          do j = 2, m
             d = mod ( t(j), prime ( j - 1 ) )
             r(j,k) = r(j,k) + real ( d, kind = 8 ) * prime_inv(j)
             prime_inv(j) = prime_inv(j) / real ( prime ( j - 1 ), kind = 8 )
             t(j) = ( t(j) / prime ( j - 1 ) )
          end do
       end do

    end do

    return
  end subroutine hammersley_sequence

  !> @brief For more info please visit "https://people.sc.fsu.edu/~jburkardt/f_src/hammersley/hammersley.html".
  subroutine r8mat_print ( m, n, a, title )
    !*****************************************************************************80
    !
    !! R8MAT_PRINT prints an R8MAT.
    !
    !  Discussion:
    !
    !    An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    12 September 2004
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) M, the number of rows in A.
    !
    !    Input, integer ( kind = 4 ) N, the number of columns in A.
    !
    !    Input, real ( kind = 8 ) A(M,N), the matrix.
    !
    !    Input, character ( len = * ) TITLE, a title.
    !
    implicit none

    integer ( kind = 4 ) m
    integer ( kind = 4 ) n

    real ( kind = 8 ) a(m,n)
    character ( len = * ) title

    call r8mat_print_some ( m, n, a, 1, 1, m, n, title )

    return
  end subroutine r8mat_print

  !> @brief For more info please visit "https://people.sc.fsu.edu/~jburkardt/f_src/hammersley/hammersley.html".
  subroutine r8mat_print_some ( m, n, a, ilo, jlo, ihi, jhi, title )
    !*****************************************************************************80
    !
    !! R8MAT_PRINT_SOME prints some of an R8MAT.
    !
    !  Discussion:
    !
    !    An R8MAT is an MxN array of R8's, stored by (I,J) -> [I+J*M].
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    10 September 2009
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    Input, integer ( kind = 4 ) M, N, the number of rows and columns.
    !
    !    Input, real ( kind = 8 ) A(M,N), an M by N matrix to be printed.
    !
    !    Input, integer ( kind = 4 ) ILO, JLO, the first row and column to print.
    !
    !    Input, integer ( kind = 4 ) IHI, JHI, the last row and column to print.
    !
    !    Input, character ( len = * ) TITLE, a title.
    !
    implicit none

    integer ( kind = 4 ), parameter :: incx = 5
    integer ( kind = 4 ) m
    integer ( kind = 4 ) n

    real ( kind = 8 ) a(m,n)
    character ( len = 14 ) ctemp(incx)
    integer ( kind = 4 ) i
    integer ( kind = 4 ) i2hi
    integer ( kind = 4 ) i2lo
    integer ( kind = 4 ) ihi
    integer ( kind = 4 ) ilo
    integer ( kind = 4 ) inc
    integer ( kind = 4 ) j
    integer ( kind = 4 ) j2
    integer ( kind = 4 ) j2hi
    integer ( kind = 4 ) j2lo
    integer ( kind = 4 ) jhi
    integer ( kind = 4 ) jlo
    character ( len = * ) title

    write ( *, '(a)' ) ' '
    write ( *, '(a)' ) trim ( title )

    if ( m <= 0 .or. n <= 0 ) then
       write ( *, '(a)' ) ' '
       write ( *, '(a)' ) '  (None)'
       return
    end if

    do j2lo = max ( jlo, 1 ), min ( jhi, n ), incx

       j2hi = j2lo + incx - 1
       j2hi = min ( j2hi, n )
       j2hi = min ( j2hi, jhi )

       inc = j2hi + 1 - j2lo

       write ( *, '(a)' ) ' '

       do j = j2lo, j2hi
          j2 = j + 1 - j2lo
          write ( ctemp(j2), '(i8,6x)' ) j
       end do

       write ( *, '(''  Col   '',5a14)' ) ctemp(1:inc)
       write ( *, '(a)' ) '  Row'
       write ( *, '(a)' ) ' '

       i2lo = max ( ilo, 1 )
       i2hi = min ( ihi, m )

       do i = i2lo, i2hi

          do j2 = 1, inc

             j = j2lo - 1 + j2

             if ( a(i,j) == real ( int ( a(i,j) ), kind = 8 ) ) then
                write ( ctemp(j2), '(f8.0,6x)' ) a(i,j)
             else
                write ( ctemp(j2), '(g14.6)' ) a(i,j)
             end if

          end do

          write ( *, '(i5,a,5a14)' ) i, ':', ( ctemp(j), j = 1, inc )

       end do

    end do

    return
  end subroutine r8mat_print_some

  !> @brief For more info please visit "https://people.sc.fsu.edu/~jburkardt/f_src/hammersley/hammersley.html".
  subroutine timestamp ( )
    !*****************************************************************************80
    !
    !! TIMESTAMP prints the current YMDHMS date as a time stamp.
    !
    !  Example:
    !
    !    31 May 2001   9:45:54.872 AM
    !
    !  Licensing:
    !
    !    This code is distributed under the GNU LGPL license.
    !
    !  Modified:
    !
    !    18 May 2013
    !
    !  Author:
    !
    !    John Burkardt
    !
    !  Parameters:
    !
    !    None
    !
    implicit none

    character ( len = 8 ) ampm
    integer ( kind = 4 ) d
    integer ( kind = 4 ) h
    integer ( kind = 4 ) m
    integer ( kind = 4 ) mm
    character ( len = 9 ), parameter, dimension(12) :: month = (/ &
         'January  ', 'February ', 'March    ', 'April    ', &
         'May      ', 'June     ', 'July     ', 'August   ', &
         'September', 'October  ', 'November ', 'December ' /)
    integer ( kind = 4 ) n
    integer ( kind = 4 ) s
    integer ( kind = 4 ) values(8)
    integer ( kind = 4 ) y

    call date_and_time ( values = values )

    y = values(1)
    m = values(2)
    d = values(3)
    h = values(5)
    n = values(6)
    s = values(7)
    mm = values(8)

    if ( h < 12 ) then
       ampm = 'AM'
    else if ( h == 12 ) then
       if ( n == 0 .and. s == 0 ) then
          ampm = 'Noon'
       else
          ampm = 'PM'
       end if
    else
       h = h - 12
       if ( h < 12 ) then
          ampm = 'PM'
       else if ( h == 12 ) then
          if ( n == 0 .and. s == 0 ) then
             ampm = 'Midnight'
          else
             ampm = 'AM'
          end if
       end if
    end if

    write ( *, '(i2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) &
         d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm )

    return
  end subroutine timestamp
END MODULE korc_hammersley_generator


      double precision function atg(s,t,p)
*
c ****************************
c adiabatic temperature gradient deg c per decibar
c ref: bryden,h.,1973,deep-sea res.,20,401-408
c units:
c       pressure        p        decibars
c       temperature     t        deg celsius (ipts-68)
c       salinity        s        (ipss-78)
c       adiabatic       atg      deg. c/decibar
c checkvalue: atg=3.255976e-4 c/dbar for s=40 (ipss-78),
c t=40 deg c,p0=10000 decibars
*
      implicit double precision (a-h,o-z)
*

      ds = s - 35.0

      atg = (((-2.1687d-16*t+1.8676d-14)*t-4.6206d-13)*p
     x+((2.7759d-12*t-1.1351d-10)*ds+((-5.4481d-14*t
     x+8.733d-12)*t-6.7795d-10)*t+1.8741d-8))*p
     x+(-4.2393d-8*t+1.8932d-6)*ds
     x+((6.6228d-10*t-6.836d-8)*t+8.5258d-6)*t+3.5803d-5

      return
      end


      SUBROUTINE DCALP(MMH,NNH,KKH,CMN,DMN,EMN,EPSIL,LROW,LDIAG,RLAT,
     $                 ALP,DALP)
C
C CALCULATES THE ASSOCIATED LEGENDRE POLYNOMIALS USING A HIGHLY
C STABLE FOUR TERM RECURRENCE RELATION GIVEN BY BELOUSOV (1962).
C THE SPECTRAL TRUNCATION PARAMETERS ARE DEFINED BY 3 PARAMETERS:
C MMH, THE LARGEST FOURIER WAVENUMBER; KKH, THE HIGHEST DEGREE OF THE
C ASSOCIATED LEGENDRE POLYNOMIALS, AND NNH THE HIGHEST DEGREE OF THE
C ASSOCIATED LEGENDRE POLYNOMIALS FOR M=0.  THE LENGTH OF THE
C ASSOCIATED LEGENDRE POLYNOMIAL ARRAY ALP IS GIVEN BY THE RELATION
C LEN = ((MMH+1)*(NNH+1) - (LMN**2 + LMN)/2)  WHERE LMN = MMH + NNH - KKH
C VARIABLES ARE STORED ALONG DIAGONALS STARTING WITH DIAGONAL M=N.
C THE LENGTH OF EACH ROW IS STORED IN THE ARRAY LROW(0:MAXH,2).
C THE LENGTH OF EACH DIAGONAL IS STORED IN THE ARRAY LDIAG(0:MAXH,1)
C AND IS EVALUATED IN SUBROUTINE CEPS AS (MMH+1)-AMAX(MMH+N-KKH,0)
C WHERE 0>N>NNH.  CUMULATIVE DIAGONAL LENGTHS (CUMULATIVE
C DISPLACEMENTS) ARE ALSO STORED IN LDIAG(0:MAXH,2) SO THAT THE
C ASSOCIATED LEGENDRE POLYNOMIAL OF ORDER M, DEGREE N, AND ARGUMENT
C SNJ IS ADDRESSED AS ALP(1 + LDIAG(N-M,2)+M)), OR USING THE
C STATEMENT FUNCTION IDSP AS ALP(IDSP(M,N)).  THE SAME FORM
C APPLIES FOR ADDRESSING THE DERIVATIVES (DALP) AND RECURRENCE
C COEFFICIENTS DEFINED IN THE EPSIL MATRIX.
C
C CALLED BY: EVAL
C CALLS:
C
C REVISIONS:
C 7-10-92 CHANGE TO CCM CODING CONVENTIONS (R. JAKOB)
C
C---- Model Parameters -------------------------------------------------
C
      INCLUDE 'params.i'
C
C------------ Arguments ------------------------------------------------
C
C     Input
C
C TRUNCATION PARAMETERS
      INTEGER MMH,NNH,KKH
C RECURRENCE COEFFICIENTS FOR ALP
      REAL CMN(NALPH), DMN(NALPH), EMN(NALPH)
C RECURRENCE COEFFICIENTS FOR DALP
      REAL EPSIL(NALPH)
C ROW LENGTH AND INDEX
      INTEGER LROW(0:MAXH,2)
C DIAGONAL LENGTH AND INDEX
      INTEGER LDIAG(0:MAXH,2)
C LATITUDE FOR EVALUATION OF BASISFUNCTIONS
      REAL RLAT
C
C     Output
C
C ASSOC. LEGENDRE POLYNOMIALS
      REAL ALP(NALPH)
C DERIV. ASSOC. LEGENDRE POLYNOMIALS
      REAL DALP(NALPH)
C
C------ Local Parameters -----------------------------------------------
C
      REAL PI
      PARAMETER (PI=3.141592653589793)
C
C------ Local Variables ------------------------------------------------
C
      REAL CN2N1N(MAXH+1,3)
      REAL COL1(MAXH), COL2(MAXH), SNPSUM(MAXH), CSPSUM(MAXH),
     $     SQNP(MAXH), AN(MAXH), CSFAC(MAXH), SNFAC(MAXH),
     $     COSTBL(MAXH), SINTBL(MAXH)
C
C     TEMPORARIES
C
      REAL RNORM,COS2P,SNJ,THTA
      INTEGER N,M,JK,JM,JN,MSTART,NSTART
      INTEGER MLIM,IS,ISM1
C
C----- Statement Function ----------------------------------------------
C
C     ADDRESS COMPUTATION OF ALP, DALP, EPSIL
C     E.G., EPSIL(M,N) = EPSIL(IDSP(M,N))
C
      INTEGER MDUM,NDUM,IDSP,IDSPR
      IDSP(MDUM,NDUM) = 1 + LDIAG(NDUM-MDUM,2)+MDUM
C
C     STATEMENT FUNCTION FOR ADDRESS COMPUTATION OF BELOUSOV RECURRENCE
C     COEFFICIENT MATRICES.  E.G., CMN(M,N) = CMN(IDSPR(M,N))
C
      IDSPR(MDUM,NDUM) = 1 + LROW(NDUM,2)+MDUM
C
C----- Executable Statements -------------------------------------------
C
C     COMPUTE ASSOCIATED LEGENDRE POLYNOMIALS AND THEIR DERIVATIVES FOR
C     THE TRUNCATED WAVENUMBER SPACE DEFINED IN LDIAG(0:MAXH,2) WITH
C     ARGUMENTS GIVEN BY PARAMETER RLAT USING BELOUSOV'S ALGORITHM.
C     THE PROCEDURE INVOLVES EXTRA WORK FOR ANY TRUNCATION OTHER THAN
C     TRIANGULAR BECAUSE BELOUSOV'S RECURRENCE REQUIRES POLYNOMIAL
C     INFORMATION IN PART OF THE REGION BETWEEN KKH AND NNH.  MORE
C     ELABORATE BOOKKEEPING COULD REDUCE THIS EXTRA COMPUTATION, BUT BY
C     LESS THAN A FACTOR OF TWO (PROBABLY LESS THAN 10% OF TOTAL WORK).
C
C     LATITUDE = RLAT
C
C     BEGIN BY COMPUTING 1ST TWO ELEMENTS IN EACH ROW (M=0:1;N=0:KKH)
C     EVALUATE THE SERIES EXPANSIONS (19) AND (21) IN BELOUSOV (1962)
C     FINAL RESULTS ARE STORED IN WORK ARRAYS COL1 AND COL2
C
      COS2P = COS(RLAT)
      SNJ   = SIN(RLAT)
      THTA  = PI/2.0 - RLAT
      CN2N1N(1,1)  = SQRT(0.50)
      ALP(1)  = CN2N1N(1,1)
      DALP(1) = 0.0
C
C        INITIALIZE WORKING SPACE
C
      DO 205 N=1,KKH
         SNPSUM(N) = 0.0
         CSPSUM(N) = 0.0
         SQNP(N)   = 1.0/SQRT(REAL(N*N + N))
         CSFAC(N)  = 1.0
         SNFAC(N)  = REAL(N)*SQNP(N)
         COSTBL(N) = COS(REAL(N)*THTA)
         SINTBL(N) = SIN(REAL(N)*THTA)
  205 CONTINUE
C
      AN(1) = SQRT(0.75)
      DO 210 N=2,KKH
         AN(N) = AN(N-1)*SQRT(1.0-(1.0/REAL(4*N*N)))
  210 CONTINUE
C
C     EACH INCREMENT IN JK EVALUATES AN ADDITIONAL TERM IN EXPANSIONS
C
      JK=1
      DO 215 N=1,KKH
         CSPSUM(N) = CSPSUM(N)+COSTBL(N-JK+1)*CSFAC(N)
         SNPSUM(N) = SNPSUM(N)+SINTBL(N-JK+1)*SNFAC(N)
  215 CONTINUE
C
      DO 225 JK=3,KKH+1,2
C
         NSTART = MAX0(JK-1,1)
         N = NSTART
         CSFAC(N)  = REAL(JK-2)/REAL(JK-1)*REAL(2*N-JK+3)
     $               /REAL(2*N-JK+2)*CSFAC(N)
         CSPSUM(N) = CSPSUM(N) + CSFAC(N)*0.50
C
         DO 220 N=NSTART+1,KKH
            CSFAC(N)  = REAL(JK-2)/REAL(JK-1)*REAL(2*N-JK+3)
     $                  /REAL(2*N-JK+2)*CSFAC(N)
            SNFAC(N)  = CSFAC(N)*REAL(N-JK+1)*SQNP(N)
            CSPSUM(N) = CSPSUM(N)+COSTBL(N-JK+1)*CSFAC(N)
            SNPSUM(N) = SNPSUM(N)+SINTBL(N-JK+1)*SNFAC(N)
  220    CONTINUE
  225 CONTINUE
C
      RNORM = 1.0/ALP(1)
      DO 230 N=1,KKH
         COL1(N) = AN(N)*CSPSUM(N)*RNORM
         COL2(N) = AN(N)*SNPSUM(N)*RNORM
  230 CONTINUE
C
      DO 260 N=1,KKH
C
C        EVALUATE REMAINING POLYNOMIALS BY SWEEPING THROUGH ROWS N=1:KKH
C        FIRST TWO ELEMENTS OBTAINED FROM THE ABOVE SERIES EXPANSIONS
C
         CN2N1N(1,3) = COL1(N)
         CN2N1N(2,3) = COL2(N)
C
C        NECESSARY DETOUR TO "PRIME THE PIPELINE" (FIRST PASS)
C
         IF (N .EQ. 1) THEN
            CN2N1N(1,2)   = CN2N1N(1,3)
            CN2N1N(2,2)   = CN2N1N(2,3)
            ALP(MMH+2)  = CN2N1N(1,2)
            DALP(MMH+2) = SQRT(3.0)*CN2N1N(1,1)-SNJ*CN2N1N(1,2)
            ALP(2)     = CN2N1N(2,2)
            DALP(2)    = -SNJ*CN2N1N(2,2)
         ELSE
C
C        EVALUATE THE REMAINDER OF THIS ROW (M = 2, 3, 4, ...)
C        USING BELOUSOV'S RECURRENCE RELATION
C
         MLIM = MIN0(MMH,N-1)
         DO 235 M=2,MLIM
            JM = M+1
            CN2N1N(JM,3) = CMN(IDSPR(M,N))*CN2N1N(JM-2,1)
     $                     -SNJ*(DMN(IDSPR(M,N))
     $                     *CN2N1N(JM-2,2) - EMN(IDSPR(M,N))
     $                     *CN2N1N(JM,2))
  235    CONTINUE
C
C        PUT VALUES OF THE POLYNOMIALS CONTAINED IN CN2N1N(0:MLIM,3)
C        INTO THE ASSOCIATED LEGENDRE POLYNOMIAL ARRAY ALP
C
         MSTART = MAX0(N-NNH,0)
         DO 240 M=MSTART,MLIM
            JM = M+1
            ALP(IDSP(M,N)) = CN2N1N(JM,3)
  240    CONTINUE
C
C        SPECIAL EVALUATION REQUIRED FOR DIAGONAL ELEMENT M=N
C
         IF (N .LE. MMH) THEN
            CN2N1N(N+1,3)      = SQRT(1.0 + (1.0/REAL(2*N)))*COS2P
     $                             *CN2N1N(N,2)
            ALP(IDSP(N,N))  = CN2N1N(N+1,3)
            DALP(IDSP(N,N)) = -REAL(N)*SNJ*CN2N1N(N+1,3)
         ENDIF
C
C        MAKE ROOM FOR NEW POLYNOMIAL EVALUATION IN CN2N1N(0:MLIM,3)
C
         DO 250 JM=1,N+1
            CN2N1N(JM,1) = CN2N1N(JM,2)
            CN2N1N(JM,2) = CN2N1N(JM,3)
  250    CONTINUE
         ENDIF
C
  260 CONTINUE
C
C     EFFICIENTLY EVALUATE DERIVATIVES SEPARATELY (ALONG DIAGONALS)
C
      DO 280 JN = 1,NNH
         IS   = LDIAG(JN,2)
         ISM1 = LDIAG(JN-1,2)
         DO 270 M=0,LDIAG(JN,1)-1
            JM = M+1
            N  = JN+M
            DALP(IS+JM) = REAL(2*N+1)*EPSIL(IS+JM)*
     $                  ALP(ISM1+JM)-REAL(N)*SNJ*ALP(IS+JM)
  270    CONTINUE
  280 CONTINUE
C
      RETURN
      END


      SUBROUTINE IDF1 (EE,E2,    ETA01,ZET01,ARE,AIM,BRE,BIM,CRE,CIM,
     1                 R1SQX,XIIJR,XIIJI)
C   ***   INTEGRATES THE PLANAR PARTS OF THE INCREMENTAL
C         OSCILLATORY KERNELS FOR UNSTEADY CASES
      PI   = 3.1415926
      PARN = ETA01**2 - ZET01**2
      FACR = PARN*ARE + ETA01*BRE + CRE
      FACI = PARN*AIM + ETA01*BIM + CIM
      PARNR= BRE/2.0  + ETA01*ARE
      PARNI= BIM/2.0  + ETA01*AIM
      UP   = (ETA01-EE)**2 + ZET01**2
      DOWN = (ETA01+EE)**2 + ZET01**2
      ARG2 = UP/DOWN
      ALARG2 = ALOG(ARG2)
      TRM2R= PARNR * ALOG(ARG2)
      TRM2I= PARNI * ALOG(ARG2)
      TRM3R= 2.0*EE* ARE
      TRM3I= 2.0*EE* AIM
      AZET = ABS(ZET01)
      IF  ((AZET/EE) . LE . 0.001)  GO TO  100
      TEST0= ABS((R1SQX-E2)/(2.0*EE*AZET))
      IF (TEST0.LE.0.0001)  GO TO 110
      COEF = (2.0*EE)/(R1SQX-E2)
      ARGA = COEF*ZET01
      TEST = ABS(ARGA)
      IF (TEST.LE.0.3)  GO TO 120
      ARGT = COEF*AZET
      ATANA= ATAN(ARGT)
      FUNCT= ATANA/AZET
      GO TO 170
  100 CONTINUE
      FUNCT= (2.0*EE)/(ETA01**2-E2)
      GO TO 170
  110 CONTINUE
      FUNCT= 0.0
      GO TO 170
  120 CONTINUE
      S    = ARGA**2
      SER  = 1./3.+S*(-1./5.+S*(1./7.+S*(-1./9.+S*(1./11.-S/13.))))
      ALPHA= E2*(COEF**2)*SER
      FUNCT= COEF*(1.0-ALPHA*(ZET01**2)/E2)
  170 CONTINUE
      TRM1R= FACR * FUNCT
      TRM1I= FACI * FUNCT
      XIIJR= TRM1R + TRM2R + TRM3R
      XIIJI= TRM1I + TRM2I + TRM3I
      RETURN
      END


!****************************************************************************
! WAVETEST: Example Fortran program for WAVELET, using NINO3 SST dataset
!
! COMPILE:   f77 chisqr.f cfftpack.f wavelet.f wavetest.f
!
! See "http://paos.colorado.edu/research/wavelets/"
!
!  Copyright (C) 1998, Christopher Torrence and Gilbert P. Compo
! This software may be used, copied, or redistributed as long as it is not
! sold and this copyright notice is reproduced on each copy made.  This
! routine is provided as is without any express or implied warranties
! whatsoever.
!
! Modified: November 1999 by Arjan van Dijk to include IMPLICIT NONE and
!           to convert all routines to DOUBLE precision.
!****************************************************************************

program wavetest

    use wavepack, only: rk, wavelet, wave_signif
    implicit none

    integer n, subscale, jtot
    real(rk) :: dt, s0, dj

    ! these parameters depend on the particular time series
    parameter(n=504, dt=0.25_rk, s0=dt)
    parameter(subscale=4)
    parameter(dj=1._rk/subscale, jtot=11*subscale)
    ! Note: for accurate reconstruction and wavelet-derived variance
    !     do not pad with zeroes, set s0=dt (for Paul set s0=dt/4), and use
    !     a large "jtot" (even though the extra scales will be within
    !     the cone of influence).
    !     For plotting purposes, it is only necessary to use
    !     s0=2dt (for Morlet) and "jtot" from Eqn(10) Torrence&Compo(1998).

    integer mother, ibase2, npad
    real(rk) :: sst(n), recon_sst(n), param, pi
    real(rk) :: scale(jtot), period(jtot), coi(n)
    double complex wave(n, jtot)

    integer :: i, j, isigtest, javg1, javg2
    real(rk) :: lag1, siglvl, dof(jtot)
    real(rk) :: fft_theor(jtot), signif(jtot), ymean, variance
    real(rk) :: recon_mean, recon_vari
    real(rk) :: cdelta, psi0
    real(rk) :: global_ws(jtot), global_signif(jtot)
    real(rk) :: savg_dof(jtot), savg_signif(jtot), sstenso(n)

    pi = 4._rk*atan(1._rk)
    ibase2 = nint(log(dble(n))/log(2._rk)) + 1
    npad = int(2._rk**ibase2)
    !      npad = n  ! this is for no padding with zeroes

    !*************************************************** Wavelet transform

    !** let the WAVELET subroutine choose the defaults for these:
    mother = 0
    param = 6._rk

    !** read in the NINO3 SST data
    open (unit=11, file='data/sst_nino3.dat', status='old')
    read (11, *) sst
    close (11)
    print '(/,"sst(1)=",f6.2,"  sst(n) = ",f6.2,/)', sst(1), sst(n)

    !** get the wavelet transform
    call wavelet(n, sst, dt, mother, param, s0, dj, jtot, npad, wave, scale, period, coi)

    !*************************************************** Significance testing

    !** local significance test
    isigtest = 0
    lag1 = 0.72_rk
    siglvl = 0.05_rk
    call wave_signif(isigtest, n, sst, dt, mother, param, dj, jtot, scale, period, &
                     lag1, siglvl, dof, fft_theor, signif, ymean, variance, cdelta, psi0)

    !** global wavelet spectrum & significance test
    isigtest = 1
    lag1 = 0.72_rk
    siglvl = 0.05_rk
    do j = 1, jtot
        do i = 1, n
            global_ws(j) = global_ws(j) + abs(wave(i, j))**2
        end do
        global_ws(j) = global_ws(j)/n
        dof(j) = n - scale(j)
    end do

    call wave_signif(isigtest, n, sst, dt, mother, param, dj, jtot, scale, period, &
                     lag1, siglvl, dof, fft_theor, global_signif, ymean, variance, cdelta, psi0)

    !** scale-average time series & significance test
    isigtest = 2
    lag1 = 0.72_rk
    siglvl = 0.05_rk
    !    scale average between 2 and 7.9 years
    savg_dof(1) = 2.0_rk
    savg_dof(2) = 7.9_rk
    !    find the "j"-values that correspond to savg_dof(1) & savg_dof(2)
    javg1 = 0
    javg2 = 0
    do j = 1, jtot
        if ((scale(j) >= savg_dof(1)) .and. (javg1 == 0)) javg1 = j
        if (scale(j) <= savg_dof(2)) javg2 = j
    end do
    !   call wave_signif first, to get the value of "Cdelta"
    call wave_signif(isigtest, n, sst, dt, mother, param, dj, jtot, scale, period, &
                     lag1, siglvl, savg_dof, fft_theor, savg_signif, ymean, variance, cdelta, psi0)
    !   construct the scale-averaged time series [Eqn(24)]
    do i = 1, n
        sstenso(i) = 0._rk
        do j = javg1, javg2
            sstenso(i) = sstenso(i) + (abs(wave(i, j))**2)/scale(j)
        end do
        sstenso(i) = dj*dt*sstenso(i)/cdelta
    end do

    !************************************************************* print results
    print *, ' n=', n
    print *, ' dt=', dt
    print *, ' mother=', mother
    print *, ' param=', param
    print *, ' s0=', s0
    print *, ' dj=', dj
    print *, ' jtot=', jtot
    print *, ' npad=', npad
    print '(/,"let w = wave(n/2,j)",/)'
    print '(a4,7a10)', 'j', 'scale', 'period', 'abs(w)^2', 'phase(w)', '5%signif', 'global', 'gws5%sig'
    print '(i4,7f10.3)', (j, scale(j), period(j), abs(wave(n/2, j))**2, &
                          atan2(dimag(wave(n/2, j)), dble(wave(n/2, j)))*180._rk/pi, &
                          signif(j), global_ws(j), global_signif(j), j=1, jtot)
    print '(/,a,f10.3)', ' scale-average degrees of freedom = ', savg_dof(1)
    print '(a,f10.3,/)', ' scale-avg 5% significance level  = ', savg_signif(1)

    !************************************************************ Reconstruction

    !** construct the wavelet derived variance (Parseval's theorem)  [Eqn(14)]
    !   Cdelta & psi0 are returned from WAVE_SIGNIF
    recon_vari = 0._rk
    do i = 1, n
        do j = 1, jtot
            recon_vari = recon_vari + (abs(wave(i, j))**2)/scale(j)
        end do
    end do
    recon_vari = dj*dt*recon_vari/(cdelta*n)
    print '(a,f14.5)', ' reconstructed variance=', recon_vari
    print '(a,f14.5)', ' original variance   =', variance
    print '(a,f14.5,a,/)', ' ratio = ', recon_vari/variance, ' (this is low due to padding with zeroes)'

    !** reconstruct the time series [Eqn(11)]
    !   check mean and RMS difference of reconstructed time series
    recon_mean = 0._rk
    recon_vari = 0._rk
    do i = 1, n
        recon_sst(i) = 0._rk
        do j = 1, jtot
            recon_sst(i) = recon_sst(i) + (dble(wave(i, j)))/sqrt(scale(j))
        end do
        recon_sst(i) = dj*sqrt(dt)*recon_sst(i)/(cdelta*psi0)
        recon_vari = recon_vari + (sst(i) - ymean - recon_sst(i))**2
        recon_mean = recon_mean + recon_sst(i)
    end do
    recon_mean = recon_mean/n
    recon_vari = sqrt(recon_vari/n)

    print '(a,f14.6)', ' reconstructed mean=', recon_mean
    print '(a,f14.6)', ' original mean   =', ymean
    print '(a,f14.6,/)', ' root-mean-square difference of time series=', recon_vari

end program wavetest


      MODULE LIB_LINPACK_Rdp
      use LIB_LINPACK_BLAS !!((03-A-LIB_LINPACK_BLAS.f))
      INTERFACE GBSL
       MODULE PROCEDURE DGBSL
      END INTERFACE
	INTERFACE GBFA
       MODULE PROCEDURE DGBFA
      END INTERFACE

	CONTAINS

      subroutine dgbfa(abd,lda,n,ml,mu,ipvt,info)
      integer lda,n,ml,mu,ipvt(1),info
      double precision abd(lda,1)
c
c     dgbfa factors a double precision band matrix by elimination.
c
c     dgbfa is usually called by dgbco, but it can be called
c     directly with a saving in time if  rcond  is not needed.
c
c     on entry
c
c        abd     double precision(lda, n)
c                contains the matrix in band storage.  the columns
c                of the matrix are stored in the columns of  abd  and
c                the diagonals of the matrix are stored in rows
c                ml+1 through 2*ml+mu+1 of  abd .
c                see the comments below for details.
c
c        lda     integer
c                the leading dimension of the array  abd .
c                lda must be .ge. 2*ml + mu + 1 .
c
c        n       integer
c                the order of the original matrix.
c
c        ml      integer
c                number of diagonals below the main diagonal.
c                0 .le. ml .lt. n .
c
c        mu      integer
c                number of diagonals above the main diagonal.
c                0 .le. mu .lt. n .
c                more efficient if  ml .le. mu .
c     on return
c
c        abd     an upper triangular matrix in band storage and
c                the multipliers which were used to obtain it.
c                the factorization can be written  a = l*u  where
c                l  is a product of permutation and unit lower
c                triangular matrices and  u  is upper triangular.
c
c        ipvt    integer(n)
c                an integer vector of pivot indices.
c
c        info    integer
c                = 0  normal value.
c                = k  if  u(k,k) .eq. 0.0 .  this is not an error
c                     condition for this subroutine, but it does
c                     indicate that dgbsl will divide by zero if
c                     called.  use  rcond  in dgbco for a reliable
c                     indication of singularity.
c
c     band storage
c
c           if  a  is a band matrix, the following program segment
c           will set up the input.
c
c                   ml = (band width below the diagonal)
c                   mu = (band width above the diagonal)
c                   m = ml + mu + 1
c                   do 20 j = 1, n
c                      i1 = max0(1, j-mu)
c                      i2 = min0(n, j+ml)
c                      do 10 i = i1, i2
c                         k = i - j + m
c                         abd(k,j) = a(i,j)
c                10    continue
c                20 continue
c
c           this uses rows  ml+1  through  2*ml+mu+1  of  abd .
c           in addition, the first  ml  rows in  abd  are used for
c           elements generated during the triangularization.
c           the total number of rows needed in  abd  is  2*ml+mu+1 .
c           the  ml+mu by ml+mu  upper left triangle and the
c           ml by ml  lower right triangle are not referenced.
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,dscal,idamax
c     fortran max0,min0
c
c     internal variables
c
      double precision t
      integer i,i0,j,ju,jz,j0,j1,k,kp1,l,lm,m,mm,nm1
c
c
      m = ml + mu + 1
      info = 0
c
c     zero initial fill-in columns
c
      j0 = mu + 2
      j1 = min0(n,m) - 1
      if (j1 .lt. j0) go to 30
      do 20 jz = j0, j1
         i0 = m + 1 - jz
         do 10 i = i0, ml
            abd(i,jz) = 0.0d0
   10    continue
   20 continue
   30 continue
      jz = j1
      ju = 0
c
c     gaussian elimination with partial pivoting
c
      nm1 = n - 1
      if (nm1 .lt. 1) go to 130
      do 120 k = 1, nm1
         kp1 = k + 1
c
c        zero next fill-in column
c
         jz = jz + 1
         if (jz .gt. n) go to 50
         if (ml .lt. 1) go to 50
            do 40 i = 1, ml
               abd(i,jz) = 0.0d0
   40       continue
   50    continue
c
c        find l = pivot index
c
         lm = min0(ml,n-k)
         l = idamax(lm+1,abd(m,k),1) + m - 1
         ipvt(k) = l + k - m
c
c        zero pivot implies this column already triangularized
c
         if (abd(l,k) .eq. 0.0d0) go to 100
c
c           interchange if necessary
c
            if (l .eq. m) go to 60
               t = abd(l,k)
               abd(l,k) = abd(m,k)
               abd(m,k) = t
   60       continue
c
c           compute multipliers
c
            t = -1.0d0/abd(m,k)
            call dscal(lm,t,abd(m+1,k),1)
c
c           row elimination with column indexing
c
            ju = min0(max0(ju,mu+ipvt(k)),n)
            mm = m
            if (ju .lt. kp1) go to 90
            do 80 j = kp1, ju
               l = l - 1
               mm = mm - 1
               t = abd(l,j)
               if (l .eq. mm) go to 70
                  abd(l,j) = abd(mm,j)
                  abd(mm,j) = t
   70          continue
               call daxpy(lm,t,abd(m+1,k),1,abd(mm+1,j),1)
   80       continue
   90       continue
         go to 110
  100    continue
            info = k
  110    continue
  120 continue
  130 continue
      ipvt(n) = n
      if (abd(m,n) .eq. 0.0d0) info = n
      return
      end subroutine

      subroutine dgbsl(abd,lda,n,ml,mu,ipvt,b,job)
      integer lda,n,ml,mu,ipvt(1),job
      double precision abd(lda,1),b(1)
c
c     dgbsl solves the double precision band system
c     a * x = b  or  trans(a) * x = b
c     using the factors computed by dgbco or dgbfa.
c
c     on entry
c
c        abd     double precision(lda, n)
c                the output from dgbco or dgbfa.
c
c        lda     integer
c                the leading dimension of the array  abd .
c
c        n       integer
c                the order of the original matrix.
c
c        ml      integer
c                number of diagonals below the main diagonal.
c
c        mu      integer
c                number of diagonals above the main diagonal.
c
c        ipvt    integer(n)
c                the pivot vector from dgbco or dgbfa.
c
c        b       double precision(n)
c                the right hand side vector.
c
c        job     integer
c                = 0         to solve  a*x = b ,
c                = nonzero   to solve  trans(a)*x = b , where
c                            trans(a)  is the transpose.
c
c     on return
c
c        b       the solution vector  x .
c
c     error condition
c
c        a division by zero will occur if the input factor contains a
c        zero on the diagonal.  technically this indicates singularity
c        but it is often caused by improper arguments or improper
c        setting of lda .  it will not occur if the subroutines are
c        called correctly and if dgbco has set rcond .gt. 0.0
c        or dgbfa has set info .eq. 0 .
c
c     to compute  inverse(a) * c  where  c  is a matrix
c     with  p  columns
c           call dgbco(abd,lda,n,ml,mu,ipvt,rcond,z)
c           if (rcond is too small) go to ...
c           do 10 j = 1, p
c              call dgbsl(abd,lda,n,ml,mu,ipvt,c(1,j),0)
c        10 continue
c
c     linpack. this version dated 08/14/78 .
c     cleve moler, university of new mexico, argonne national lab.
c
c     subroutines and functions
c
c     blas daxpy,ddot
c     fortran min0
c
c     internal variables
c
      double precision t
      integer k,kb,l,la,lb,lm,m,nm1
c
      m = mu + ml + 1
      nm1 = n - 1
      if (job .ne. 0) go to 50
c
c        job = 0 , solve  a * x = b
c        first solve l*y = b
c
         if (ml .eq. 0) go to 30
         if (nm1 .lt. 1) go to 30
            do 20 k = 1, nm1
               lm = min0(ml,n-k)
               l = ipvt(k)
               t = b(l)
               if (l .eq. k) go to 10
                  b(l) = b(k)
                  b(k) = t
   10          continue
               call daxpy(lm,t,abd(m+1,k),1,b(k+1),1)
   20       continue
   30    continue
c
c        now solve  u*x = y
c
         do 40 kb = 1, n
            k = n + 1 - kb
            b(k) = b(k)/abd(m,k)
            lm = min0(k,m) - 1
            la = m - lm
            lb = k - lm
            t = -b(k)
            call daxpy(lm,t,abd(la,k),1,b(lb),1)
   40    continue
      go to 100
   50 continue
c
c        job = nonzero, solve  trans(a) * x = b
c        first solve  trans(u)*y = b
c
         do 60 k = 1, n
            lm = min0(k,m) - 1
            la = m - lm
            lb = k - lm
            t = ddot(lm,abd(la,k),1,b(lb),1)
            b(k) = (b(k) - t)/abd(m,k)
   60    continue
c
c        now solve trans(l)*x = y
c
         if (ml .eq. 0) go to 90
         if (nm1 .lt. 1) go to 90
            do 80 kb = 1, nm1
               k = n - kb
               lm = min0(ml,n-k)
               b(k) = b(k) + ddot(lm,abd(m+1,k),1,b(k+1),1)
               l = ipvt(k)
               if (l .eq. k) go to 70
                  t = b(l)
                  b(l) = b(k)
                  b(k) = t
   70          continue
   80       continue
   90    continue
  100 continue
      return
      end subroutine

      END MODULE


*DECK ASINH
      FUNCTION ASINH (X)
C***BEGIN PROLOGUE  ASINH
C***PURPOSE  Compute the arc hyperbolic sine.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4C
C***TYPE      SINGLE PRECISION (ASINH-S, DASINH-D, CASINH-C)
C***KEYWORDS  ARC HYPERBOLIC SINE, ASINH, ELEMENTARY FUNCTIONS, FNLIB,
C             INVERSE HYPERBOLIC SINE
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C ASINH(X) computes the arc hyperbolic sine of X.
C
C Series for ASNH       on the interval  0.          to  1.00000D+00
C                                        with weighted error   2.19E-17
C                                         log weighted error  16.66
C                               significant figures required  15.60
C                                    decimal places required  17.31
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  CSEVL, INITS, R1MACH
C***REVISION HISTORY  (YYMMDD)
C   770401  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  ASINH
      DIMENSION ASNHCS(20)
      LOGICAL FIRST
      SAVE ALN2, ASNHCS, NTERMS, XMAX, SQEPS, FIRST
      DATA ALN2 /0.6931471805 5994530942E0/
      DATA ASNHCS( 1) /   -.1282003991 1738186E0 /
      DATA ASNHCS( 2) /   -.0588117611 89951768E0 /
      DATA ASNHCS( 3) /    .0047274654 32212481E0 /
      DATA ASNHCS( 4) /   -.0004938363 16265361E0 /
      DATA ASNHCS( 5) /    .0000585062 07058557E0 /
      DATA ASNHCS( 6) /   -.0000074669 98328931E0 /
      DATA ASNHCS( 7) /    .0000010011 69358355E0 /
      DATA ASNHCS( 8) /   -.0000001390 35438587E0 /
      DATA ASNHCS( 9) /    .0000000198 23169483E0 /
      DATA ASNHCS(10) /   -.0000000028 84746841E0 /
      DATA ASNHCS(11) /    .0000000004 26729654E0 /
      DATA ASNHCS(12) /   -.0000000000 63976084E0 /
      DATA ASNHCS(13) /    .0000000000 09699168E0 /
      DATA ASNHCS(14) /   -.0000000000 01484427E0 /
      DATA ASNHCS(15) /    .0000000000 00229037E0 /
      DATA ASNHCS(16) /   -.0000000000 00035588E0 /
      DATA ASNHCS(17) /    .0000000000 00005563E0 /
      DATA ASNHCS(18) /   -.0000000000 00000874E0 /
      DATA ASNHCS(19) /    .0000000000 00000138E0 /
      DATA ASNHCS(20) /   -.0000000000 00000021E0 /
      DATA FIRST /.TRUE./
C***FIRST EXECUTABLE STATEMENT  ASINH
      IF (FIRST) THEN
         NTERMS = INITS (ASNHCS, 20, 0.1*R1MACH(3))
         SQEPS = SQRT (R1MACH(3))
         XMAX = 1.0/SQEPS
      ENDIF
      FIRST = .FALSE.
C
      Y = ABS(X)
      IF (Y.GT.1.0) GO TO 20
C
      ASINH = X
      IF (Y.GT.SQEPS) ASINH = X*(1.0 + CSEVL (2.*X*X-1., ASNHCS,NTERMS))
      RETURN
C
 20   IF (Y.LT.XMAX) ASINH = LOG (Y + SQRT(Y**2+1.))
      IF (Y.GE.XMAX) ASINH = ALN2 + LOG(Y)
      ASINH = SIGN (ASINH, X)
C
      RETURN
      END


! 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
    implicit none
    integer, parameter :: latt_leng = 30
    integer, parameter :: EXCH_CONST = 1 ! exchange constant
    integer, parameter :: n_T_step = 500
    double precision, parameter :: T_start = 0.5d0
    double precision, parameter :: T_end = 3.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
module Class_Site
    implicit none

    type, public :: Site
    integer :: x, y, spin
    end type
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, parameter :: MC_max = 100* latt_leng**2  ! number of iteration of MC simulation per temperature
    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(2) ! 1 : random, 2 : aligned
    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_wolff(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) ! switch = 1 for <E> data file, 2 for <M>, 3 for <Cv>
    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 flip_sites_wolff(T, MC_max, avg_en, avg_mag, avg_en2)
    use parameters
    use Class_Site
    implicit none
!    interface
!        subroutine resize(arr, capacity_new)
!            use Class_Site
!            integer, intent(in) :: capacity_new
!            integer :: capacity_old
!            type(Site), dimension(:), allocatable, intent(inout) :: arr
!            type(Site), dimension(:), allocatable :: temp
!        end subroutine

!        subroutine print_clstr_bag(clstr_bag)
!            use Class_Site
!            implicit none
!            integer :: i
!            type(Site), dimension(:), allocatable, intent(in):: clstr_bag
!        end subroutine

!        subroutine print_bndry_bag(bndry_bag)
!            use Class_Site
!            implicit none
!            integer :: i
!            type(Site), dimension(:), allocatable, intent(in) :: bndry_bag
!        end subroutine
!    end interface

    logical, dimension(0 : latt_leng - 1, 0 : latt_leng - 1) :: is_in_clstr_bag
    integer :: i, j, x, y, ran_index, MC_step, n_sample
    integer :: n_site_bndry_bag, n_site_clstr_bag, size_clstr_bag, size_bndry_bag
    integer, intent(in) :: MC_max
    type(Site), dimension(0 : latt_leng**2 - 1) :: clstr_bag
    type(Site), dimension(0 : latt_leng**2 - 1) :: bndry_bag
    type(Site), dimension(0:3) :: nbr_site_bag
    double precision, intent(in) :: T ! unit = kT/J
    double precision, intent(out) :: avg_en, avg_en2, avg_mag
    double precision :: accept_prob, tot_en, tot_mag, tot_en2, sum_tot_E, sum_tot_M, sum_tot_E2
    double precision :: u, v, w, r

    n_sample = 0 ! Initialize variables and arrays
    n_site_clstr_bag = 0
    n_site_bndry_bag = 0
    size_clstr_bag = 0
    size_bndry_bag = 0
    is_in_clstr_bag (:, :) = .false.
    nbr_site_bag(:) = Site(0, 0, 0)
    clstr_bag(:) = Site(0, 0, 0)
    bndry_bag(:) = Site(0, 0, 0)
    sum_tot_E = 0d0
    sum_tot_M = 0d0
    sum_tot_E2 = 0d0
    accept_prob = 1 - exp(-2*T)

    do MC_step = 0, MC_max - 1
!        print *, "                                                        "
!        print *, "++++++++++++++++++MC Iteration Start++++++++++++++++++++"
        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)
        !allocate(clstr_bag(0:1))
        !allocate(bndry_bag(0:1))
        !size_clstr_bag = 2
        !size_bndry_bag = 2
        !clstr_bag(:) = Site(0, 0, 0)
        !bndry_bag(:) = Site(0, 0, 0)
        clstr_bag(0) = Site(x, y, spin_of(x, y))
        bndry_bag(0) = Site(x, y, spin_of(x, y))
        is_in_clstr_bag(x, y) = .true.
        n_site_clstr_bag = n_site_clstr_bag + 1
        n_site_bndry_bag = n_site_bndry_bag + 1
!        call print_bndry_bag(bndry_bag, n_site_bndry_bag)
!        call print_clstr_bag(clstr_bag, n_site_clstr_bag)
!        call print_spin_of
!        call print_is_in_clstr_bag(is_in_clstr_bag)
!        call print_nbr_site_bag(nbr_site_bag)
!        print *, "++++++++++++++++++Form Cluster Start++++++++++++++++++++"
        do while (n_site_bndry_bag > 0)
            call random_number(w)
            ran_index = FLOOR(w * n_site_bndry_bag) ! Pick random site from clstr_bag, [0, n_site_clstr_bag - 1]

            nbr_site_bag(0)%x = bndry_bag(ran_index)%x - 1 ! Assign nbr sites to nbr_site_bag
            nbr_site_bag(0)%y = bndry_bag(ran_index)%y
            nbr_site_bag(0)%spin = spin_of(nbr_site_bag(0)%x, nbr_site_bag(0)%y)
            nbr_site_bag(1)%x = bndry_bag(ran_index)%x + 1
            nbr_site_bag(1)%y = bndry_bag(ran_index)%y
            nbr_site_bag(1)%spin = spin_of(nbr_site_bag(1)%x, nbr_site_bag(1)%y)
            nbr_site_bag(2)%x = bndry_bag(ran_index)%x
            nbr_site_bag(2)%y = bndry_bag(ran_index)%y - 1
            nbr_site_bag(2)%spin = spin_of(nbr_site_bag(2)%x, nbr_site_bag(2)%y)
            nbr_site_bag(3)%x = bndry_bag(ran_index)%x
            nbr_site_bag(3)%y = bndry_bag(ran_index)%y + 1
            nbr_site_bag(3)%spin = spin_of(nbr_site_bag(3)%x, nbr_site_bag(3)%y)

            do i = 0, 3 ! Add nbr_sites to cluster with magic probability = 1-exp(-2beta)
                call cnvrt_padng_to_latt(nbr_site_bag(i)%x, nbr_site_bag(i)%y) ! convert padding sites to original sites, two if-else if checks
                if (.not.(is_in_clstr_bag(nbr_site_bag(i)%x, nbr_site_bag(i)%y)) &
                .and. (nbr_site_bag(i)%spin == bndry_bag(ran_index)%spin)) then
                    call random_number(r) ![0, 1)
                    if (r < accept_prob) then
!                        if(n_site_clstr_bag == size_clstr_bag) then ! resize if necessary
!                            call resize(clstr_bag, 2*size_clstr_bag)
!                            size_clstr_bag = 2*size_clstr_bag
!                        else if (n_site_clstr_bag <= size_clstr_bag/4) then
!                            call resize(clstr_bag, size_clstr_bag/2)
!                            size_clstr_bag = size_clstr_bag/2
!                        end if
!                        if(n_site_bndry_bag == size_bndry_bag) then  ! resize if necessary
!                            call resize(bndry_bag, 2*size_bndry_bag)
!                            size_bndry_bag = 2*size_bndry_bag
!                        else if (n_site_bndry_bag <= size_bndry_bag/4) then
!                            call resize(bndry_bag, size_bndry_bag/2)
!                            size_bndry_bag = size_bndry_bag/2
!                        end if

                        clstr_bag(n_site_clstr_bag) = Site(nbr_site_bag(i)%x, nbr_site_bag(i)%y, &
                        spin_of(nbr_site_bag(i)%x, nbr_site_bag(i)%y))
                        bndry_bag(n_site_bndry_bag) = Site(nbr_site_bag(i)%x, nbr_site_bag(i)%y, &
                        spin_of(nbr_site_bag(i)%x, nbr_site_bag(i)%y))
                        is_in_clstr_bag(nbr_site_bag(i)%x, nbr_site_bag(i)%y) = .true.
                        n_site_clstr_bag = n_site_clstr_bag + 1
                        n_site_bndry_bag = n_site_bndry_bag + 1
                    end if
                end if
            end do
            bndry_bag(ran_index) = bndry_bag(n_site_bndry_bag - 1) ! Pop chosen random site from bndry_bag
            bndry_bag(n_site_bndry_bag - 1) = Site(0, 0, 0)
            n_site_bndry_bag = n_site_bndry_bag - 1
        end do
!        print *, "++++++++++++++++++Form Cluster End++++++++++++++++++++"
!        call print_bndry_bag(bndry_bag, n_site_bndry_bag)
!        call print_clstr_bag(clstr_bag, n_site_clstr_bag)
!        call print_spin_of
!        call print_is_in_clstr_bag(is_in_clstr_bag)
!        call print_nbr_site_bag(nbr_site_bag)
!        print *, "++++++++++++++++++Flip Cluster Start++++++++++++++++++++"
        do j = 0, n_site_clstr_bag - 1 ! Flip sites in clstr_bag
            spin_of(clstr_bag(j)%x, clstr_bag(j)%y) = - spin_of(clstr_bag(j)%x, clstr_bag(j)%y)
            if (clstr_bag(j)%x == 0) then ! Update padding sites
                spin_of(latt_leng, clstr_bag(j)%y) = spin_of(clstr_bag(j)%x, clstr_bag(j)%y)
            else if (clstr_bag(j)%x == latt_leng - 1) then
                spin_of(-1, clstr_bag(j)%y) = spin_of(clstr_bag(j)%x, clstr_bag(j)%y)
            end if
            if (clstr_bag(j)%y == 0) then
                spin_of(clstr_bag(j)%x, latt_leng) = spin_of(clstr_bag(j)%x, clstr_bag(j)%y)
            else if (clstr_bag(j)%y == latt_leng - 1) then
                spin_of(clstr_bag(j)%x, -1) = spin_of(clstr_bag(j)%x, clstr_bag(j)%y)
            end if
        end do
!        print *, "++++++++++++++++++Flip Cluster End++++++++++++++++++++"
!        call print_bndry_bag(bndry_bag, n_site_bndry_bag)
!        call print_clstr_bag(clstr_bag, n_site_clstr_bag)
!        call print_spin_of
!        call print_is_in_clstr_bag(is_in_clstr_bag)
!        call print_nbr_site_bag(nbr_site_bag)
!        print *, "++++++++++++++++++Deallocate Start++++++++++++++++++++"
        !deallocate(clstr_bag)
        !deallocate(bndry_bag)
        !size_clstr_bag = 0
        !size_bndry_bag = 0
        nbr_site_bag(:) = Site(0, 0, 0)
        is_in_clstr_bag(:, :) = .false.
        n_site_clstr_bag = 0
        n_site_bndry_bag = 0
        do i = 0, n_site_clstr_bag - 1
            clstr_bag(:) = Site(0, 0, 0)
            bndry_bag(:) = Site(0, 0, 0)
        end do
!        print *, "++++++++++++++++++Deallocate End++++++++++++++++++++"
!        call print_bndry_bag(bndry_bag, n_site_bndry_bag)
!        call print_clstr_bag(clstr_bag, n_site_clstr_bag)
!        call print_spin_of
!        call print_is_in_clstr_bag(is_in_clstr_bag)
!        call print_nbr_site_bag(nbr_site_bag)
!        print *, "++++++++++++++++++Add to Ensemble Start++++++++++++++++++++"
        if (MC_step > MC_step / 2 .and. MOD(MC_step, latt_leng**2) == 0) then ! Create ensemble for sampled microstates
            tot_en = 0d0
            tot_mag = 0d0
            tot_en2 = 0d0
            call compute_tot_E_M_E2(tot_en, tot_mag, tot_en2)
            sum_tot_E = sum_tot_E + tot_en
            sum_tot_M = sum_tot_M + tot_mag ! The value M can flip due to fluctuation
            sum_tot_E2 = sum_tot_E2 + tot_en2
            n_sample = n_sample + 1
!            print *, "sum_tot_E =", sum_tot_E
!            print *, "sum_tot_M =", sum_tot_M
!            print *, "sum_tot_E2 =", sum_tot_E2
!            print *, "tot_en = ", tot_en
!            print *, "tot_mag = ", tot_mag
!            print *, "tot_en2 = ", tot_en2
!            print *, "n_sample = ", n_sample
        end if
!        print *, "++++++++++++++++++Add to Ensemble End++++++++++++++++++++"
!        print *, "++++++++++++++++++MC Iteration End++++++++++++++++++++"
    end do
!    print *, "++++++++++++++++++Ensemble averaging Start++++++++++++++++++++"
    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 create_lattice(switch)
    use parameters
    implicit none
    integer :: x, y
    integer, intent(in) :: switch
    double precision :: u

    if (switch == 1) then ! random
        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

    else if (switch == 2) then ! Aligned, i.e., All up spins
        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 if
end subroutine
subroutine resize(arr, capacity_new)
    use Class_Site
    implicit none

    integer, intent(in) :: capacity_new
    integer :: i, capacity_old
    type(Site), dimension(:), allocatable, intent(inout) :: arr
    type(Site), dimension(:), allocatable :: temp

    capacity_old = size(arr)
    allocate(temp(0:capacity_new-1))
    temp(:) = Site(0, 0, 0)
    do i = 0, min(capacity_old, capacity_new)-1
        temp(i) = arr(i)
    end do
    deallocate(arr)
    allocate(arr(0:capacity_new-1))
    arr(:) = Site(0, 0, 0)
    do i = 0, min(capacity_old, capacity_new)-1
        arr(i) = temp(i)
    end do
    deallocate(temp)
end subroutine
subroutine cnvrt_padng_to_latt(x, y)
    use parameters
    implicit none
    integer, intent(inout) :: x, y

    if (x == -1) then ! Check if the nbr site is a padding site
        x = latt_leng - 1
    else if (x == latt_leng) then
        x = 0
    end if
    if (y == -1) then
        y = latt_leng - 1
    else if (y == latt_leng) then
        y = 0
    end if
end subroutine
subroutine compute_tot_E_M_E2(tot_E, tot_M, tot_E2)
    use parameters
    implicit none
    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
    implicit none
    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
    implicit none
    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
    implicit none
    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
    implicit none
    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_clstr_avg_E_change.txt', action = "write", STATUS = 'replace')
    else if (switch == 2) then
        open (out_unit1, FILE = 'output_ising_model_clstr_avg_M_change.txt', action = "write", STATUS = 'replace')
    else if (switch == 3) then
        open (out_unit1, FILE = 'output_ising_model_clstr_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_clstr_avg_E_change_plot.txt', action = "write", STATUS = 'replace')
    else if (switch == 2) then
        open (out_unit2, FILE = 'output_ising_model_clstr_avg_M_change_plot.txt', action = "write", STATUS = 'replace')
    else if (switch == 3) then
        open (out_unit2, FILE = 'output_ising_model_clstr_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

!For debugging
subroutine test_cpu_time
    real :: start, finish
    call cpu_time(start)
    ! put code to test here
    call cpu_time(finish)
    print '("Time = ",f6.3," seconds.")',finish-start
end subroutine
subroutine print_clstr_bag(clstr_bag)
    use Class_Site
    implicit none
    integer :: i
    type(Site), dimension(:), allocatable, intent(in):: clstr_bag

    do i = 0, size(clstr_bag) - 1
        print *, clstr_bag(i)%x, clstr_bag(i)%y, clstr_bag(i)%spin
    end do
    !print *, "n_site_clstr_bag = ", n_site_clstr_bag
    !print *, "size_clstr_bag = ", size(clstr_bag)
    print *, "======clstr_bag======"
end subroutine
subroutine print_bndry_bag(bndry_bag)
    use Class_Site
    implicit none
    integer :: i
    type(Site), dimension(:), allocatable, intent(in) :: bndry_bag

    do i = 0, size(bndry_bag) - 1
    print *, bndry_bag(i)%x, bndry_bag(i)%y, bndry_bag(i)%spin
    end do
    !print *, "n_site_bndry_bag = ", n_site_bndry_bag
    !print *, "size_bndry_bag = ", size_bndry_bag
    print *, "======bndry_bag======"
end subroutine
subroutine print_spin_of
    use Class_Site
    use parameters
    implicit none
    integer :: i

    do i = -1, latt_leng
        print *, spin_of(:, i)
    end do
    print *, "======spin_of======"
end subroutine
subroutine print_is_in_clstr_bag(arr)
    use Class_Site
    use parameters
    implicit none
    integer :: i
    logical, dimension(0 : latt_leng - 1, 0 : latt_leng - 1) :: arr

    do i = 0, latt_leng - 1
        print *, arr(0:, i)
    end do
    print *, "======is_in_clstr_bag======"
end subroutine
subroutine print_nbr_site_bag(arr)
    use Class_Site
    implicit none
    integer :: i
    type(Site), dimension(0:3), intent(in) :: arr

    do i = 0, 3
    print *, arr(i)%x, arr(i)%y, arr(i)%spin
    end do
    print *, "======nbr_site_bag======"
end subroutine


module time_utilities

contains

subroutine date_from_since(since_date, sec_since, current_date)

! create date string from since_date date string and number of seconds since
! offset_ss can be used to adjust for time zone

implicit none
character*19 :: since_date, current_date  ! format: yyyy-mm-dd hh:nn:ss
double precision      :: sec_since
integer      :: count_sec, count_sav
integer      :: since_yyyy, since_mm, since_dd, since_hh, since_nn, since_ss
integer      :: current_yyyy, current_mm, current_dd, current_hh, current_nn, current_ss
logical      :: leap_year = .false.
integer      :: num_leap = 0
integer      :: iyyyy, imm, limit
integer, dimension(12), parameter :: days_in_mm = (/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /)

  current_date = "xxxx-xx-xx xx:xx:xx"

  limit = huge(1)
  if(sec_since > limit .or. sec_since < 0) stop "not capable of dealing with sec_since"

  read(since_date( 1: 4),  '(i4)') since_yyyy
  read(since_date( 6: 7),  '(i2)') since_mm
  read(since_date( 9:10),  '(i2)') since_dd
  read(since_date(12:13),  '(i2)') since_hh
  read(since_date(15:16),  '(i2)') since_nn
  read(since_date(18:19),  '(i2)') since_ss

! reset to beginning of since_year

  count_sec = 0
  if(mod(since_yyyy,4) == 0) leap_year = .true.

  do imm = 1,since_mm-1
    count_sec = count_sec - days_in_mm(imm)*86400
  end do

  if(leap_year .and. since_mm > 2) count_sec = count_sec - 86400
  count_sec = count_sec - (since_dd - 1) * 86400
  count_sec = count_sec - (since_hh) * 3600
  count_sec = count_sec - (since_nn) * 60
  count_sec = count_sec - (since_ss)

! not worrying about the complexity of non-recent leap years

! find the year

  current_yyyy = since_yyyy

  do while (count_sec <= sec_since)
    count_sav = count_sec
    if(mod(current_yyyy,4) == 0) then
      count_sec = count_sec + 366*86400
    else
      count_sec = count_sec + 365*86400
    end if
    current_yyyy = current_yyyy + 1
  end do

  count_sec = count_sav
  current_yyyy = current_yyyy - 1

! find the month

  current_mm = 0!since_mm

  leap_year = .false.
  if(mod(current_yyyy,4) == 0) leap_year = .true.

  do while (count_sec <= sec_since)
    count_sav = count_sec
    current_mm = current_mm + 1
    if(leap_year .and. current_mm == 2) then
      count_sec = count_sec + 29*86400
    else
      count_sec = count_sec + days_in_mm(current_mm)*86400
    end if
  end do

  count_sec = count_sav

! find the day

  current_dd = 0!since_dd

  do while (count_sec <= sec_since)
    current_dd = current_dd + 1
    count_sav = count_sec
    count_sec = count_sec + 86400
  end do

  count_sec = count_sav

! find the hour

  current_hh = -1!since_hh

  do while (count_sec <= sec_since)
    current_hh = current_hh + 1
    count_sav = count_sec
    count_sec = count_sec + 3600
  end do

  count_sec = count_sav

! find the minute

  current_nn = -1!since_nn

  do while (count_sec <= sec_since)
    current_nn = current_nn + 1
    count_sav = count_sec
    count_sec = count_sec + 60
  end do

  count_sec = count_sav

  current_ss = sec_since - count_sec

  write(current_date( 1: 4),  '(i4.4)') current_yyyy
  write(current_date( 6: 7),  '(i2.2)') current_mm
  write(current_date( 9:10),  '(i2.2)') current_dd
  write(current_date(12:13),  '(i2.2)') current_hh
  write(current_date(15:16),  '(i2.2)') current_nn
  write(current_date(18:19),  '(i2.2)') current_ss

end subroutine date_from_since

subroutine calc_sec_since(since_date, current_date, offset_ss, sec_since)

! calculate number of seconds between since_date and current_date

double precision      :: sec_since
character*19 :: since_date, current_date  ! format: yyyy-mm-dd hh:nn:ss
integer      :: offset_ss
integer      :: since_yyyy, since_mm, since_dd, since_hh, since_nn, since_ss
integer      :: current_yyyy, current_mm, current_dd, current_hh, current_nn, current_ss
logical      :: leap_year = .false.
integer      :: iyyyy, imm
integer, dimension(12), parameter :: days_in_mm = (/31, 28, 31, 30, 31, 30, 31, 31, 30, 31, 30, 31 /)

  sec_since = 0

  read(since_date( 1: 4),  '(i4)') since_yyyy
  read(since_date( 6: 7),  '(i2)') since_mm
  read(since_date( 9:10),  '(i2)') since_dd
  read(since_date(12:13),  '(i2)') since_hh
  read(since_date(15:16),  '(i2)') since_nn
  read(since_date(18:19),  '(i2)') since_ss

  read(current_date( 1: 4),  '(i4)') current_yyyy
  read(current_date( 6: 7),  '(i2)') current_mm
  read(current_date( 9:10),  '(i2)') current_dd
  read(current_date(12:13),  '(i2)') current_hh
  read(current_date(15:16),  '(i2)') current_nn
  read(current_date(18:19),  '(i2)') current_ss

! not worrying about the complexity of non-recent leap years

! calculate number of seconds in all years
  do iyyyy = since_yyyy, current_yyyy
    if(mod(iyyyy,4) == 0) then
      sec_since = sec_since + 366*86400
    else
      sec_since = sec_since + 365*86400
    end if
  end do

! remove seconds from since_year
  if(mod(since_yyyy,4) == 0) leap_year = .true.

  do imm = 1,since_mm-1
    sec_since = sec_since - days_in_mm(imm)*86400
  end do

  if(leap_year .and. since_mm > 2) sec_since = sec_since - 86400

  sec_since = sec_since - (since_dd - 1) * 86400

  sec_since = sec_since - (since_hh) * 3600

  sec_since = sec_since - (since_nn) * 60

  sec_since = sec_since - (since_ss)

! remove seconds in current_year
  leap_year = .false.
  if(mod(current_yyyy,4) == 0) leap_year = .true.

  do imm = current_mm+1, 12
    sec_since = sec_since - days_in_mm(imm)*86400
  end do
  if(leap_year .and. current_mm < 3) sec_since = sec_since - 86400

  sec_since = sec_since - (days_in_mm(current_mm) - current_dd) * 86400

  sec_since = sec_since - (23 - current_hh) * 3600

  sec_since = sec_since - (59 - current_nn) * 60

  sec_since = sec_since - (60 - current_ss)

  sec_since = sec_since + offset_ss

end subroutine calc_sec_since

end module time_utilities