program SphereMLSQTester

use NumberKindsModule
use OutputWriterModule
use LoggerModule
use PolyMesh2dModule
use ParticlesModule
use EdgesModule
use FacesModule
use STDIntVectorModule
use FieldModule
use SphereGeomModule
use MPISetupModule
use MLSQModule

implicit none

include 'mpif.h'

!
!	logger / console output
!
type(Logger) :: exeLog
character(len=MAX_STRING_LENGTH) :: logstring
character(len=18) :: logKey = "sphereMLSQ"
integer(kint), parameter :: logLevel = DEBUG_LOGGING_LEVEL
!
!	mesh
!
type(PolyMesh2d) :: sphere
integer(kint) :: initNest
integer(kint) :: maxNest
integer(kint) :: amrLimit
real(kreal) :: radius
integer(kint) :: faceType
integer(kint) :: meshSeed
!
!	interpolation
!
type(MLSQ) :: scalarMlsq, vectorMlsq
real(kreal), allocatable :: lons(:)
real(kreal), allocatable :: lats(:)
real(kreal), allocatable :: scalarInterp(:,:), scalarGradX(:,:), scalarGradY(:,:), scalarGradZ(:,:), scalarLap(:,:)
real(kreal), allocatable :: exactScalar(:,:), exactScalarGradX(:,:), exactScalarGradY(:,:), exactScalarGradZ(:,:)
real(kreal), allocatable :: exactScalarLap(:,:)
integer(kint) :: nLon, nLat

type(Field) :: testScalar, testVector
type(Field) :: estGrad
type(Field) :: estLap
type(Field) :: exactGrad
type(Field) :: exactLap
type(Field) :: estDoubleDot
type(Field) :: exactDoubleDot

!
!	MPI
!
type(MPISetup) :: interpMPI
integer(kint) :: mpiErrCode

!
!	general
!
real(kreal) :: programStart, programEnd
integer(kint) :: i, j
character(len=MAX_STRING_LENGTH) :: namelistFile, outputDir, outputRoot, matlabFile, vtkFile
character(len=12) :: meshString
real(kreal) :: xij(3), vecA(3)

namelist /mlsqTest/ initNest, faceType, radius, nLon, outputDir, outputRoot

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! PROGRAM START
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	Initialize 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)

call ReadNamelistFile(procRank)

programStart = MPI_WTIME()

!
!	Initialize sphere mesh
!
amrLimit = 0
maxNest = initNest
call New(sphere, meshSeed, initNest, maxNest, amrLimit, radius )

call LogStats(sphere, exeLog)

!
!	Initialize interpolation tests
!
allocate(lons(nLon))
allocate(lats(nLat))
allocate(scalarInterp(nLat, nLon))
allocate(scalarGradX(nLat, nLon))
allocate(scalarGradY(nLat, nLon))
allocate(scalarGradZ(nLat, nLon))
allocate(scalarLap(nLat, nLon))
allocate(exactScalar(nLat, nLon))
allocate(exactScalarGradX(nLat, nLon))
allocate(exactScalarGradY(nLat, nLon))
allocate(exactScalarGradZ(nLat, nLon))
allocate(exactScalarLap(nLat,nLon))

do j = 1, nLon
	lons(j) = real(j-1, kreal) * DEG_2_RAD
enddo
do i = 1, nLat
	lats(i) = -0.5_kreal * PI + real(i-1,kreal) * DEG_2_RAD
enddo

call New(testScalar, 1, sphere%particles%N, 'sphHarm', 'n/a')
call New(testVector, 3, sphere%particles%N, 'tangentVector','n/a')
call New(estGrad, 3, sphere%particles%N, 'estGrad', 'n/a')
call New(exactGrad, 3, sphere%particles%N, 'exactGrad', 'n/a')
call New(estLap, 1, sphere%particles%N, 'estLap', 'n/a')
call New(exactLap, 1, sphere%particles%N, 'exactLap', 'n/a')
call New(estDoubleDot, 1, sphere%particles%N, 'estDoubleDot', 'n/a')
call New(exactDoubleDot, 1, sphere%particles%N,'exactDoubleDot','n/a')

do j = 1, nLon
	do i = 1, nLat
		xij = [ radius * cos(lons(j)) * cos(lats(i)), radius * sin(lons(j)) * cos(lats(i)), radius * sin(lats(i)) ]
		exactScalar(i,j) = SphereHarmonic54( xij )
		vecA = HarmGradient( xij )
		exactScalarGradX(i,j) = vecA(1)
		exactScalarGradY(i,j) = vecA(2)
		exactScalarGradZ(i,j) = vecA(3)
		exactScalarLap(i,j) = - 30.0_kreal * SphereHarmonic54( xij )
	enddo
enddo

do i = 1, sphere%particles%n
	xij = PhysCoord(sphere%particles, i)
	call InsertScalarToField( testScalar, SphereHarmonic54(xij) )
	call InsertVectorToField( testVector, VectorFromLinearPotential(xij))
enddo

call MPI_BARRIER(MPI_COMM_WORLD, mpiErrCode)
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logKey), " initialization complete... Running problem...")

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! PROGRAM RUN
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	perform interpolation and derivative approximation
!
call New( scalarMlsq, sphere, testScalar )

call New( vectorMlsq, sphere, testVector )

call New(interpMPI, nLon, numProcs )

do j = interpMPI%indexStart(procRank), interpMPI%indexEnd(procRank)
	do i = 1, nLat
		xij = [ radius * cos(lons(j)) * cos(lats(i)), radius * sin(lons(j)) * cos(lats(i)), radius * sin(lats(i)) ]
		scalarInterp(i,j) = InterpolateScalar( scalarMlsq, sphere, xij )
		vecA = InterpolateScalarGradient( scalarMlsq, sphere, xij )
		scalarGradX(i,j) = vecA(1)
		scalarGradY(i,j) = vecA(2)
		scalarGradZ(i,j) = vecA(3)
		scalarLap(i,j) = InterpolateScalarLaplacian( scalarMlsq, sphere, xij )
	enddo
enddo

call MLSQGradientAtParticles( scalarMlsq, sphere, estGrad )

call MLSQLaplacianAtParticles( scalarMlsq, sphere, estLap )

call MLSQDoubleDotProductAtParticles( vectorMlsq, sphere, estDoubleDot )

do i = 0, numProcs - 1
	call MPI_BCAST( scalarInterp(:, interpMPI%indexStart(i):interpMPI%indexEnd(i)), nLat * interpMPI%messageLength(i), &
		MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	call MPI_BCAST( scalarGradX(:, interpMPI%indexStart(i):interpMPI%indexEnd(i)), nLat * interpMPI%messageLength(i), &
		MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	call MPI_BCAST( scalarGradY(:, interpMPI%indexStart(i):interpMPI%indexEnd(i)), nLat * interpMPI%messageLength(i), &
		MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	call MPI_BCAST( scalarGradZ(:, interpMPI%indexStart(i):interpMPI%indexEnd(i)), nLat * interpMPI%messageLength(i), &
		MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
	call MPI_BCAST( scalarLap(:, interpMPI%indexStart(i):interpMPI%indexEnd(i)), nLat * interpMPI%messageLength(i), &
		MPI_DOUBLE_PRECISION, i, MPI_COMM_WORLD, mpiErrCode)
enddo

!
!	write output
!
if ( procRank == 0 ) then
	open(unit=WRITE_UNIT_1, file=vtkFile, status='REPLACE', action='WRITE')
		! vtk header and point locations
		call WriteVTKPoints( sphere%particles, WRITE_UNIT_1, 'SphereMLSQTester')
		! vtk polydata
		call WriteFacesToVTKPolygons( sphere%faces, WRITE_UNIT_1 )
		! point data section header
		call WriteVTKPointDataSectionHeader( WRITE_UNIT_1, sphere%particles%N)
		!  fields @ points
		call WriteVTKLagCoords( sphere%particles, WRITE_UNIT_1)
		call WriteFieldToVTKPointData( testScalar, WRITE_UNIT_1 )
		call WriteFieldToVTKPointData( estGrad, WRITE_UNIT_1 )
		call WriteFieldToVTKPointData( estLap, WRITE_UNIT_1)
		call WriteFieldToVTKPointData( testVector, WRITE_UNIT_1 )
		call WriteFieldToVTKPointData( estDoubleDot, WRITE_UNIT_1)
		call WriteFieldToVTKPointData( exactGrad, WRITE_UNIT_1)
		call WriteFieldToVTKPointData( exactLap, WRITE_UNIT_1 )
		!	fields @ cells
		call WriteFaceAreaToVTKCellData( sphere%faces, sphere%particles, WRITE_UNIT_1)
	close(WRITE_UNIT_1)
	open(unit=WRITE_UNIT_1, file=matlabFile, status='REPLACE', action='WRITE')
		call WriteToMatlab( lons, WRITE_UNIT_1, "lons" )
		call WriteToMatlab( lats, WRITE_UNIT_1, "lats" )
		call WriteToMatlab( scalarInterp, WRITE_UNIT_1, "scalarInterp")
		call WriteToMatlab( exactScalar, WRITE_UNIT_1, "exactScalar")
		call WriteToMatlab( scalarGradX, WRITE_UNIT_1, "scalarGradX")
		call WriteToMatlab( scalarGradY, WRITE_UNIT_1, "scalarGradY")
		call WriteToMatlab( scalarGradZ, WRITE_UNIT_1, "scalarGradZ")
		call WriteToMatlab( exactScalarGradX, WRITE_UNIT_1, "exactScalarGradX")
		call WriteToMatlab( exactScalarGradY, WRITE_UNIT_1, "exactScalarGradY")
		call WriteToMatlab( exactScalarGradZ, WRITE_UNIT_1, "exactScalarGradZ")
		call WriteToMatlab( scalarLap, WRITE_UNIT_1, "scalarLap")
		call WriteToMatlab( exactScalarLap, WRITE_UNIT_1, "exactScalarLap")
	close(WRITE_UNIT_1)
endif

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!! PROGRAM END
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
programEnd = MPI_WTIME()

if ( procRank == 0 ) then
	write(6,'(A,F12.2,A)') "PROGRAM COMPLETE : elapsed time = ", programEnd - programStart, " seconds."
endif

call Delete(interpMPI)
call Delete(scalarMlsq)
call Delete(vectorMlsq)
call Delete(estGrad)
call Delete(estLap)
call Delete(estDoubleDot)
call Delete(exactDoubleDot)
call Delete(testVector)
call Delete(testScalar)
deallocate(exactScalarLap)
deallocate(exactScalar)
deallocate(exactScalarGradZ)
deallocate(exactScalarGradY)
deallocate(exactScalarGradX)
deallocate(scalarLap)
deallocate(scalarGradZ)
deallocate(scalarGradY)
deallocate(scalarGradX)
deallocate(scalarInterp)
deallocate(lats)
deallocate(lons)
call Delete(exeLog)
call MPI_FINALIZE(mpiErrCode)

contains

pure function SolidBodyRotationVelocity( xyz )
	real(kreal), dimension(3) :: SolidBodyRotationVelocity
	real(kreal), dimension(3), intent(in) :: xyz
	!
	real(kreal), parameter :: OMG = 2.0_kreal * PI

	SolidBodyRotationVelocity(1) = - OMG * xyz(2)
	SolidBodyRotationVelocity(2) =   OMG * xyz(1)
	SolidBodyRotationVelocity(3) = 	 0.0_kreal
end function

pure function VectorFromLinearPotential( xyz )
	real(kreal), dimension(3) :: VectorFromLinearPotential
	real(kreal), dimension(3), intent(in) :: xyz
	VectorFromLinearPotential(1) = 1.0_kreal - xyz(1) * xyz(1)
	VectorFromLinearPotential(2) = - xyz(1) * xyz(2)
	VectorFromLinearPotential(3) = - xyz(1) * xyz(3)
end function

pure function SphereHarmonic54(xyz)
	real(kreal) :: SphereHarmonic54
	real(kreal), intent(in) :: xyz(3)
	SphereHarmonic54 = 3.0_kreal * sqrt(35.0_kreal) * cos( 4.0_kreal * Longitude(xyz)) * sin(Latitude(xyz)) * &
					   (-1.0_kreal + sin(Latitude(xyz)) * sin(Latitude(xyz)))**2
end function

pure function HarmGradient( xyz )
	real(kreal) :: HarmGradient(3)
	real(kreal), intent(in) :: xyz(3)
	!
	real(kreal) :: lon, lat, u, v

	lat = Latitude(xyz)
	lon = Longitude(xyz)

	u = -12.0_kreal * sqrt(35.0_kreal) * sin(4.0_kreal * lon) * (-1.0_kreal + sin(lat)*sin(lat))**2 * tan(lat)
	v =  12.0_kreal * sqrt(35.0_kreal) * cos(4.0_kreal * lon) * sin(lat) * sin(lat)*(-1.0_kreal + sin(lat)*sin(lat)) + &
	3.0_kreal * sqrt(35.0_kreal) * cos(4.0_kreal * lon)*cos(lat)*(-1.0_kreal + sin(lat)*sin(lat))**2

	HarmGradient(1) = -u * sin(lon) - v*sin(lat)*cos(lon)
	HarmGradient(2) = u * cos(lon) - v * sin(lat)*sin(lon)
	HarmGradient(3) = v * cos(lat)
end function

subroutine ReadNamelistFile(rank)
	integer(kint), intent(in) :: rank
	!
	integer(kint), parameter :: initBCAST_intSize = 4
	integer(kint), parameter :: initBCAST_realSize = 1
	integer(kint) :: readStat
	integer(kint) :: bcastIntegers(initBCAST_intSize)
	real(kreal) :: bcastReals(initBCAST_realSize)

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

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

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

			read(READ_UNIT,nml=mlsqTest)
		close(READ_UNIT)

		if ( faceType == 3 ) then
			meshSeed = ICOS_TRI_SPHERE_SEED
			write(meshString,'(A,I1)') 'icosTri', initNest
		elseif ( faceType == 4) then
			meshSeed = CUBED_SPHERE_SEED
			write(meshString,'(A,I1)') 'cubedSphere', initNest
		else
			call LogMessage(exeLog, WARNING_LOGGING_LEVEL, trim(logKey)//" ReadNamelistFile WARNING :", &
				" invalid faceKind -- using triangles.")
			meshSeed = ICOS_TRI_SPHERE_SEED
			write(meshString,'(A,I1)') 'icosTri', initNest
		endif

		write(matlabFile,'(A,A,A,A,A,A)') trim(outputDir), '/', trim(outputRoot), '_', trim(meshString), '.m'
		write(vtkFile,'(A,A,A,A,A,A)') trim(outputDir), '/', trim(outputRoot), '_', trim(meshString), '.vtk'

		bcastIntegers(1) = meshSeed
		bcastIntegers(2) = initNest
		bcastIntegers(3) = nLon
		bcastIntegers(4) = nLon / 2 + 1

		bcastReals(1) = radius
	endif

	call MPI_BCAST( bcastIntegers, initBCAST_intSize, MPI_INTEGER, 0, MPI_COMM_WORLD, mpiErrCode)
	call MPI_BCAST( bcastReals, initBCAST_realSize, MPI_DOUBLE_PRECISION, 0, MPI_COMM_WORLD, mpiErrCode)

	meshSeed = bcastIntegers(1)
	initNest = bcastIntegers(2)
	nLon = bcastIntegers(3)
	nLat = bcastIntegers(4)

	radius = bcastReals(1)
end subroutine

subroutine InitLogger(aLog,rank)
! Initialize a logger for this processor
	type(Logger), intent(out) :: aLog
	integer(kint), intent(in) :: rank
	write(logKey,'(A,A,I0.2,A)') trim(logKey),'_',rank,' : '
	if ( rank == 0 ) then
		call New(aLog,logLevel)
	else
		call New(aLog,ERROR_LOGGING_LEVEL)
	endif
end subroutine

end program


!!
!! @author R.C. Singleton
!! @author M. Olesen
!! @author J. Beale
!! @author D. Wortmann
!! @author Paul Baumeister
!! @version 0.0
!!
!!>This code is a replacement of the old FFT code
!! It has been modified to
!! 1. Not to use any kind-parameter
!! 2. to be fixed-format compatible
!! 3. Some further changes are marked by !DW
!!          D. Wortmann
!!<4. Fixed-format was removed again ! PB  P.Baumeister
!!
!!-----------------------------------------------------------------------------
!! Multivariate Fast Fourier Transform
!!
!! Fortran 90 (ELF90) Implementation of Singleton's mixed-radix algorithm,
!! RC Singleton, Stanford Research Institute, Sept. 1968.
!!
!! Adapted from fftn.c, translated from Fortran 66 to C by Mark Olesen and
!! John Beale.
!!
!! Fourier transforms can be computed either in place, using assumed size
!! arguments, or by generic function, using assumed shape arguments.
!!
!!
!! Public:
!!
!!   fftkind                              kind parameter of complex :: arguments
!!                                        and function results.
!!
!!   fft(array, dims, inv)                 generic transform function
!!    COMPLEX(fftkind), DIMENSION(:,...,:), INTENT(IN) :: array
!!    INTEGER,          DIMENSION(:),       INTENT(IN),  OPTIONAL :: dims
!!    LOGICAL,                              INTENT(IN),  OPTIONAL :: inv
!!
!!   fftn(array, shape, dim, inv, stat)   in place transform subroutine
!!    COMPLEX(fftkind), DIMENSION(*), INTENT(INOUT)        :: array
!!    INTEGER,          DIMENSION(:), INTENT(IN)               :: shape
!!    INTEGER,          DIMENSION(:), INTENT(IN),  OPTIONAL :: dims
!!    LOGICAL,                        INTENT(IN),  OPTIONAL :: inv
!!    INTEGER,                        INTENT(OUT), OPTIONAL     :: stat
!!
!!
!! Formal Parameters:
!!
!!   array    The complex :: array to be transformed. array can be of arbitrary
!!            rank (i.e. up to seven).
!!
!!   shape    With subroutine fftn, the shape of the array to be transformed
!!            has to be passed separately, since fftradix - the internal trans-
!!            formation routine - will treat array always as one dimensional.
!!            The product of elements in shape must be the number of
!!            elements in array.
!!            Although passing array with assumed shape would have been nicer,
!!            I prefered assumed size in order to prevent the compiler from
!!            using a copy-in-copy-out mechanism. That would generally be
!!            necessary with fftn passing array to fftradix and with fftn
!!            being prepared for accepting non consecutive array sections.
!!            Using assumed size, it's up to the user to pass an array argu-
!!            ment, that can be addressed as continous one dimensional array
!!            without copying. Otherwise, transformation will not really be
!!            performed in place.
!!            On the other hand, since the rank of array and the size of
!!            shape needn't match, fftn is appropriate for handling more than
!!            seven dimensions.
!!            As far as function fft is concerned all this doesn't matter,
!!            because the argument will be copied anyway. Thus no extra
!!            shape argument is needed for fft.
!!
!! Optional Parameters:
!!
!!   dims     One dimensional integer :: array, containing the dimensions to be
!!            transformed. Default is (/1,...,N/) with N being the rank of
!!            array, i.e. complete transform. dims can restrict transformation
!!            to a subset of available dimensions. Its size must not exceed the
!!            rank of array or the size of shape respectivly.
!!
!!   inv      If .true., inverse transformation will be performed. Default is
!!            .false., i.e. forward transformation.
!!
!!   stat     If present, a system dependent nonzero status value will be
!!            returned in stat, if allocation of temporary storage failed.
!!            For functions, the integer :: variable status is used.
!!
!! Scaling:
!!
!!   Transformation results will always be scaled by the square root of the
!!   product of sizes of each dimension in dims. (See examples below)
!!
!!
!! Examples:
!!
!!   Let A be a L*M*N three dimensional complex :: array. Then
!!
!!     result = fft(A)
!!
!!   will produce a three dimensional transform, scaled by sqrt(L*M*N), while
!!
!!     call fftn(A, SHAPE(A))
!!
!!   will do the same in place.
!!
!!     result = fft(A, dims = (/1,3/))
!!
!!   will transform with respect to the first and the third dimension, scaled
!!   by sqrt(L*N).
!!
!!     result = fft(fft(A), inv = .true.)
!!
!!   should (approximately) reproduce A.
!!   With B having the same shape as A
!!
!!     result = fft(fft(A) * CONJG(fft(B)), inv = .true.)
!!
!!   will correlate A and B.
!!
!!
!! Remarks:
!!
!!   Following changes have been introduced with respect to fftn.c:
!!   - complex arguments and results are of type complex, rather than
!!     real an imaginary part separately.
!!   - increment parameter (magnitude of isign) has been dropped,
!!     inc is always one, direction of transform is given by inv.
!!   - maxf and maxp have been dropped. The amount of temporary storage
!!     needed is determined by the fftradix routine. Both fftn and fft
!!     can handle any size of array. (Maybe they take a lot of time and
!!     memory, but they will do it)
!!
!!   Redesigning fftradix in a way, that it handles assumed shape arrays
!!   would have been desirable. However, I found it rather hard to do this
!!   in an efficient way. Problems were:
!!   - to prevent stride multiplications when indexing arrays. At least our
!!     compiler was not clever enough to discover that in fact additions
!!     would do the job as well. On the other hand, I haven't been clever
!!     enough to find an implementation using array operations.
!!   - fftradix is rather large and different versions would be necessaray
!!     for each possible rank of array.
!!   Consequently, in place transformation still needs the argument stored
!!   in a consecutive bunch of memory and can't be performed on array
!!   sections like A(100:199:-3, 50:1020). Calling fftn with such sections
!!   will most probably imply copy-in-copy-out. However, the function fft
!!   works with everything it gets and should be convenient to use.
!!
!!   To enable this module to be used with ELF90 it appears to be necessary
!!   to allocate a 1-D work array into which the multi-dimensional array is
!!   copied, and then to copy the results back from the 1-D array to the
!!   multi-dimensional array ft.
!!
!!   Unfortunately, ELF90 will not allow a function to return more than one
!!   output variable.   The variable `stat' has been dropped from the function
!!   arguments.   Users should examine the value of the variable `status'
!!   instead.   This is a PUBLIC variable declared in this module.
!!
!! Michael Steffens, 09.12.96, <Michael.Steffens@mbox.muk.uni-hannover.de>
!! ELF90-compatible version by Alan Miller, 29 April 1997 & 6 June 1997
!! amiller @ bigpond.net.au
!! Restructured fftradix for better optimization by M. Steffens, 4 June 1997
!!-----------------------------------------------------------------------------
module FFT_tools
  implicit none
  private !! default visibility for this module namespace

  public :: fftn
  public :: fft
  public :: test

  interface fft
    module procedure fft1d, fft2d, fft3d, fft4d, fft5d, fft6d, fft7d
  endinterface

  character(len=*), parameter, private :: sym = 'fft' !! module symbol

  real, parameter :: sin60 = 0.86602540378443865
  real, parameter :: cos72 = 0.30901699437494742
  real, parameter :: sin72 = 0.95105651629515357
  real, parameter :: Pi    = 3.14159265358979323

  integer, save :: status = 0 !--- shifted to here as elf90 does not allow arguments to be intent(out)

  contains

  function fft1d( a, dims, inv ) result( ft )
    !--- formal parameters
    complex, intent(in) :: a(:)
    integer, intent(in),  optional :: dims(:)
    logical, intent(in),  optional :: inv
    !--- function result
    complex :: ft(size(a))

    ft = a
    call fftn( ft, shape(a), dims, inv=inv, stat=status )
  endfunction ! fft1d

  function fft2d( a, dims, inv ) result( ft )
    !--- formal parameters
    complex, intent(in) :: a(:,:)
    integer, intent(in), optional :: dims(:)
    logical, intent(in), optional :: inv
    !--- function result
    complex :: ft(size(a,1),size(a,2))
    complex :: work(size(a))

    work = reshape( a, (/ size(a) /) )
    call fftn( work, shape(a), dims, inv, stat=status )
    ft = reshape( work, shape(ft) )
  endfunction ! fft2d

  function fft3d( a, dims, inv ) result( ft )
    !--- formal parameters
    complex, intent(in) :: a(:,:,:)
    integer, intent(in),  optional :: dims(:)
    logical, intent(in),  optional :: inv
    !--- function result
    complex :: ft(size(a,1),size(a,2),size(a,3))
    complex :: work(size(a))

    work = reshape( a, (/ size(a) /) )
    call fftn( work, shape(a), dims, inv, stat=status )
    ft = reshape( work, shape(ft) )
  endfunction ! fft3d

  function fft4d( a, dims, inv ) result(ft)
    !--- formal parameters
    complex, intent(in) :: a(:,:,:,:)
    integer, intent(in), optional :: dims(:)
    logical, intent(in), optional :: inv
    !--- function result
    complex :: ft(size(a,1),size(a,2),size(a,3),size(a,4))
    complex :: work(size(a))

    work = reshape( a, (/ size(a) /) )
    call fftn( work, shape(a), dims, inv, stat=status )
    ft = reshape( work, shape(ft) )
  endfunction ! fft4d

  function fft5d( a, dims, inv ) result(ft)
    !--- formal parameters
    complex, intent(in) :: a(:,:,:,:,:)
    integer, intent(in), optional :: dims(:)
    logical, intent(in), optional :: inv
    !--- function result
    complex :: ft(size(a,1),size(a,2),size(a,3),size(a,4),size(a,5))
    complex :: work(size(a))

    work = reshape( a, (/ size(a) /) )
    call fftn( work, shape(a), dims, inv, stat=status )
    ft = reshape( work, shape(ft) )
  endfunction ! fft5d

  function fft6d( a, dims, inv ) result(ft)
    !--- formal parameters
    complex, intent(in) :: a(:,:,:,:,:,:)
    integer, intent(in), optional :: dims(:)
    logical, intent(in), optional :: inv
    !--- function result
    complex :: ft(size(a,1),size(a,2),size(a,3),size(a,4),size(a,5),size(a,6))
    complex :: work(size(a))

    work = reshape( a, (/ size(a) /) )
    call fftn( work, shape(a), dims, inv, stat=status )
    ft = reshape( work, shape(ft) )
  endfunction ! fft6d

  function fft7d( a, dims, inv ) result(ft)
    !--- formal parameters
    complex, intent(in) :: a(:,:,:,:,:,:,:)
    integer, intent(in), optional :: dims(:)
    logical, intent(in), optional :: inv
    !--- function result
    complex :: ft(size(a,1),size(a,2),size(a,3),size(a,4),size(a,5),size(a,6),size(a,7))
    complex :: work(size(a))

    work = reshape( a, (/ size(a) /) )
    call fftn( work, shape(a), dims, inv, stat=status )
    ft = reshape( work, shape(ft) )
  endfunction ! fft7d

  subroutine fftn( array, shape, dims, inv, stat )
    !--- formal parameters
    complex, intent(inout)            :: array(:)
    integer, intent(in)               :: shape(:)
    integer, intent(in), optional     :: dims(:)
    logical, intent(in), optional     :: inv
    integer, intent(out), optional    :: stat
    !--- local vars
    integer         :: d(size(shape))
    logical         :: inverse
    integer         :: id, ndims, ntotal
!    real            :: scal

    !--- optional parameter settings
    inverse = .false. ; if( present(inv) ) inverse = inv

    if( present(dims) ) then
      ndims = min( size(dims), size(d) )
      d(1:ndims) = dims(1:ndims)
    else
      ndims = size(d)
      d = (/ ( id, id=1,size(d) ) /) ! default is all dimensions 1,...,N
    endif

    ntotal = product(shape)

    !dw!
    !dw: no scaling!
    ! scal = sqrt( 1. / product(shape(d(1:ndims))) )
    ! array = scal * array

    do id = 1, ndims
      call fftradix( array, ntotal, shape(d(id)), product(shape(1:d(id))), inverse )
    enddo ! id

    if( present(stat) ) stat = status
  endsubroutine ! fftn

  subroutine fftradix( array, ntotal, npass, nspan, inv )
    !--- formal parameters
    complex, intent(inout)      :: array(:)
    integer, intent(in)         :: ntotal, npass, nspan
    logical, intent(in)         :: inv
    !--- local arrays
    integer :: factor(bit_size(0))
    !--- local scalars
    integer :: maxfactor, nfactor, nsquare
    !--- intrinsics used

    if ( npass <= 1 ) return

    maxfactor = factorize( npass, factor, nfactor, nsquare )

    call transform( array, ntotal, npass, nspan, factor, nfactor, maxfactor, inv )
    call permute( array, ntotal, npass, nspan, factor, nfactor, nsquare, maxfactor )
  endsubroutine ! fftradix

  integer function factorize( npass, factor, nfactor, nsquare ) result( maxfactor )
    !--- formal parameters
    integer, intent(in)  :: npass
    integer, intent(out) :: factor(:)
    integer, intent(out) :: nfactor, nsquare
    !--- local scalars
    integer :: j, jj, k

    nfactor = 0 ! init the number of factors
    k = npass

    ! try with 4
    do while ( mod( k, 16 ) == 0 ) ! npass can be divided by 16
      nfactor = nfactor + 1 ! increase the number of factors
      factor(nfactor) = 4 ! store the factor 4
      k = k / 16 ! proceed with the reduced number
    enddo
    ! now k does not contain any powers of 16 any more

    j = 3 ! try odd numbers starting from 3
    jj = j * j
    do
      do while ( mod( k, jj ) == 0 ) ! npass can be divided by j^2
        nfactor = nfactor + 1 ! increase the number of factors
        factor(nfactor) = j ! store the factor j
        k = k / jj ! proceed with the reduced number
      enddo
      j = j + 2 ! try higher odd numbers
      jj = j * j
      if ( jj > k ) exit
    enddo

    if ( k <= 4 ) then
      nsquare = nfactor
      factor(nfactor+1) = k
      if ( k /= 1 ) nfactor = nfactor + 1
    else   ! k <= 4
      if ( k - ishft( k / 4, 2 ) == 0 ) then
        nfactor = nfactor + 1
        factor(nfactor) = 2
        k = k / 4
      endif
      nsquare = nfactor
      j = 2
      do
        if ( mod( k, j ) == 0 ) then
          nfactor = nfactor + 1
          factor(nfactor) = j
          k = k / j
        endif
        j = ishft( (j + 1) / 2, 1 ) + 1
        if ( j > k ) exit
      enddo
    endif ! k <= 4
    if ( nsquare > 0 ) then
      j = nsquare
      do
        nfactor = nfactor + 1
        factor(nfactor) = factor(j)
        j = j - 1
        if ( j == 0 ) exit
      enddo
    endif
    maxfactor = maxval( factor(:nfactor) )
  endfunction ! factorize

  subroutine transform( array, ntotal, npass, nspan, factor, nfactor, maxfactor, inv )
    !--- formal parameters
    complex, intent(inout)      :: array(:)
    integer, intent(in)         :: ntotal, npass, nspan
    integer, intent(in)         :: factor(:)
    integer, intent(in)         :: nfactor
    integer, intent(in)         :: maxfactor
    logical, intent(in)         :: inv
    !--- local scalars
    integer         :: ii, ispan
    integer         :: j, jc, jf, jj
    integer         :: k, kk, kspan, k1, k2, k3, k4
    integer         :: nn, nt
    real            :: s60, c72, s72, pi2, radf
    real            :: c1, s1, c2, s2, c3, s3, cd, sd, ak
    complex         :: cc, cj, ck, cjp, cjm, ckp, ckm
    !--- local arrays
  !   complex, allocatable  :: ctmp(:)
  !   real, allocatable     :: sine(:), cosine(:)
  !
  !   maxfactor = maxval(factor(:nfactor))
  !   allocate( ctmp(maxfactor), sine(maxfactor), cosine(maxfactor), stat=status )
  !   if (status /= 0) return
    complex :: ctmp(maxfactor)
    real :: sine(maxfactor), cosine(maxfactor)

    c72 = cos72
    if (inv) then
        s72 = sin72
        s60 = sin60
        pi2 = pi
    else
        s72 = -sin72
        s60 = -sin60
        pi2 = -pi
    endif

    nt = ntotal
    nn = nt - 1
    kspan = nspan
    jc = nspan / npass
    radf = pi2 * jc
    pi2 = pi2 * 2.0 !-- use 2 pi from here on

    ii = 0
    jf = 0
    do
      sd = radf / kspan
      cd = sin(sd)
      cd = 2.0 * cd * cd
      sd = sin(sd + sd)
      kk = 1
      ii = ii + 1

      select case (factor(ii))
      case (2)
        !-- transform for factor of 2 (including rotation factor)
        kspan = kspan / 2
        k1 = kspan + 2
        do
            do
              k2 = kk + kspan
              ck = array(k2)
              array(k2) = array(kk)-ck
              array(kk) = array(kk) + ck
              kk = k2 + kspan
              if (kk > nn) exit
            enddo
            kk = kk - nn
            if (kk > jc) exit
        enddo
        if (kk > kspan) then
!             deallocate( ctmp, sine, cosine, stat=status )
            return
        endif
        do
            c1 = 1.0 - cd
            s1 = sd
            do
              do
                  do
                    k2 = kk + kspan
                    ck = array(kk) - array(k2)
                    array(kk) = array(kk) + array(k2)
                    array(k2) = ck * cmplx(c1, s1)
                    kk = k2 + kspan
                    if (kk >= nt) exit
                  enddo
                  k2 = kk - nt
                  c1 = -c1
                  kk = k1 - k2
                  if (kk <= k2) exit
              enddo
              ak = c1 - (cd * c1 + sd * s1)
              s1 = sd * c1 - cd * s1 + s1
              c1 = 2.0 - (ak * ak + s1 * s1)
              s1 = s1 * c1
              c1 = c1 * ak
              kk = kk + jc
              if (kk >= k2) exit
            enddo
            k1 = k1 + 1 + 1
            kk = (k1 - kspan) / 2 + jc
            if (kk > jc + jc) exit
        enddo

      case (4) !-- transform for factor of 4
        ispan = kspan
        kspan = kspan / 4

        do
            c1 = 1.0
            s1 = 0.0
            do
              do
                  k1 = kk + kspan
                  k2 = k1 + kspan
                  k3 = k2 + kspan
                  ckp = array(kk) + array(k2)
                  ckm = array(kk) - array(k2)
                  cjp = array(k1) + array(k3)
                  cjm = array(k1) - array(k3)
                  array(kk) = ckp + cjp
                  cjp = ckp - cjp
                  if (inv) then
                    ckp = ckm + cmplx(-aimag(cjm), real(cjm))
                    ckm = ckm + cmplx(aimag(cjm), -real(cjm))
                  else
                    ckp = ckm + cmplx(aimag(cjm), -real(cjm))
                    ckm = ckm + cmplx(-aimag(cjm), real(cjm))
                  endif
                  !-- avoid useless multiplies
                  if (s1 == 0.0) then
                    array(k1) = ckp
                    array(k2) = cjp
                    array(k3) = ckm
                  else
                    array(k1) = ckp * cmplx(c1, s1)
                    array(k2) = cjp * cmplx(c2, s2)
                    array(k3) = ckm * cmplx(c3, s3)
                  endif
                  kk = k3 + kspan
                  if (kk > nt) exit
              enddo

              c2 = c1 - (cd * c1 + sd * s1)
              s1 = sd * c1 - cd * s1 + s1
              c1 = 2.0 - (c2 * c2 + s1 * s1)
              s1 = s1 * c1
              c1 = c1 * c2
              !-- values of c2, c3, s2, s3 that will get used next time
              c2 = c1 * c1 - s1 * s1
              s2 = 2.0 * c1 * s1
              c3 = c2 * c1 - s2 * s1
              s3 = c2 * s1 + s2 * c1
              kk = kk - nt + jc
              if (kk > kspan) exit
            enddo
            kk = kk - kspan + 1
            if (kk > jc) exit
        enddo
        if (kspan == jc) then
!             deallocate( ctmp, sine, cosine, stat=status )
            return
        endif

      case default
        !-- transform for odd factors
        k = factor(ii)
        ispan = kspan
        kspan = kspan / k

        select case (k)
        case (3) !-- transform for factor of 3 (optional code)
            do
              do
                  k1 = kk + kspan
                  k2 = k1 + kspan
                  ck = array(kk)
                  cj = array(k1) + array(k2)
                  array(kk) = ck + cj
                  ck        = ck - cmplx( 0.5 * real (cj), 0.5 * aimag(cj))
                  cj = cmplx( (real(array(k1)) - real (array(k2))) * s60,(aimag(array(k1)) - aimag(array(k2))) * s60)
                  array(k1) = ck + cmplx(-aimag(cj), real(cj))
                  array(k2) = ck + cmplx(aimag(cj), -real(cj))
                  kk = k2 + kspan
                  if (kk >= nn) exit
              enddo
              kk = kk - nn
              if (kk > kspan) exit
            enddo

        case (5) !-- transform for factor of 5 (optional code)
            c2 = c72 * c72 - s72 * s72
            s2 = 2.0 * c72 * s72
            do
              do
                  k1 = kk + kspan
                  k2 = k1 + kspan
                  k3 = k2 + kspan
                  k4 = k3 + kspan
                  ckp = array(k1) + array(k4)
                  ckm = array(k1) - array(k4)
                  cjp = array(k2) + array(k3)
                  cjm = array(k2) - array(k3)
                  cc = array(kk)
                  array(kk) = cc + ckp + cjp
                  ck = cmplx(real(ckp) * c72, aimag(ckp) * c72 ) + &
                      cmplx(real(cjp) * c2,  aimag(cjp) * c2) + cc
                  cj = cmplx(real(ckm) * s72, aimag(ckm) * s72) + &
                      cmplx(real(cjm) * s2,  aimag(cjm) * s2)
                  array(k1) = ck + cmplx(-aimag(cj), real(cj))
                  array(k4) = ck + cmplx(aimag(cj), -real(cj))
                  ck  = cmplx(real(ckp) * c2,  aimag(ckp) * c2) &
                      + cmplx(real(cjp) * c72, aimag(cjp) * c72) + cc
                  cj   = cmplx(real(ckm) * s2,  aimag(ckm) * s2) - &
                        cmplx(real(cjm) * s72, aimag(cjm) * s72)
                  array(k2) = ck + cmplx(-aimag(cj), real(cj))
                  array(k3) = ck + cmplx(aimag(cj), -real(cj))
                  kk = k4 + kspan
                  if (kk >= nn) exit
              enddo
              kk = kk - nn
              if (kk > kspan) exit
            enddo

        case default
            if (k /= jf) then
              jf = k
              s1 = pi2 / k
              c1 = cos(s1)
              s1 = sin(s1)
              cosine (jf) = 1.0
              sine (jf) = 0.0
              j = 1
              do
                  cosine (j) = cosine (k) * c1 + sine (k) * s1
                  sine (j) = cosine (k) * s1 - sine (k) * c1
                  k = k-1
                  cosine (k) = cosine (j)
                  sine (k) = -sine (j)
                  j = j + 1
                  if (j >= k) exit
              enddo
            endif
            do
              do
                  k1 = kk
                  k2 = kk + ispan
                  cc = array(kk)
                  ck = cc
                  j = 1
                  k1 = k1 + kspan
                  do
                    k2 = k2 - kspan
                    j = j + 1
                    ctmp(j) = array(k1) + array(k2)
                    ck = ck + ctmp(j)
                    j = j + 1
                    ctmp(j) = array(k1) - array(k2)
                    k1 = k1 + kspan
                    if (k1 >= k2) exit
                  enddo
                  array(kk) = ck
                  k1 = kk
                  k2 = kk + ispan
                  j = 1
                  do
                    k1 = k1 + kspan
                    k2 = k2 - kspan
                    jj = j
                    ck = cc
                    cj = (0.0, 0.0)
                    k = 1
                    do
                        k = k + 1
                        ck = ck + cmplx(real (ctmp(k)) * cosine(jj),aimag(ctmp(k)) * cosine(jj))
                        k = k + 1
                        cj = cj + cmplx( real (ctmp(k)) * sine(jj),aimag(ctmp(k)) * sine(jj))
                        jj = jj + j
                        if (jj > jf) jj = jj - jf
                        if (k >= jf) exit
                    enddo
                    k = jf - j
                    array(k1) = ck + cmplx(-aimag(cj), real(cj))
                    array(k2) = ck + cmplx(aimag(cj), -real(cj))
                    j = j + 1
                    if (j >= k) exit
                  enddo
                  kk = kk + ispan
                  if (kk > nn) exit
              enddo
              kk = kk - nn
              if (kk > kspan) exit
            enddo

        endselect
        !--  multiply by rotation factor (except for factors of 2 and 4)
        if (ii == nfactor) then
!             deallocate( ctmp, sine, cosine, stat=status )
            return
        endif

        kk = jc + 1
        do
            c2 = 1.0 - cd
            s1 = sd
            do
              c1 = c2
              s2 = s1
              kk = kk + kspan
              do
                  do
                    array(kk) = cmplx(c2, s2)* array(kk)
                    kk = kk + ispan
                    if (kk > nt) exit
                  enddo
                  ak = s1 * s2
                  s2 = s1 * c2 + c1 * s2
                  c2 = c1 * c2 - ak
                  kk = kk - nt + kspan
                  if (kk > ispan) exit
              enddo
              c2 = c1 - (cd * c1 + sd * s1)
              s1 = s1 + sd * c1 - cd * s1
              c1 = 2.0 - (c2 * c2 + s1 * s1)
              s1 = s1 * c1
              c2 = c2 * c1
              kk = kk - ispan + jc
              if (kk > kspan) exit
            enddo
            kk = kk - kspan + jc + 1
            if (kk > jc + jc) exit
        enddo

      endselect
    enddo

    ! deallocate( ctmp, sine, cosine, stat=status )
  endsubroutine ! transform

  subroutine permute( array, ntotal, npass, nspan, factor, nfactor, nsquare, maxfactor )
    !--- formal parameters
    complex, intent(inout)      :: array(:)
    integer, intent(in)         :: ntotal, npass, nspan
    integer, intent(inout)      :: factor(:)
    integer, intent(in)         :: nfactor, nsquare
    integer, intent(in)         :: maxfactor
    !--- local scalars
    integer         :: ii, ispan
    integer         :: j, jc, jj
    integer         :: k, kk, kspan, kt, k1, k2, k3
    integer         :: nn, nperm, nt
    complex         :: ck
    !--- local arrays
    complex, allocatable  :: ctmp(:)
    integer, allocatable  :: perm(:)

    allocate( ctmp(maxfactor), stat=status )
    if (status /= 0) return

    if (nfactor - ishft(nsquare, 1) > 0) then
        nperm = max(nfactor + 1,product(factor(nsquare+1: nfactor-nsquare)) - 1)
    else
        nperm = nfactor + 1
    endif
    allocate( perm(nperm), stat=status )
    if ( status /= 0 ) return

    !--  permute the results to normal order---done in two stages
    !--  permutation for square factors of n

    nt = ntotal
    nn = nt - 1
    kt = nsquare
    kspan = nspan
    jc = nspan / npass

    perm (1) = nspan
    if (kt > 0) then
      k = kt + kt + 1
      if (nfactor < k) k = k - 1
      j = 1
      perm (k + 1) = jc
      do
        perm (j + 1) = perm (j) / factor(j)
        perm (k) = perm (k + 1) * factor(j)
        j = j + 1
        k = k - 1
        if (j >= k) exit
      enddo
      k3 = perm (k + 1)
      kspan = perm (2)
      kk = jc + 1
      k2 = kspan + 1
      j = 1

      if (npass /= ntotal) then
        permute_multi: do
            do
              do
                  k = kk + jc
                  do
                    !-- swap array(kk) <> array(k2)
                    ck = array(kk)
                    array(kk) = array(k2)
                    array(k2) = ck
                    kk = kk + 1
                    k2 = k2 + 1
                    if (kk >= k) exit
                  enddo
                  kk = kk + nspan - jc
                  k2 = k2 + nspan - jc
                  if (kk >= nt) exit
              enddo
              kk = kk - nt + jc
              k2 = k2 - nt + kspan
              if (k2 >= nspan) exit
            enddo
            do
              do
                  k2 = k2 - perm (j)
                  j = j + 1
                  k2 = perm (j + 1) + k2
                  if (k2 <= perm (j)) exit
              enddo
              j = 1
              do
                  if (kk < k2) cycle permute_multi
                  kk = kk + jc
                  k2 = k2 + kspan
                  if (k2 >= nspan) exit
              enddo
              if (kk >= nspan) exit
            enddo
            exit
        enddo permute_multi
      else
        permute_single: do
            do
              !-- swap array(kk) <> array(k2)
              ck = array(kk)
              array(kk) = array(k2)
              array(k2) = ck
              kk = kk + 1
              k2 = k2 + kspan
              if (k2 >= nspan) exit
            enddo
            do
              do
                  k2 = k2 - perm (j)
                  j = j + 1
                  k2 = perm (j + 1) + k2
                  if (k2 <= perm (j)) exit
              enddo
              j = 1
              do
                  if (kk < k2) cycle permute_single
                  kk = kk + 1
                  k2 = k2 + kspan
                  if (k2 >= nspan) exit
              enddo
              if (kk >= nspan) exit
            enddo
            exit
        enddo permute_single
      endif
      jc = k3
    endif

    if (ishft(kt, 1) + 1 >= nfactor) then
      deallocate( perm, ctmp )
      return
    endif

    ispan = perm (kt + 1)
    !-- permutation for square-free factors of n
    j = nfactor - kt
    factor(j + 1) = 1
    do
        factor(j) = factor(j) * factor(j+1)
        j = j - 1
        if (j == kt) exit
    enddo
    kt = kt + 1
    nn = factor(kt) - 1
    j = 0
    jj = 0
    do
        k = kt + 1
        k2 = factor(kt)
        kk = factor(k)
        j = j + 1
        if (j > nn) exit !-- exit infinite loop
        jj = jj + kk
        do while (jj >= k2)
          jj = jj - k2
          k2 = kk
          k = k + 1
          kk = factor(k)
          jj = jj + kk
        enddo
        perm (j) = jj
    enddo
    !--  determine the permutation cycles of length greater than 1
    j = 0
    do
      do
        j = j + 1
        kk = perm(j)
        if (kk >= 0) exit
      enddo
      if (kk /= j) then
        do
            k = kk
            kk = perm (k)
            perm (k) = -kk
            if (kk == j) exit
        enddo
        k3 = kk
      else
        perm (j) = -j
        if (j == nn) exit !-- exit infinite loop
      endif
    enddo
    !--  reorder a and b, following the permutation cycles
    do
      j = k3 + 1
      nt = nt - ispan
      ii = nt - 1 + 1
      if (nt < 0) exit !-- exit infinite loop
      do
        do
            j = j-1
            if (perm(j) >= 0) exit
        enddo
        jj = jc
        do
            kspan = jj
            if (jj > maxfactor) kspan = maxfactor
            jj = jj - kspan
            k = perm(j)
            kk = jc * k + ii + jj
            k1 = kk + kspan
            k2 = 0
            do
              k2 = k2 + 1
              ctmp(k2) = array(k1)
              k1 = k1 - 1
              if (k1 == kk) exit
            enddo
            do
              k1 = kk + kspan
              k2 = k1 - jc * (k + perm(k))
              k = -perm(k)
              do
                  array(k1) = array(k2)
                  k1 = k1 - 1
                  k2 = k2 - 1
                  if (k1 == kk) exit
              enddo
              kk = k2
              if (k == j) exit
            enddo
            k1 = kk + kspan
            k2 = 0
            do
              k2 = k2 + 1
              array(k1) = ctmp(k2)
              k1 = k1 - 1
              if (k1 == kk) exit
            enddo
            if (jj == 0) exit
        enddo
        if (j == 1) exit
      enddo
    enddo

    deallocate( perm, ctmp )
  endsubroutine ! permute

  integer function test( )
    write(*,*,iostat=test) 'FFT: no module test implemented!'
  endfunction ! test

endmodule ! FFT_tools


      PROGRAM sphfpt
      INTEGER i,m,n,nvar,nn2,N1,N2,NTOT
      REAL DXX
      PARAMETER (N1=2,N2=1,NTOT=N1+N2,DXX=1.e-4)
      REAL c2,dx,gamma,q1,x1,x2,xf,v1(N2),v2(N1),v(NTOT)
      LOGICAL check
      COMMON /sphcom/ c2,gamma,dx,m,n
      COMMON /caller/ x1,x2,xf,nvar,nn2
      EQUIVALENCE (v1(1),v(1)),(v2(1),v(N2+1))
CU    USES newt
      nvar=NTOT
      nn2=N2
      dx=DXX
1     write(*,*) 'input m,n,c-squared (999 to end)'
      read(*,*) m,n,c2
      if (c2.eq.999.) stop
      if ((n.lt.m).or.(m.lt.0)) goto 1
      gamma=1.0
      q1=n
      do 11 i=1,m
        gamma=-0.5*gamma*(n+i)*(q1/i)
        q1=q1-1.0
11    continue
      v1(1)=n*(n+1)-m*(m+1)+c2/2.0
      v2(2)=v1(1)
      v2(1)=gamma*(1.-(v2(2)-c2)*dx/(2*(m+1)))
      x1=-1.0+dx
      x2=1.0-dx
      xf=0.
      call newt(v,NTOT,check)
      if(check)then
        write(*,*)'shootf failed; bad initial guess'
      else
        write(*,'(1x,t6,a)') 'mu(m,n)'
        write(*,'(1x,f12.6)') v1(1)
        goto 1
      endif
      END
      SUBROUTINE load1(x1,v1,y)
      INTEGER m,n
      REAL c2,dx,gamma,x1,y1,v1(1),y(3)
      COMMON /sphcom/ c2,gamma,dx,m,n
      y(3)=v1(1)
      if(mod(n-m,2).eq.0)then
        y1=gamma
      else
        y1=-gamma
      endif
      y(2)=-(y(3)-c2)*y1/(2*(m+1))
      y(1)=y1+y(2)*dx
      return
      END
      SUBROUTINE load2(x2,v2,y)
      INTEGER m,n
      REAL c2,dx,gamma,x2,v2(2),y(3)
      COMMON /sphcom/ c2,gamma,dx,m,n
      y(3)=v2(2)
      y(1)=v2(1)
      y(2)=(y(3)-c2)*y(1)/(2*(m+1))
      return
      END
      SUBROUTINE score(xf,y,f)
      INTEGER i,m,n
      REAL c2,gamma,dx,xf,f(3),y(3)
      COMMON /sphcom/ c2,gamma,dx,m,n
      do 12 i=1,3
        f(i)=y(i)
12    continue
      return
      END

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


program problem_12

!! What is the Manhattan distance between that location
!! and the ship's starting position?

use aoc_utilities
use iso_fortran_env

implicit none

integer,parameter :: chunk_size = 256

integer :: n, iunit, istat, i
character(len=:),allocatable :: line
logical :: status_ok
character(len=1) :: action
integer :: value
integer,dimension(2) :: r ! (x,y) position
integer :: direction ! current direction (N=90,S=270,E=0,W=180)

open(newunit=iunit, file='input.txt', iostat=istat)
n = number_of_lines_in_file(iunit)

direction = 0 ! start facing east
r = 0         ! initial position

do i = 1, n
    call read_line_from_file(iunit,chunk_size,line,status_ok)

    action = line(1:1)
    read(line(2:),'(I5)') value

    select case (action)
    case('N'); r(2) = r(2) + value  ! move north by the given value.
    case('S'); r(2) = r(2) - value  ! move south by the given value.
    case('E'); r(1) = r(1) + value  ! move east by the given value.
    case('W'); r(1) = r(1) - value  ! move west by the given value.
    case('L'); direction = wrap(direction + value)  ! turn left the given number of degrees.
    case('R'); direction = wrap(direction - value)  ! turn right the given number of degrees.
    case('F')  ! move forward by the given value in the direction the ship is currently facing.
        select case (direction)
        case(0,360); r(1) = r(1) + value  ! E
        case(90);    r(2) = r(2) + value  ! N
        case(180);   r(1) = r(1) - value  ! W
        case(270);   r(2) = r(2) - value  ! S
        case default
            error stop 'invalid direction'
        end select
    case default
        error stop 'invalid action: '//action
    end select

end do

write(*,*) 'Manhattan distance: ', abs(r(1)) + abs(r(2))

contains

pure function wrap(angle) result(wrapped_angle)
implicit none
integer,intent(in) :: angle
integer :: wrapped_angle
wrapped_angle = mod(angle, 360)
if (wrapped_angle<0) wrapped_angle = wrapped_angle + 360
end function wrap

end program problem_12


!##############################################################################
! MODULE globals
!
! This code is published under the GNU General Public License v3
!                         (https://www.gnu.org/licenses/gpl-3.0.en.html)
!
! Authors: Hans Fehr and Fabian Kindermann
!          contact@ce-fortran.com
!
! #VC# VERSION: 1.0  (23 January 2018)
!
!##############################################################################
module globals

    implicit none
    real*8, parameter :: Kbar = 10d0
    real*8, parameter :: Tbar = 30d0
    real*8, parameter :: alpha(2) = (/0.3d0, 0.4d0/)
    real*8, parameter :: beta(2) = (/ 0.3d0, 0.6d0/)
    real*8, parameter :: gamma(2) = (/ -2.5d0, 0.5d0/)
    real*8, parameter :: G = 3d0
    real*8, parameter :: B = 0.1d0
    real*8            :: tauw = 0d0
    real*8            :: tauu = 0d0
    real*8            :: taur = 0d0
    real*8            :: tauc(2) = 0d0

contains

    ! function to determine market equilibrium
    function markets(x)

        implicit none
        real*8, intent(in) :: x(:)
        real*8 :: markets(size(x, 1))
        real*8 :: Ybarn, q(2), p(2), PX, w, wn, r, rn, ur

        ! copy producer prices and taxes
        q(1)    = 1d0
        q(2)    = x(1)
        w       = x(2)
        r       = x(3)

        ! set tax rates (uncomment respective line for different tables)
        taur    = x(4)
        !tauw    = x(4)
        !tauc(1) = x(4)
        !tauc(2) = x(4)

        ! copy the unempoyment rate
        ur      = x(5)

        ! calculate consumer prices and total income
        p     = q*(1d0+tauc)
        PX    = p(1)*alpha(1)/sum(alpha)+p(2)*alpha(2)/sum(alpha)
        tauu  = PX*B*ur/(w*(1-ur))
        wn    = w*(1d0-tauw-tauu)*(1-ur)+PX*B*ur
        rn    = r*(1d0-taur)
        Ybarn = wn*Tbar+rn*Kbar

        ! get market equations
        markets(1) = alpha(1)*Ybarn/p(1)+G-(beta(1)/w)**beta(1)* &
            ((1d0-beta(1))/r)**(1d0-beta(1))*q(1)*(alpha(1)*Ybarn/p(1)+G)
        markets(2) = 1d0-(beta(2)/w)**beta(2)*((1d0-beta(2))/r)**(1d0-beta(2))*q(2)
        markets(3) = beta(1)/w*q(1)*(alpha(1)*Ybarn/p(1)+G)+ &
            beta(2)/w*q(2)*alpha(2)*Ybarn/p(2)+(1-ur)*((1d0-alpha(1)-alpha(2))*Ybarn/wn-Tbar)
        markets(4) = q(1)*G-tauc(1)/(1d0+tauc(1))*alpha(1)*Ybarn- &
            tauc(2)/(1d0+tauc(2))*alpha(2)*Ybarn-&
            tauw*w*(1-ur)*(Tbar-(1d0-alpha(1)-alpha(2))/wn*Ybarn)-taur*r*Kbar
        markets(5) = log(w*(1-tauw-tauu)/PX)-gamma(1)+gamma(2)*log(ur)

    end function markets

end module


!Please Note: In order to run a fortran OpenMP program, the environment variable
!OMP_NUM_THREADS must be set to the number of threads to be used.  I have been
!running the command 'export OMP_NUM_THREADS=10' to set my thread numbers
!through a system call.  Should this not work, please set the environment
!variable before running.
!
!Thank you

program gaussianElimination

implicit none

integer :: x, y, count, n, rowselect

real :: scalar

real(kind=4), dimension(10, 10) :: matrix

real(kind=4), dimension(10) :: rightside, solutions

!this is the number of rows & columns
n = 10

x = 1

y = 1

do while(x <= n)

        y = 1

        do while(y <= n)

!this code generates values from -10 (inclusive) to 10 (inclusive)
!the basis for this code came from the new mexico tech computer program
!website, at http://infohost.nmt.edu/tcc/help/lang/fortran/scaling.html
                matrix(x, y) = int(rand(0)*(10+1+10))-10

                rightside(x) = int(rand(0)*(10+1+10))-10

                count = count + 1

                y = y + 1

        end do

        x = x + 1

end do

x = 1

count = 0

y = 1

print *, "Original Matrix:"

call printmatrix(matrix, n)

print *, "Beginning Elimination"

call elimination(matrix, n)

print *, "End Elimination"

call backsubstitution(matrix, rightside, solutions, n)

call printmatrix(matrix, n)

Print *, "Below is the solutions to each row: "

do count = 1, 10

print *, rightside(count)

end do

print *, "The solution set for this matrix is: "

do count = 1, 10

print *, solutions(count)

end do

end program gaussianElimination

subroutine printmatrix(matrix, n)

implicit none

integer, intent(in) :: n

integer :: x, y

real, intent(in) :: matrix(10, 10)

x = 1

do while(x <= n)

                write(*, 20) matrix(x, :)

        x = x + 1

end do

20      format(10f10.5)

end subroutine

subroutine elimination(matrix, n)

use omp_lib

implicit none

integer :: row, rowadd, column, test, myid

real, intent(inout) :: matrix(10, 10)

real(kind=4), dimension(10) :: swapvector

real :: scalar

integer, intent(in) :: n

logical :: bool

row = 1

column = 1

do while(row <= n)

        rowadd = row + 1

        !if a zero exists, swap rows
        if(matrix(row, column) == 0) then

                swapvector = matrix(row, :)

                matrix(row, :) = matrix(row + 1, :)

                matrix(row + 1, :) = swapvector

        end if

        if(matrix(row, column) /= 1) then

                scalar = (1/matrix(row, column))

                matrix(row, :) = matrix(row, :) * scalar

        end if

!        print *, "Post reduction"

!        call printmatrix(matrix, n)

        !make all numbers below it in the column a zero

!turn this loop into parallel        do while(rowadd <= n)

        call system("export OMP_NUM_THREADS=10")
        !$OMP PARALLEL DEFAULT(NONE) NUM_THREADS(10) SHARED(matrix, n, row, column) PRIVATE(myid)

        myid = OMP_GET_THREAD_NUM() + 1

        if(myid <= n .and. myid > row) then

                matrix(myid, :) = matrix(myid, :) - matrix(row, :) * matrix(myid, column)

        end if

        !$OMP END PARALLEL

        !move to the next diagonal

        row = row + 1

        column = column + 1

end do

end subroutine

subroutine backsubstitution(matrix, rightside, solutions, n)

use omp_lib

implicit none

real, intent(in) ::matrix(10, 10)

integer, intent(in) :: n

real, intent(inout) :: rightside(10), solutions(10)

integer :: row, col, myid

row = n

do while(row >= 1)

solutions(row) = rightside(row)

do col = row + 1, n

solutions(row) = solutions(row) - (matrix(row, col) * solutions(col))

end do

solutions(row) = solutions(row) / matrix(row, row)

row = row - 1

end do

end subroutine


SUBROUTINE p52(input_file,output_file)
!-------------------------------------------------------------------------
! Program 5.2 Non-axisymmetric analysis of an axisymmetric elastic solid
!             using 8-node rectangular quadrilaterals. Mesh numbered in
!             r- or z- direction.
!-------------------------------------------------------------------------
 USE main
 USE geom
 IMPLICIT NONE
 CHARACTER(len=70),INTENT(IN) :: input_file
 CHARACTER(len=70),INTENT(OUT) :: output_file
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 INTEGER::i,iel,iflag,k,loaded_nodes,lth,ndim=2,ndof=24,nels,neq,nip=4,   &
   nlen,nod=8,nodof=3,nn,nprops=2,np_types,nr,nre,nst=6,nze
 REAL(iwp)::ca,chi,det,one=1.0_iwp,pi,radius,sa,zero=0.0_iwp
 CHARACTER(LEN=15)::argv,element='quadrilateral'
!-----------------------dynamic arrays------------------------------------
 INTEGER,ALLOCATABLE::etype(:),g(:),g_g(:,:),g_num(:,:),kdiag(:),nf(:,:), &
   num(:)
 REAL(iwp),ALLOCATABLE::bee(:,:),coord(:,:),dee(:,:),der(:,:),deriv(:,:), &
 eld(:),fun(:),gc(:),g_coord(:,:),jac(:,:),km(:,:),kv(:),loads(:),        &
 points(:,:),prop(:,:),r_coords(:),sigma(:),weights(:),z_coords(:)
!-----------------------input and initialisation--------------------------

 OPEN(10,FILE=input_file)
 OPEN(11,FILE=output_file)
 READ(10,*)nre,nze,lth,iflag,chi,np_types
 CALL mesh_size(element,nod,nels,nn,nre,nze)
 ALLOCATE(nf(nodof,nn),points(nip,ndim),g(ndof),g_coord(ndim,nn),         &
   dee(nst,nst),coord(nod,ndim),fun(nod),jac(ndim,ndim),eld(ndof),        &
   weights(nip),der(ndim,nod),deriv(ndim,nod),bee(nst,ndof),km(ndof,ndof),&
   sigma(nst),num(nod),g_num(nod,nels),g_g(ndof,nels),gc(ndim),           &
   r_coords(nre+1),z_coords(nze+1),prop(nprops,np_types),etype(nels))
 READ(10,*)prop
 etype=1
 IF(np_types>1)read(10,*)etype
 READ(10,*)r_coords,z_coords
 nf=1
 READ(10,*)nr,(k,nf(:,k),i=1,nr)
 CALL formnf(nf)
 neq=MAXVAL(nf)
 ALLOCATE(kdiag(neq),loads(0:neq))
 pi=ACOS(-one)
 chi=chi*pi/180.0_iwp
 ca=COS(chi)
 sa=SIN(chi)
 kdiag=0
!-----------------------loop the elements to find global arrays sizes-----
 elements_1: DO iel=1,nels
   CALL geom_rect(element,iel,r_coords,z_coords,coord,num,'r')
   CALL num_to_g(num,nf,g)
   g_num(:,iel)=num
   g_coord(:,num)=TRANSPOSE(coord)
   g_g(:,iel)=g
   CALL fkdiag(kdiag,g)
 END DO elements_1
 CALL mesh(g_coord,g_num,argv,nlen,12)
 DO i=2,neq
   kdiag(i)=kdiag(i)+kdiag(i-1)
 END DO
 ALLOCATE(kv(kdiag(neq)))
 WRITE(11,'(2(A,I5))')                                                    &
   " There are",neq," equations and the skyline storage is",kdiag(neq)
!-----------------------element stiffness integration and assembly--------
 CALL sample(element,points,weights)
 kv=zero
 elements_2: DO iel=1,nels
   CALL deemat(dee,prop(1,etype(iel)),prop(2,etype(iel)))
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   km=zero
   gauss_pts_1: DO i=1,nip
     CALL shape_fun(fun,points,i)
     CALL shape_der(der,points,i)
     jac=MATMUL(der,coord)
     det=determinant(jac)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     CALL bmat_nonaxi(bee,radius,coord,deriv,fun,iflag,lth)
     km=km+MATMUL(MATMUL(TRANSPOSE(bee),dee),bee)*det*weights(i)*radius
   END DO gauss_pts_1
   CALL fsparv(kv,km,g,kdiag)
 END DO elements_2
 loads=zero
 READ(10,*)loaded_nodes,(k,loads(nf(:,k)),i=1,loaded_nodes)
!-----------------------equation solution---------------------------------
 CALL sparin(kv,kdiag)
 CALL spabac(kv,loads,kdiag)
 loads(0)=zero
 WRITE(11,'(/A)')"  Node   r-disp      z-disp      t-disp"
 DO k=1,nn
   WRITE(11,'(I5,3E12.4)')k,loads(nf(:,k))
 END DO
!-----------------------recover stresses at nip integrating points--------
 nip=1
 DEALLOCATE(points,weights)
 ALLOCATE(points(nip,ndim),weights(nip))
 CALL sample(element,points,weights)
 WRITE(11,'(/A,I2,A)')" The integration point (nip=",nip,") stresses are:"
 WRITE(11,'(A,A)')" Element      r-coord     z-coord",                    &
   "     sig_r       sig_z       sig_t"
 WRITE(11,'(A,A)')"                                 ",                    &
   "     tau_rz      tau_zt      tau_tr"
 elements_3: DO iel=1,nels
   CALL deemat(dee,prop(1,etype(iel)),prop(2,etype(iel)))
   num=g_num(:,iel)
   coord=TRANSPOSE(g_coord(:,num))
   g=g_g(:,iel)
   eld=loads(g)
   int_pts_2: DO i=1,nip
     CALL shape_fun(fun,points,i)
     CALL shape_der(der,points,i)
     gc=MATMUL(fun,coord)
     jac=MATMUL(der,coord)
     CALL invert(jac)
     deriv=MATMUL(jac,der)
     CALL bmat_nonaxi(bee,radius,coord,deriv,fun,iflag,lth)
     bee(1:4,:)=bee(1:4,:)*ca
     bee(5:6,:)=bee(5:6,:)*sa
     sigma=MATMUL(dee,MATMUL(bee,eld))
     WRITE(11,'(I5,5X,5E12.4/34X,3E12.4)')iel,gc,sigma(:3),sigma(4:6)
   END DO int_pts_2
 END DO elements_3
 CALL dismsh(loads,nf,0.05_iwp,g_coord,g_num,argv,nlen,13)
 CALL vecmsh(loads,nf,0.05_iwp,0.1_iwp,g_coord,g_num,argv,nlen,14)

END SUBROUTINE p52


!
!     (c) 2020-2021 Sourcery, Inc.
!     This software was developed for the U.S. Nuclear Regulatory Commission (US NRC) under contract # 31310020D0006:
!     "Technical Assistance in Support of NRC Nuclear Regulatory Research for Materials, Waste, and Reactor Programs"
!
module calc_cpi

  implicit none

contains

  ! calculate cpi(t)
  pure function cpi_t(K, RTndt, T)

    real :: cpi_t
    real, intent(in) :: K, RTndt, T
    real, parameter :: cKic = 4.0

    associate( &
      aKic => 19.35+8.335*exp(0.02254*(T-RTndt)), &
      bKic => 15.61+50.132*exp(0.008*(T-RTndt)) &
    )
      cpi_t = merge(0.0,1-exp(-((K-aKic)/bKic)**cKic), K < aKic)
    end associate

  end function cpi_t

end module calc_cpi


cc Copyright (C) 2004-2009: Leslie Greengard and June-Yub Lee
cc Contact: greengard@cims.nyu.edu
cc
cc This program is free software; you can redistribute it and/or modify
cc it under the terms of the GNU General Public License as published by
cc the Free Software Foundation; either version 2 of the License, or
cc (at your option) any later version.  This program is distributed in
cc the hope that it will be useful, but WITHOUT ANY WARRANTY; without
cc even the implied warranty of MERCHANTABILITY or FITNESS FOR A
cc PARTICULAR PURPOSE.  See the GNU General Public License for more
cc details. You should have received a copy of the GNU General Public
cc License along with this program;
cc if not, see <http://www.gnu.org/licenses/>.
cc
      program testfft
      implicit none
c
      integer i,ier,iflag,j,k1,k2,mx,ms,mt,n1,n2,nj,nk
      parameter (mx=256*256)
      real(8) xj(mx),yj(mx)
      real(8) sk(mx),tk(mx)
      real(8) err,pi,eps!,salg,ealg
      parameter (pi=3.141592653589793d0)
      complex(8) cj(mx),cj0(mx),cj1(mx)
      complex(8) fk0(mx),fk1(mx)
c
c     --------------------------------------------------
c     create some test data
c     --------------------------------------------------
c
      n1 = 36
      n2 = 40
      ms = 32
      mt = 30
      nj = n1*n2
      do k1 = -n1/2, (n1-1)/2
         do k2 = -n2/2, (n2-1)/2
            j = (k2+n2/2+1) + (k1+n1/2)*n2
            xj(j) = pi*dcos(-pi*k1/n1)
            yj(j) = pi*dcos(-pi*k2/n2)
            cj(j) = cmplx(dsin(pi*j/n1),dcos(pi*j/n2),kind=8)
         enddo
      enddo
c
c     -----------------------
c     start tests
c     -----------------------
c
      iflag = 1
      print*,'Starting 2D testing: ', ' nj =',nj, ' ms,mt =',ms,mt
      do i = 1,3
         if (i.eq.1) eps=1d-4
         if (i.eq.2) eps=1d-8
         if (i.eq.3) eps=1d-12
         print*,' '
         print*,' Requested precision eps =',eps
         print*,' '
c
c     -----------------------
c     call 2D Type 1 method
c     -----------------------
c
         call dirft2d1(nj,xj,yj,cj,iflag,ms,mt,fk0)
         call nufft2d1f90(nj,xj,yj,cj,iflag,eps,ms,mt,fk1,ier)
         call errcomp(fk0,fk1,ms*mt,err)
         print *, ' ier = ',ier
         call errcomp(fk0,fk1,ms*mt,err)
         print *, ' type 1 err = ',err
c
c     -----------------------
c      call 2D Type 2 method
c     -----------------------
         call dirft2d2(nj,xj,yj,cj0,iflag,ms,mt,fk0)
         call nufft2d2f90(nj,xj,yj,cj1,iflag,eps,ms,mt,fk1,ier)
         print *, ' ier = ',ier
         call errcomp(cj0,cj1,nj,err)
         print *, ' type 1 err = ',err
c
c     -----------------------
c      call 2D Type3 method
c     -----------------------
         nk = ms*mt
         do k1 = 1, nk
            sk(k1) = 48D0*(dcos(k1*pi/nk))
            tk(k1) = 32D0*(dsin(-pi/2+k1*pi/nk))
         enddo

         call dirft2d3(nj,xj,yj,cj,iflag,nk,sk,tk,fk0)
         call nufft2d3f90(nj,xj,yj,cj,iflag,eps,nk,sk,tk,fk1,ier)
c
         print *, ' ier = ',ier
         call errcomp(fk0,fk1,nk,err)
         print *, ' type 1 err = ',err
      enddo
      stop
      end
c
c
c
c
c
      subroutine errcomp(fk0,fk1,n,err)
      implicit none
      integer k,n
      complex(8) fk0(n), fk1(n)
      real(8) salg,ealg,err
c
      ealg = 0d0
      salg = 0d0
      do k = 1, n
         ealg = ealg + abs(fk1(k)-fk0(k))**2
         salg = salg + abs(fk0(k))**2
      enddo
      err =sqrt(ealg/salg)
      return
      end


subroutine evolve_step(mass,  pos,  vel, &
                  acc,  jerk, n, t, &
                  dt,  epot, coll_time)
	use numz
	use dim
	use face, only:predict_step,get_acc_jerk_pot_coll,correct_step
	implicit none
    real(b8) mass(0:), pos(0:,0:)
    real(b8) vel(0:,0:),  acc(0:,0:)
    real(b8) jerk(0:,0:)
    integer  n
    real(b8) t,dt
    real(b8) epot
    real(b8) coll_time

	real(b8),allocatable:: old_pos(:,:),old_vel(:,:),old_acc(:,:),old_jerk(:,:)
	allocate( old_pos(0:n-1,0:ndim-1) )
	allocate( old_vel(0:n-1,0:ndim-1) )
	allocate( old_acc(0:n-1,0:ndim-1) )
	allocate( old_jerk(0:n-1,0:ndim-1) )
	old_pos=pos
	old_vel=vel
	old_acc=acc
	old_jerk=jerk

	call predict_step(pos, vel, acc, jerk, n, dt)
	call get_acc_jerk_pot_coll(mass, pos, vel, acc, jerk, n, epot, coll_time)
	call correct_step(pos, vel, acc, jerk, old_pos, old_vel, old_acc, old_jerk, n, dt)
	t = t +dt

	deallocate( old_pos     )
	deallocate( old_vel     )
	deallocate( old_acc     )
	deallocate( old_jerk     )
end subroutine  evolve_step

!/*-----------------------------------------------------------------------------
! *  predict_step  --  takes the first approximation of one Hermite integration
! *                    step, advancing the positions and velocities through a
! *                    Taylor series development up to the order of the jerks.
! *-----------------------------------------------------------------------------
! */

subroutine predict_step(pos,vel, acc, jerk,n,dt)
	use numz
	use dim
	implicit none
    real(b8) pos(0:,0:)
    real(b8) vel(0:,0:)
    real(b8) acc(0:,0:)
    real(b8) jerk(0:,0:)
    integer  n
    real(b8) dt

    real(b8) dt2,dt3
    integer i,k
    dt2=dt*dt
    dt3=dt2*dt
    dt2=dt2/2.0_b8
    dt3=dt3/6.0_b8
    do i=0,n-1
      do k=0,ndim-1

            pos(i,k) = pos(i,k) + vel(i,k)*dt + acc(i,k)*dt2 &
                                                 + jerk(i,k)*dt3
            vel(i,k) = vel(i,k) + acc(i,k)*dt + jerk(i,k)*dt2
      enddo
    enddo
end subroutine predict_step
!/*-----------------------------------------------------------------------------
! *  correct_step  --  takes one iteration to improve the new values of position
! *                    and velocities, effectively by using a higher-order
! *                    Taylor series constructed from the terms up to jerk at
! *                    the beginning and the end of the time step.
! *-----------------------------------------------------------------------------
! */

subroutine correct_step(pos,vel, acc, jerk, &
                  old_pos, old_vel, old_acc, old_jerk, &
                  n,dt)
	use numz
	use dim
	implicit none
    real(b8) pos(0:,0:),vel(0:,0:),acc(0:,0:),jerk(0:,0:)
    real(b8) old_pos(0:,0:),old_vel(0:,0:),old_acc(0:,0:),old_jerk(0:,0:)
    integer  n
    real(b8) dt

    integer i,k

    do i=0,n-1
      do k=0,ndim-1
            vel(i,k) = old_vel(i,k) + (old_acc(i,k) + acc(i,k))*dt/2 &
                                      + (old_jerk(i,k) - jerk(i,k))*dt*dt/12
            pos(i,k) = old_pos(i,k) + (old_vel(i,k) + vel(i,k))*dt/2 &
                                      + (old_acc(i,k) - acc(i,k))*dt*dt/12
      enddo
    enddo
end subroutine correct_step


MODULE ISING
    IMPLICIT NONE
    REAL, PARAMETER               :: TEMP = 3.5, dTEMP = 0.05
    INTEGER, PARAMETER            :: LSIZE = 20
    INTEGER, PARAMETER            :: NTEMP = 40, NSTEP = 10000, ESTEP = 5000
    INTEGER, PARAMETER            :: NSPIN = LSIZE*LSIZE
CONTAINS

SUBROUTINE INIT_TRANSITION_PROBABILITY(tprob, temperature)
    IMPLICIT NONE
    REAL, INTENT(OUT)             :: tprob(1:8)
    REAL, INTENT(IN)              :: temperature
    INTEGER                       :: dE

    ! two possible value: exp(-4J) and exp(-8J)
    DO dE = 4, 8, 4
        tprob(dE) = EXP(-dE/temperature)
    END DO
END SUBROUTINE INIT_TRANSITION_PROBABILITY

SUBROUTINE INIT_CONFIGURATION(spin, init_mag)
    IMPLICIT NONE
    INTEGER, INTENT(OUT)         :: spin(LSIZE+2,LSIZE+2)
    INTEGER, INTENT(IN)          :: init_mag
    INTEGER                      :: spin_up, spin_count
    INTEGER                      :: i, j

    spin_count = 0
    spin_up = (NSPIN + init_mag )/2
    DO i = 2, LSIZE + 1
        DO j = 2, LSIZE + 1
            IF ( spin_count < spin_up ) THEN
                spin_count  = spin_count + 1
                spin(i,j) = 1
            ELSE
                spin(i,j) = -1
            END IF
        END DO
    END DO

    ! Periodic boundary conditon
    spin(1,:)       = spin(LSIZE+1,:)
    spin(LSIZE+2,:) = spin(2,:)
    spin(:,1)       = spin(:,LSIZE+1)
    spin(:,LSIZE+2) = spin(:,2)
END SUBROUTINE INIT_CONFIGURATION

SUBROUTINE METROPOLIS(tprob, spin, i, j, idata, ene, mag)
    IMPLICIT NONE
    REAL, INTENT(IN)                :: tprob(1:8)
    INTEGER, INTENT(INOUT)          :: spin(LSIZE+2,LSIZE+2)
    INTEGER, INTENT(IN)             :: i, j
    INTEGER, INTENT(IN), OPTIONAL   :: idata
    INTEGER, INTENT(OUT), OPTIONAL  :: ene, mag
    INTEGER, SAVE                   :: local_ene, local_mag
    INTEGER                         :: dE
    REAL                            :: random
    LOGICAL                         :: move

    move = .FALSE.
    dE = 2*spin(i,j)*(spin(i-1,j) + spin(i+1,j) + spin(i,j-1) + spin(i,j+1))

    ! Metropolis condition
    IF ( dE <= 0 ) THEN
        move = .TRUE.
    ELSE
        CAll RANDOM_NUMBER(random)
        IF ( tprob(dE) > random ) THEN
            move = .TRUE.
        END IF
    END IF

    IF ( move ) THEN
        ! flip the spin
        spin(i,j) = -spin(i,j)
        ! Periodic boundary condition
        IF ( i == 2 )       spin(LSIZE+2,j) = spin(i,j)
        IF ( i == LSIZE+1 ) spin(1,j)       = spin(i,j)
        IF ( j == 2 )       spin(i,LSIZE+2) = spin(i,j)
        IF ( j == LSIZE+1 ) spin(i,1)       = spin(i,j)
    END IF

    ! data collection if idata, ene, and mag are passed to subroutine
    IF ( PRESENT(idata) .AND. PRESENT(ene) .AND. PRESENT(mag) ) THEN
        IF ( idata == 1 ) THEN
            local_ene = TOTAL_ENE(spin)
            local_mag = TOTAL_MAG(spin)
        END IF
        IF ( move ) THEN
            ene = local_ene + dE
            mag = local_mag + 2*spin(i,j)
        ELSE
            ene = local_ene
            mag = local_mag
        END IF
        ! save value of local_ene, and local_mag for next pass
        local_ene = ene
        local_mag = mag
    END IF
END SUBROUTINE METROPOLIS

SUBROUTINE RESPONSE_FUNCTION(ene_per_spin, mag_per_spin, temperature, output)
    IMPLICIT NONE
    REAL, INTENT(IN)            :: ene_per_spin(NSTEP*NSPIN), mag_per_spin(NSTEP*NSPIN)
    REAL, INTENT(IN)            :: temperature
    INTEGER, INTENT(IN)         :: output
    REAL                        :: ave_ene, ave_ene2, ave_mag, ave_mag2, Cv, chi

    ! Heat capacity
    ave_ene      = SUM(ene_per_spin)/(NSTEP*NSPIN)
    ave_ene2     = SUM(ene_per_spin**2)/(NSTEP*NSPIN)
    Cv           = NSPIN*(ave_ene2 - ave_ene**2)/(temperature**2)

    ! Magnetic susceptability
    ave_mag      = SUM(mag_per_spin)/(NSTEP*NSPIN)
    ave_mag2     = SUM(mag_per_spin**2)/(NSTEP*NSPIN)
    chi          = NSPIN*(ave_mag2 - ave_mag**2)/(temperature)

    WRITE (output, '(F7.3, 4(3X, F15.8))') temperature, ave_ene, ave_mag, Cv, chi
END SUBROUTINE RESPONSE_FUNCTION

SUBROUTINE SPIN_CORRELATION(s, ss1, ss2, ss3, ss4, ss5, temperature, output)
    IMPLICIT NONE
    REAL, INTENT(IN)            :: ss1(NSTEP*NSPIN), ss2(NSTEP*NSPIN), ss3(NSTEP*NSPIN),&
                                   ss4(NSTEP*NSPIN), ss5(NSTEP*NSPIN), s(NSTEP*NSPIN)
    REAL, INTENT(IN)            :: temperature
    INTEGER, INTENT(IN)         :: output

    REAL                        :: G2_1, G2_2, G2_3, G2_4, G2_5
    REAL                        :: s2

    s2 = (SUM(s)/(NSTEP*NSPIN))**2

    G2_1 = SUM(ss1)/(NSTEP*NSPIN) - s2
    G2_2 = SUM(ss2)/(NSTEP*NSPIN) - s2
    G2_3 = SUM(ss3)/(NSTEP*NSPIN) - s2
    G2_4 = SUM(ss4)/(NSTEP*NSPIN) - s2
    G2_5 = SUM(ss5)/(NSTEP*NSPIN) - s2

    WRITE (output, '(F7.3, 5(3X, F15.8))') temperature, G2_1, G2_2, G2_3, G2_4, G2_5
END SUBROUTINE SPIN_CORRELATION

SUBROUTINE SPIN_CONFIGURATION(spin, output)
    IMPLICIT NONE
    INTEGER, INTENT(INOUT)      :: spin(LSIZE+2,LSIZE+2)
    INTEGER, INTENT(IN)         :: output
    INTEGER                     :: i, j

    DO i = 2, LSIZE + 1
        DO j = 2, LSIZE + 1
            IF ( spin(i,j) == 1 )  WRITE (output, '(I3,2(3X,I3))') i, j, 0
            IF ( spin(i,j) == -1 ) WRITE (output, '(I3,2(3X,I3))') i, 0, j
        END DO
    END DO
    ! two blank space to separate between data block
    WRITE (output,*)
    WRITE (output,*)
END SUBROUTINE SPIN_CONFIGURATION

INTEGER FUNCTION TOTAL_ENE(spin)
    IMPLICIT NONE
    INTEGER, INTENT(INOUT)         :: spin(LSIZE+2,LSIZE+2)
    INTEGER                        :: i, j

    TOTAL_ENE = 0.0
    DO i = 2, LSIZE + 1
        DO j = 2, LSIZE + 1
            TOTAL_ENE = TOTAL_ENE - spin(i,j)*(spin(i-1,j) + spin(i+1,j) + spin(i,j-1) + spin(i,j+1))
            END DO
    END DO

    ! Double counting
    TOTAL_ENE = TOTAL_ENE/2
END FUNCTION TOTAL_ENE

INTEGER FUNCTION TOTAL_MAG(spin)
    IMPLICIT NONE
    INTEGER, INTENT(INOUT)         :: spin(LSIZE+2,LSIZE+2)

    TOTAL_MAG = SUM(spin(2:LSIZE+1,2:LSIZE+1))
END FUNCTION TOTAL_MAG
END MODULE ISING


module SmoothingModule
  use KindModule, only: DP, I4B
  use ConstantsModule, only: DZERO, DHALF, DONE, DTWO, DTHREE, DFOUR,            &
 &                           DSIX, DPREC, DEM2, DEM4, DEM5, DEM6, DEM8, DEM14
  implicit none

  contains

  subroutine sSCurve(x,range,dydx,y)
! ******************************************************************************
! COMPUTES THE S CURVE FOR SMOOTH DERIVATIVES BETWEEN X=0 AND X=1
! FROM mfusg smooth SUBROUTINE in gwf2wel7u1.f
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    real(DP), intent(in) :: x
    real(DP), intent(in) :: range
    real(DP), intent(inout) :: dydx
    real(DP), intent(inout) :: y
    !--local variables
    real(DP) :: s
    real(DP) :: xs
! ------------------------------------------------------------------------------
!   code
!
    s = range
    if ( s < DPREC ) s = DPREC
    xs = x / s
    if (xs < DZERO) xs = DZERO
    if (xs <= DZERO) then
      y = DZERO
      dydx = DZERO
    elseif(xs < DONE)then
      y = -DTWO * xs**DTHREE + DTHREE * xs**DTWO
      dydx = -DSIX * xs**DTWO + DSIX * xs
    else
      y = DONE
      dydx = DZERO
    endif
    return
  end subroutine sSCurve

  subroutine sCubicLinear(x,range,dydx,y)
! ******************************************************************************
! COMPUTES THE S CURVE WHERE DY/DX = 0 at X=0; AND DY/DX = 1 AT X=1.
! Smooths from zero to a slope of 1.
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    real(DP), intent(in) :: x
    real(DP), intent(in) :: range
    real(DP), intent(inout) :: dydx
    real(DP), intent(inout) :: y
    !--local variables
    real(DP) :: s
    real(DP) :: xs
! ------------------------------------------------------------------------------
!   code
!
    s = range
    if ( s < DPREC ) s = DPREC
    xs = x / s
    if (xs < DZERO) xs = DZERO
    if (xs <= DZERO) then
      y = DZERO
      dydx = DZERO
    elseif(xs < DONE)then
      y = -DONE * xs**DTHREE + DTWO * xs**DTWO
      dydx = -DTHREE * xs**DTWO + DFOUR * xs
    else
      y = DONE
      dydx = DZERO
    endif
    return
  end subroutine sCubicLinear

  subroutine sCubic(x,range,dydx,y)
! ******************************************************************************
! Nonlinear smoothing function returns value between 0-1; cubic function
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    real(DP), intent(inout) :: x
    real(DP), intent(inout) :: range
    real(DP), intent(inout) :: dydx
    real(DP), intent(inout) :: y
    !--local variables
    real(DP) :: s, aa, bb
    real(DP) :: cof1, cof2, cof3
! ------------------------------------------------------------------------------
!   code
!
    dydx = DZERO
    y = DZERO
    if ( range < DPREC ) range = DPREC
    if ( x < DPREC ) x = DPREC
    s = range
    aa = -DSIX/(s**DTHREE)
    bb = -DSIX/(s**DTWO)
    cof1 = x**DTWO
    cof2 = -(DTWO*x)/(s**DTHREE)
    cof3 = DTHREE/(s**DTWO)
    y = cof1 * (cof2 + cof3)
    dydx = (aa*x**DTWO - bb*x)
    if ( x <= DZERO ) then
      y = DZERO
      dydx = DZERO
    else if ( (x - s) > -DPREC ) then
      y = DONE
      dydx = DZERO
    end if
    return
  end subroutine sCubic

  subroutine sLinear(x,range,dydx,y)
! ******************************************************************************
! Linear smoothing function returns value between 0-1
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    real(DP), intent(inout) :: x
    real(DP), intent(inout) :: range
    real(DP), intent(inout) :: dydx
    real(DP), intent(inout) :: y
    !--local variables
    real(DP) :: s
! ------------------------------------------------------------------------------
!   code
!
    dydx = DZERO
    y = DZERO
    if ( range < DPREC ) range = DPREC
    if ( x < DPREC ) x = DPREC
    s = range
    y = DONE - (s - x)/s
    dydx = DONE/s
    if ( y > DONE ) then
      y = DONE
      dydx = DZERO
    end if
    return
  end subroutine sLinear

  subroutine sQuadratic(x,range,dydx,y)
! ******************************************************************************
! Nonlinear smoothing function returns value between 0-1; quadratic function
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    real(DP), intent(inout) :: x
    real(DP), intent(inout) :: range
    real(DP), intent(inout) :: dydx
    real(DP), intent(inout) :: y
    !--local variables
    real(DP) :: s
! ------------------------------------------------------------------------------
!   code
!
    dydx = DZERO
    y = DZERO
    if ( range < DPREC ) range = DPREC
    if ( x < DPREC ) x = DPREC
    s = range
    y = (x**DTWO) / (s**DTWO)
    dydx = DTWO*x/(s**DTWO)
    if ( y > DONE ) then
      y = DONE
      dydx = DZERO
    end if
    return
  end subroutine sQuadratic

  subroutine sChSmooth(d, smooth, dwdh)
! ******************************************************************************
! Function to smooth channel variables during channel drying
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    real(DP), intent(in) :: d
    real(DP), intent(inout) :: smooth
    real(DP), intent(inout) :: dwdh
    !
    ! -- local variables
    real(DP) :: s
    real(DP) :: diff
    real(DP) :: aa
    real(DP) :: ad
    real(DP) :: b
    real(DP) :: x
    real(DP) :: y
! ------------------------------------------------------------------------------
!   code
!
    smooth = DZERO
    s = DEM5
    x = d
    diff = x - s
    if ( diff > DZERO ) then
      smooth = DONE
      dwdh = DZERO
    else
      aa = -DONE / (s**DTWO)
      ad = -DTWO / (s**DTWO)
      b = DTWO / s
      y = aa * x**DTWO + b*x
      dwdh = (ad*x + b)
      if ( x <= DZERO ) then
        y = DZERO
        dwdh = DZERO
      else if ( diff > -DEM14 ) then
        y = DONE
        dwdh = DZERO
      end if
      smooth = y
    end if
    return
end subroutine sChSmooth

  function sLinearSaturation(top, bot, x) result(y)
! ******************************************************************************
! Linear smoothing function returns value between 0-1;
! Linear saturation function
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- return
    real(DP) :: y
    ! -- dummy variables
    real(DP), intent(in) :: top
    real(DP), intent(in) :: bot
    real(DP), intent(in) :: x
    ! -- local
    real(DP) :: b
! ------------------------------------------------------------------------------
!   code
!
    b = top - bot
    if (x < bot) then
      y = DZERO
    else if (x > top) then
      y = DONE
    else
      y = (x - bot) / b
    end if
    return
  end function sLinearSaturation

  function sCubicSaturation(top, bot, x, eps) result(y)
! ******************************************************************************
! Nonlinear smoothing function returns value between 0-1;
! Quadratic saturation function
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- return
    real(DP) :: y
    ! -- dummy variables
    real(DP), intent(in) :: top
    real(DP), intent(in) :: bot
    real(DP), intent(in) :: x
    real(DP), intent(in), optional :: eps
    ! -- local
    real(DP) :: teps
    real(DP) :: w
    real(DP) :: b
    real(DP) :: s
    real(DP) :: cof1
    real(DP) :: cof2
! ------------------------------------------------------------------------------
!   code
!
    if (present(eps)) then
      teps = eps
    else
      teps = DEM2
    end if
    w = x - bot
    b = top - bot
    s = teps * b
    cof1 = DONE / (s**DTWO)
    cof2 = DTWO / s
    if (w < DZERO) then
      y = DZERO
    else if (w < s) then
      y = -cof1 * (w**DTHREE) + cof2 * (w**DTWO)
    else if (w < (b-s)) then
      y = w / b
    else if (w < b) then
      y = DONE + cof1 * ((b - w)**DTHREE) - cof2 * ((b - w)**DTWO)
    else
      y = DONE
    end if

    return
  end function sCubicSaturation

  function sQuadraticSaturation(top, bot, x, eps, bmin) result(y)
! ******************************************************************************
! Nonlinear smoothing function returns value between 0-1;
! Quadratic saturation function
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- return
    real(DP) :: y
    ! -- dummy variables
    real(DP), intent(in) :: top
    real(DP), intent(in) :: bot
    real(DP), intent(in) :: x
    real(DP), optional, intent(in) :: eps
    real(DP), optional, intent(in) :: bmin
    ! -- local
    real(DP) :: teps
    real(DP) :: tbmin
    real(DP) :: b
    real(DP) :: br
    real(DP) :: bri
    real(DP) :: av
! ------------------------------------------------------------------------------
!   code
!
    if (present(eps)) then
      teps = eps
    else
      teps = DEM6
    end if
    if (present(bmin)) then
      tbmin = bmin
    else
      tbmin = DZERO
    end if
    b = top - bot
    if (b > DZERO) then
      if (x < bot) then
        br = DZERO
      else if (x > top) then
        br = DONE
      else
        br = (x - bot) / b
      end if
      av = DONE / (DONE - teps)
      bri = DONE - br
      if (br < tbmin) then
        br = tbmin
      end if
      if (br < teps) then
        y = av * DHALF * (br*br) / teps
      elseif (br < (DONE-teps)) then
        y = av * br + DHALF * (DONE - av)
      elseif (br < DONE) then
        y = DONE - ((av * DHALF * (bri * bri)) / teps)
      else
        y = DONE
      end if
    else
      if (x < bot) then
        y = DZERO
      else
        y = DONE
      end if
    end if

    return
  end function sQuadraticSaturation

  function svanGenuchtenSaturation(top, bot, x, alpha, beta, sr) result(y)
! ******************************************************************************
! Nonlinear smoothing function returns value between 0-1;
! van Genuchten saturation function
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- return
    real(DP) :: y
    ! -- dummy variables
    real(DP), intent(in) :: top
    real(DP), intent(in) :: bot
    real(DP), intent(in) :: x
    real(DP), intent(in) :: alpha
    real(DP), intent(in) :: beta
    real(DP), intent(in) :: sr
    ! -- local
    real(DP) :: b
    real(DP) :: pc
    real(DP) :: gamma
    real(DP) :: seff
! ------------------------------------------------------------------------------
!   code
!
    b = top - bot
    pc = (DHALF * b) - x
    if (pc <= DZERO) then
      y = DZERO
    else
      gamma = DONE - (DONE / beta)
      seff = (DONE + (alpha * pc)**beta)**gamma
      seff = DONE / seff
      y = seff * (DONE - sr) + sr
    end if

    return
  end function svanGenuchtenSaturation

  function sQuadraticSaturationDerivative(top, bot, x, eps, bmin) result(y)
! ******************************************************************************
! Derivative of nonlinear smoothing function returns value between 0-1;
! Derivative of the quadratic saturation function
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- return
    real(DP) :: y
    ! -- dummy variables
    real(DP), intent(in) :: top
    real(DP), intent(in) :: bot
    real(DP), intent(in) :: x
    real(DP), optional, intent(in) :: eps
    real(DP), optional, intent(in) :: bmin
    ! -- local
    real(DP) :: teps
    real(DP) :: tbmin
    real(DP) :: b
    real(DP) :: br
    real(DP) :: bri
    real(DP) :: av
! ------------------------------------------------------------------------------
!   code
!
    if (present(eps)) then
      teps = eps
    else
      teps = DEM6
    end if
    if (present(bmin)) then
      tbmin = bmin
    else
      tbmin = DZERO
    end if
    b = top - bot
    if (x < bot) then
      br = DZERO
    else if (x > top) then
      br = DONE
    else
      br = (x - bot) / b
    end if
    av = DONE / (DONE - teps)
    bri = DONE - br
    if (br < tbmin) then
      br = tbmin
    end if
    if (br < teps) then
      y = av * br / teps
    elseif (br < (DONE-teps)) then
      y = av
    elseif (br < DONE) then
      y = av * bri / teps
    else
      y = DZERO
    end if
    y = y / b

    return
  end function sQuadraticSaturationDerivative

  function sQSaturation(top, bot, x, c1, c2) result(y)
! ******************************************************************************
! Nonlinear smoothing function returns value between 0-1;
! Cubic saturation function
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- return
    real(DP) :: y
    ! -- dummy variables
    real(DP), intent(in) :: top
    real(DP), intent(in) :: bot
    real(DP), intent(in) :: x
    real(DP), intent(in), optional :: c1
    real(DP), intent(in), optional :: c2
    ! -- local
    real(DP) :: w
    real(DP) :: b
    real(DP) :: s
    real(DP) :: cof1
    real(DP) :: cof2
! ------------------------------------------------------------------------------
!   code
!
    !
    ! -- process optional variables
    if (present(c1)) then
      cof1 = c1
    else
      cof1 = -DTWO
    end if
    if (present(c2)) then
      cof2 = c2
    else
      cof2 = DTHREE
    end if
    !
    ! -- calculate head diference from bottom (w),
    !    calculate range (b), and
    !    calculate normalized head difference from bottom (s)
    w = x - bot
    b = top - bot
    s = w / b
    !
    ! -- divide cof1 and cof2 by range to the power 3 and 2, respectively
    cof1 = cof1 / b**DTHREE
    cof2 = cof2 / b**DTWO
    !
    ! -- calculate fraction
    if (s < DZERO) then
      y = DZERO
    else if(s < DONE) then
      y = cof1 * w**DTHREE + cof2 * w**DTWO
    else
      y = DONE
    end if
    !
    ! -- return
    return
  end function sQSaturation

  function sQSaturationDerivative(top, bot, x, c1, c2) result(y)
! ******************************************************************************
! Nonlinear smoothing function returns value between 0-1;
! Cubic saturation function
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- return
    real(DP) :: y
    ! -- dummy variables
    real(DP), intent(in) :: top
    real(DP), intent(in) :: bot
    real(DP), intent(in) :: x
    real(DP), intent(in), optional :: c1
    real(DP), intent(in), optional :: c2
    ! -- local
    real(DP) :: w
    real(DP) :: b
    real(DP) :: s
    real(DP) :: cof1
    real(DP) :: cof2
! ------------------------------------------------------------------------------
!   code
!
    !
    ! -- process optional variables
    if (present(c1)) then
      cof1 = c1
    else
      cof1 = -DTWO
    end if
    if (present(c2)) then
      cof2 = c2
    else
      cof2 = DTHREE
    end if
    !
    ! -- calculate head diference from bottom (w),
    !    calculate range (b), and
    !    calculate normalized head difference from bottom (s)
    w = x - bot
    b = top - bot
    s = w / b
    !
    ! -- multiply cof1 and cof2 by 3 and 2, respectively, and then
    !    divide by range to the power 3 and 2, respectively
    cof1 = cof1 * DTHREE / b**DTHREE
    cof2 = cof2 * DTWO / b**DTWO
    !
    ! -- calculate derivative of fraction with respect to x
    if (s < DZERO) then
      y = DZERO
    else if(s < DONE) then
      y = cof1 * w**DTWO + cof2 * w
    else
      y = DZERO
    end if
    !
    ! -- return
    return
  end function sQSaturationDerivative

  function sSlope(x, xi, yi, sm, sp, ta) result(y)
! ******************************************************************************
! Nonlinear smoothing function returns a smoothed value of y that has the value
! yi at xi and yi + (sm * dx) for x-values less than xi and yi + (sp * dx) for
! x-values greater than xi, where dx = x - xi.
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- return
    real(DP) :: y
    ! -- dummy variables
    real(DP), intent(in) :: x
    real(DP), intent(in) :: xi
    real(DP), intent(in) :: yi
    real(DP), intent(in) :: sm
    real(DP), intent(in) :: sp
    real(DP), optional, intent(in) :: ta
    ! -- local
    real(DP) :: a
    real(DP) :: b
    real(DP) :: dx
    real(DP) :: xm
    real(DP) :: xp
    real(DP) :: ym
    real(DP) :: yp
! ------------------------------------------------------------------------------
    !
    ! -- set smoothing variable a
    if (present(ta)) then
      a = ta
    else
      a = DEM8
    end if
    !
    ! -- calculate b from smoothing variable a
    b = a / (sqrt(DTWO) - DONE)
    !
    ! -- calculate contributions to y
    dx = x - xi
    xm = DHALF * (x + xi - sqrt(dx + b**DTWO - a**DTWO))
    xp = DHALF * (x + xi + sqrt(dx + b**DTWO - a**DTWO))
    ym = sm * (xm - xi)
    yp = sp * (xi - xp)
    !
    ! -- calculate y from ym and yp contributions
    y = yi + ym + yp
    !
    ! -- return
    return
  end function sSlope

  function sSlopeDerivative(x, xi, sm, sp, ta) result(y)
! ******************************************************************************
! Derivative of nonlinear smoothing function that has the value yi at xi and
! yi + (sm * dx) for x-values less than xi and yi + (sp * dx) for x-values
! greater than xi, where dx = x - xi.
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- return
    real(DP) :: y
    ! -- dummy variables
    real(DP), intent(in) :: x
    real(DP), intent(in) :: xi
    real(DP), intent(in) :: sm
    real(DP), intent(in) :: sp
    real(DP), optional, intent(in) :: ta
    ! -- local
    real(DP) :: a
    real(DP) :: b
    real(DP) :: dx
    real(DP) :: mu
    real(DP) :: rho
! ------------------------------------------------------------------------------
    !
    ! -- set smoothing variable a
    if (present(ta)) then
      a = ta
    else
      a = DEM8
    end if
    !
    ! -- calculate b from smoothing variable a
    b = a / (sqrt(DTWO) - DONE)
    !
    ! -- calculate contributions to derivative
    dx = x - xi
    mu = sqrt(dx**DTWO + b**DTWO - a**DTWO)
    rho = dx / mu
    !
    ! -- calculate derivative from individual contributions
    y = DHALF * (sm + sp) - DHALF * rho * (sm - sp)
    !
    ! -- return
    return
  end function sSlopeDerivative

  function sQuadratic0sp(x, xi, tomega) result(y)
! ******************************************************************************
! Nonlinear smoothing function returns a smoothed value of y that uses a
! quadratic to smooth x over range of xi - epsilon to xi + epsilon.
! Simplification of sQuadraticSlope with sm = 0, sp = 1, and yi = 0.
! From Panday et al. (2013) - eq. 35 - https://dx.doi.org/10.5066/F7R20ZFJ
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- return
    real(DP) :: y
    ! -- dummy variables
    real(DP), intent(in) :: x
    real(DP), intent(in) :: xi
    real(DP), optional, intent(in) :: tomega
    ! -- local
    real(DP) :: omega
    real(DP) :: epsilon
    real(DP) :: dx
! ------------------------------------------------------------------------------
    !
    ! -- set smoothing interval
    if (present(tomega)) then
      omega = tomega
    else
      omega = DEM6
    end if
    !
    ! -- set smoothing interval
    epsilon = DHALF * omega
    !
    ! -- calculate distance from xi
    dx = x - xi
    !
    ! -- evaluate smoothing function
    if (dx < -epsilon) then
      y = xi
    else if (dx < epsilon) then
      y = (dx**DTWO / (DFOUR * epsilon)) + DHALF * dx + (epsilon / DFOUR) + xi
    else
      y = x
    end if
    !
    ! -- return
    return
  end function sQuadratic0sp

  function sQuadratic0spDerivative(x, xi, tomega) result(y)
! ******************************************************************************
! Derivative of nonlinear smoothing function returns a smoothed value of y
! that uses a quadratic to smooth x over range of xi - epsilon to xi + epsilon.
! Simplification of sQuadraticSlope with sm = 0, sp = 1, and yi = 0.
! From Panday et al. (2013) - eq. 35 - https://dx.doi.org/10.5066/F7R20ZFJ
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- return
    real(DP) :: y
    ! -- dummy variables
    real(DP), intent(in) :: x
    real(DP), intent(in) :: xi
    real(DP), optional, intent(in) :: tomega
    ! -- local
    real(DP) :: omega
    real(DP) :: epsilon
    real(DP) :: dx
! ------------------------------------------------------------------------------
    !
    ! -- set smoothing interval
    if (present(tomega)) then
      omega = tomega
    else
      omega = DEM6
    end if
    !
    ! -- set smoothing interval
    epsilon = DHALF * omega
    !
    ! -- calculate distance from xi
    dx = x - xi
    !
    ! -- evaluate smoothing function
    if (dx < -epsilon) then
      y = 0
    else if (dx < epsilon) then
      y = (dx / omega) + DHALF
    else
      y = 1
    end if
    !
    ! -- return
    return
  end function sQuadratic0spDerivative

  function sQuadraticSlope(x, xi, yi, sm, sp, tomega) result(y)
! ******************************************************************************
! Quadratic smoothing function returns a smoothed value of y that has the value
! yi at xi and yi + (sm * dx) for x-values less than xi and yi + (sp * dx) for
! x-values greater than xi, where dx = x - xi.
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- return
    real(DP) :: y
    ! -- dummy variables
    real(DP), intent(in) :: x
    real(DP), intent(in) :: xi
    real(DP), intent(in) :: yi
    real(DP), intent(in) :: sm
    real(DP), intent(in) :: sp
    real(DP), optional, intent(in) :: tomega
    ! -- local
    real(DP) :: omega
    real(DP) :: epsilon
    real(DP) :: dx
    real(DP) :: c
! ------------------------------------------------------------------------------
    !
    ! -- set smoothing interval
    if (present(tomega)) then
      omega = tomega
    else
      omega = DEM6
    end if
    !
    ! -- set smoothing interval
    epsilon = DHALF * omega
    !
    ! -- calculate distance from xi
    dx = x - xi
    !
    ! -- evaluate smoothing function
    if (dx < -epsilon) then
      y = sm * dx
    else if (dx < epsilon) then
      c = dx / epsilon
      y = DHALF * epsilon * (DHALF * (sp - sm) * (DONE + c**DTWO) + (sm + sp) * c)
    else
      y = sp * dx
    end if
    !
    ! -- add value at xi
    y = y + yi
    !
    ! -- return
    return
  end function sQuadraticSlope

  function sQuadraticSlopeDerivative(x, xi, sm, sp, tomega) result(y)
! ******************************************************************************
! Derivative of quadratic smoothing function returns a smoothed value of y
! that has the value yi at xi and yi + (sm * dx) for x-values less than xi and
! yi + (sp * dx) for x-values greater than xi, where dx = x - xi.
! ******************************************************************************
!
!    SPECIFICATIONS:
! ------------------------------------------------------------------------------
    ! -- return
    real(DP) :: y
    ! -- dummy variables
    real(DP), intent(in) :: x
    real(DP), intent(in) :: xi
    real(DP), intent(in) :: sm
    real(DP), intent(in) :: sp
    real(DP), optional, intent(in) :: tomega
    ! -- local
    real(DP) :: omega
    real(DP) :: epsilon
    real(DP) :: dx
    real(DP) :: c
! ------------------------------------------------------------------------------
    !
    ! -- set smoothing interval
    if (present(tomega)) then
      omega = tomega
    else
      omega = DEM6
    end if
    !
    ! -- set smoothing interval
    epsilon = DHALF * omega
    !
    ! -- calculate distance from xi
    dx = x - xi
    !
    ! -- evaluate smoothing function
    if (dx < -epsilon) then
      y = sm
    else if (dx < epsilon) then
      c = dx / epsilon
      y = DHALF * ((sp - sm) * c + (sm + sp))
    else
      y = sp
    end if
    !
    ! -- return
    return
  end function sQuadraticSlopeDerivative

end module SmoothingModule


program complex_06
implicit none

real, parameter :: a = 3.0, b = 4.0
complex, parameter :: i_ = (0, 1)
complex, parameter :: z = a + i_*b
real, parameter :: x = z
real, parameter :: y = real(z)
real, parameter :: w = aimag(z)

print *, x, y, w

end program