program BVESingleGaussianVortexDriver
!> @file BVESingleGaussianVortex.f90
!> Driver program for the problem of a single Gaussian vortex on a rotating sphere.
!> @author Peter Bosler, Sandia National Laboratories Center for Computing Research
!>
!> Driver program for the problem of a single Gaussian vortex on a rotating sphere.@n
!> Demonstrates the solution of an inviscid incompressible flow on the sphere using @ref SphereBVE,
!> @ref SphereBVESolver, @ref Refinement, and @ref SSRFPACKRemesh.
!>
!> @image html BVEGaussVortSol.png "Late-time vorticity distribution of an initially Gaussian vortex on a rotating sphere (coarse resolution)."
!>
!>
use NumberKindsModule
use OutputWriterModule
use LoggerModule
use ParticlesModule
use EdgesModule
use FacesModule
use PolyMesh2dModule
use FieldModule
use MPISetupModule
use SphereGeomModule
use SphereBVEModule
use SphereBVESolverModule
use RefinementModule
use SSRFPACKInterfaceModule
use SSRFPACKRemeshModule

implicit none

include 'mpif.h'

! mesh variables
type(BVEMesh) :: sphere
type(RefineSetup) :: refinement
integer(kint) :: initNest
integer(kint) :: maxNest
integer(kint) :: faceKind
integer(kint) :: meshSeed
integer(kint) :: amrLimit
real(kreal), parameter :: radius = 1.0_kreal
logical(klog) :: continueAMR
logical(klog) :: AMR
integer(kint) :: nParticlesBefore
integer(kint) :: nParticlesAfter
namelist /meshDefine/ faceKind, initNest, amrLimit

! test case variables
real(kreal), allocatable, dimension(:) :: kineticEnergy, enstrophy
real(kreal), save :: GAUSS_CONST = 0.0_kreal
real(kreal) :: shapeParam
real(kreal) :: rotRate
real(kreal) :: vortStrength
real(kreal) :: vortInitLat
real(kreal) :: vortInitLon
real(kreal), dimension(3) :: vortCenter
real(kreal) :: flowMapVarTol
real(kreal) :: circulationTol
namelist /gaussVort/ shapeParam, rotRate, vortStrength, vortInitLat, vortInitLon, flowMapVarTol, circulationTol

! remeshing
type(BVERemeshSource) :: remesh
integer(kint) :: remeshInterval
integer(kint) :: remeshCounter
type(BVEMesh) :: tempSphere

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

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

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

!--------------------------------
!	initialize : setup computing environment
!--------------------------------

call MPI_INIT(mpiErrCode)
call MPI_COMM_SIZE(MPI_COMM_WORLD, numProcs, mpiErrCode)
call MPI_COMM_RANK(MPI_COMM_WORLD, procRank, mpiErrCode)

call InitLogger(exeLog, procRank)

timeStart = MPI_WTIME()

call ReadNamelistFile( procRank )

call SetSigmaFlag(1)

!
!	initialize mesh and spatial fields
!
t = 0.0_kreal
call New( sphere, meshSeed, initNest, maxNest, amrLimit, radius, rotRate )

vortCenter = radius * [ cos(vortInitLon) * cos(vortInitLat), sin(vortInitLon) * cos(vortInitLat), sin(vortInitLat)]
call SetInitialVorticityOnMesh( sphere, GaussianVortexVorticity)
GAUSS_CONST = SetGaussConst(sphere)
call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logKey)//" GAUSS_CONST = ", GAUSS_CONST)
call SetInitialVorticityOnMesh( sphere, GaussianVortexVorticity)
call LogMessage(exeLog, DEBUG_LOGGING_LEVEL, trim(logKey)//" ", "uniform mesh ready...")

AMR = (maxNest > initNest)
if ( AMR ) then
	call LogMessage(exeLog, DEBUG_LOGGING_LEVEL, trim(logKey)//" ", "starting adaptive refinement...")
	call New(refinement, sphere%mesh%faces%N_Max)
	call SetAbsoluteTolerances( sphere, circulationTol, flowMapVarTol)
	call LogMessage(exeLog, DEBUG_LOGGING_LEVEL, trim(logKey)//" ", "AMR ready.")

	do i = 1, amrLimit
		write(logString,"(A,I2)") 'amr loop ', i
		call StartSection(exeLog, trim(logString) )
		call IterateMeshRefinementOneVariableAndFlowMap( refinement, sphere%mesh, sphere%relVort, ScalarIntegralRefinement, &
			circulationTol, "circulation refinement", flowMapVarTol, nParticlesBefore, nParticlesAfter)

		call SetInitialVorticityOnMesh(sphere, GaussianVortexVorticity)
		GAUSS_CONST = SetGaussConst(sphere)
		call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logKey)//" GAUSS_CONST = ", GAUSS_CONST)
		call SetInitialVorticityOnMesh(sphere, GaussianVortexVorticity)
		call EndSection(exeLog)
	enddo

	call Delete(refinement)
	call LoadBalance(sphere%mpiParticles, sphere%mesh%particles%N, numProcs)
endif

call SetStreamFunctionsOnMesh(sphere)
call SetVelocityOnMesh(sphere)

call AddTracers(sphere, 1, [1])
sphere%tracers(1)%name = "initLat"
sphere%tracers(1)%units = "radians"
do i = 1, sphere%mesh%particles%N
	vec3 = PhysCoord(sphere%mesh%particles, i)
	call InsertScalarToField(sphere%tracers(1), Latitude(vec3))
enddo

frameCounter = 0
remeshCounter = 0
if ( procRank == 0 ) then
	call LogStats(sphere, exeLog)
	if (meshSeed == ICOS_TRI_SPHERE_SEED) then
		if ( initNest == maxNest) then
			write(meshString, '(A,I1,A)') '_icosTri', initNest, '_'
		else
			write(meshString, '(2(A,I1),A)') '_icosTriAMR', initNest, 'to', maxNest, '_'
		endif
	elseif (meshSeed == CUBED_SPHERE_SEED ) then
		if ( initNest == maxNest ) then
			write(meshString, '(A,I1,A)') '_cubedSphere', initNest, '_'
		else
			write(meshString, '(2(A,I1),A)') '_cubedSphereAMR', initNest, 'to', maxNest, '_'
		endif
	endif

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

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

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

!
!	initialize time stepping
!

!$acc enter data create(solver)
call New(solver, sphere)

nTimesteps = floor(tfinal / dt)
allocate(kineticEnergy(nTimesteps+1))
allocate(enstrophy(nTimesteps+1))
kineticEnergy(1) = TotalKE(sphere)
enstrophy(1) = TotalEnstrophy(sphere)
!--------------------------------
!	run : evolve the problem in time
!--------------------------------

call LogMessage(exeLog, DEBUG_LOGGING_LEVEL, trim(logkey)//" ", "starting timestepping loop.")
do timeJ = 0, nTimesteps - 1

	if ( mod(timeJ+1, remeshInterval) == 0 ) then
		call New(remesh, sphere)

		call New( tempSphere, meshSeed, initNest, maxNest, amrLimit, radius, rotRate )
		call AddTracers(tempSphere, 1, [1])
		tempSphere%tracers(1)%name = "initLat"
		tempSphere%tracers(1)%units = "radians"

		call LagrangianRemeshBVEWithVorticityFunction(remesh, sphere, tempSphere, AMR, GaussianVortexVorticity, &
					scalarIntegralRefinement, circulationTol, "circulation refinement", &
					RefineFlowMapYN = .TRUE., flowMapVarTol = flowMapVarTol, nLagTracers = 1, tracerFn1 = InitLatTracer )

		call Copy(sphere, tempSphere)

		remeshCounter = remeshCounter + 1

		call Delete(tempSphere)
		call Delete(remesh)

		call Delete(solver)
		!$acc exit data delete(solver)

		call New(solver, sphere)
	endif

	call Timestep(solver, sphere, dt)

	t = real(timeJ +1, kreal) * dt
	sphere%mesh%t = t

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

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

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

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

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

deallocate(kineticEnergy)
deallocate(enstrophy)
call Delete(solver)
call Delete(sphere)
if (AMR) call Delete(refinement)

call MPI_FINALIZE(mpiErrCode)

contains

!> @brief Returns the latitude of a Lagrangian coordinate.
!>
!> Conforms to numberkindsmodule::scalarFnOf3DSpace interface.
pure function InitLatTracer( x0, y0, z0 )
	real(kreal) :: InitLatTracer
	real(kreal), intent(in) :: x0, y0, z0
	InitLatTracer = Latitude( x0, y0, z0 )
end function

!> @brief Sets absolute tolerances for AMR criteria based on an initially uniform mesh with corresponding vorticity distribution.
!> @param[in] aBVEMesh @ref SphereBVE mesh
!> @param[inout] circTol On input, relative tolerance (between 0 and 1).  On output, absolute tolerance for circulation magnitude about a face.
!> @param[inout] lagVarTol On input, relative tolerance (between 0 and 1).  On output, absolute tolerance for Lagrangian variation magnitude on each face.
subroutine SetAbsoluteTolerances( aBVEMesh, circTol, lagVarTol )
	type(BVEMesh), intent(in) :: aBVEMesh
	real(kreal), intent(inout) :: circTol
	real(kreal), intent(inout) :: lagVarTol
	!
	circTol = circTol * MaxCirculationMagnitudePerFace(aBVEMesh)
	lagVarTol = lagVarTol * MaxLagrangianVariationPerFace(aBVEMesh%mesh)
end subroutine

!> @brief Vorticity distribution function, used to define initial conditions and for indirect vorticity interpolation
!> to @f$ t = 0 @f$.
!>
!> Conforms to the numberkindsmodule::scalarFnOf3DSpace interface.
!>
!> @param[in] x
!> @param[in] y
!> @param[in] z
!> @return initial vorticity value at at location (x,y,z)
function GaussianVortexVorticity( x, y, z )
	real(kreal) :: GaussianVortexVorticity
	real(kreal), intent(in) :: x, y, z
	GaussianVortexVorticity = vortStrength * exp( - shapeParam * shapeParam * &
		(radius * radius - x * vortCenter(1) - y * vortCenter(2) - z * vortCenter(3)) ) - GAUSS_CONST
end function

!> @brief Defines a constant to ensure that the total integral of vorticity is zero over the whole sphere.
!>
!> @param[in] aBVEMesh @ref SphereBVE mesh
!> @return C such that
!> @f[
!> 		\int_S \zeta(\vec{x})\,dA = \int_{S} \zeta_G(\vec{x})\,dA - C = 0,
!> @f]
!> where @f$ \zeta_G @f$ is a Gaussian distribution on a sphere.
function SetGaussConst( aBVEMesh )
	real(kreal) :: SetGaussConst
	type(BVEMesh), intent(in) :: aBVEMesh
	SetGaussConst = sum( aBVEMesh%relVort%scalar(1:aBVEMesh%mesh%particles%N) * &
						 aBVEMesh%mesh%particles%area(1:aBVEMesh%mesh%particles%N), &
						 MASK=aBVEMesh%mesh%particles%isActive(1:aBVEMesh%mesh%particles%N) ) / &
						 (4.0_kreal * PI * aBVEMesh%radius )
end function

!> @brief Reads a namelist file, which must be specified on the command line at run-time execution as the first argument,
!> to define the user-specified variables for this driver program.
!>
!> Only MPI rank 0 reads the file; it then broadcasts the relevant data to all other ranks.
!>
!> @param[in] rank MPI rank
subroutine ReadNamelistFile( rank )
	integer(kint), intent(in) :: rank
	!
	character(len=MAX_STRING_LENGTH) :: namelistFilename
	integer(kint), parameter :: initBcast_intSize = 6
	integer(kint), parameter :: initBcast_realSize = 9
	integer(kint), dimension(initBcast_intSize) :: bcastIntegers
	real(kreal), dimension(initBcast_realSize) :: bcastReals
	integer(kint) :: mpiErrCode, readStat

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

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

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

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

		if ( faceKind == 3 ) then
			meshSeed = ICOS_TRI_SPHERE_SEED
		elseif ( faceKind == 4) then
			meshSeed = CUBED_SPHERE_SEED
		else
			call LogMessage(exeLog, WARNING_LOGGING_LEVEL, trim(logkey)//" ReadNamelistFile WARNING : ", &
				" invalid faceKind -- using triangles.")
			meshSeed = ICOS_TRI_SPHERE_SEED
		endif

		maxNest = initNest + amrLimit

!		namelist /meshDefine/ faceKind, initNest, maxNest, amrLimit, radius
!		namelist /timestepping/ dt, tfinal
!		namelist /fileIO/ outputDir, outputRoot, frameOut

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

		bcastReals(1) = dt
		bcastReals(2) = tfinal
		bcastReals(3) = shapeParam
		bcastReals(4) = rotRate
		bcastReals(5) = vortStrength
		bcastReals(6) = vortInitLon
		bcastReals(7) = vortInitLat
		bcastReals(8) = circulationTol
		bcastReals(9) = flowMapVarTol
	endif

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

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

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

	dt = bcastReals(1)
	tfinal = bcastReals(2)
	shapeParam = bcastReals(3)
	rotRate = bcastReals(4)
	vortStrength = bcastReals(5)
	vortInitLon = bcastReals(6)
	vortInitLat = bcastReals(7)
	circulationTol = bcastReals(8)
	flowMapVarTol = bcastReals(9)
end subroutine

!> @brief Initializes a @ref Logger for this executable program.
!>
!> Output is controlled by message priority level and MPI rank.
!>
!> @param[in] log @ref Logger to initialize
!> @param[in] rank MPI rank

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

end program


C * * * * * * * * * * * * * * *
C --- DRIVER FOR RADAR5
C * * * * * * * * * * * * * * *
C       Use make command (relevant to Makefile)

        IMPLICIT REAL*8 (A-H,O-Z)

        REAL*4 TARRAY(2)
        INTEGER, PARAMETER :: DP=kind(1D0)
C --->  PARAMETERS FOR RADAR5 (FULL JACOBIAN) <---
        INTEGER, PARAMETER :: ND=3
        INTEGER, PARAMETER :: NRDENS=1
        INTEGER, PARAMETER :: NGRID=1
        INTEGER, PARAMETER :: NLAGS=1
        INTEGER, PARAMETER :: NJACL=2
        INTEGER, PARAMETER :: MXST=10000
        INTEGER, PARAMETER :: LWORK=30
        INTEGER, PARAMETER :: LIWORK=30
        INTEGER, PARAMETER :: NPAR=4
        REAL(kind=DP), dimension(ND) :: Y
        REAL(kind=DP), dimension(NGRID+1) :: GRID
        REAL(kind=DP), dimension(LWORK) :: WORK
        INTEGER, dimension(LIWORK) :: IWORK
        INTEGER, dimension(NRDENS+1) :: IPAST
        REAL(kind=DP), dimension(NPAR) :: RPAR
        INTEGER, dimension(22) :: ISTAT
        EXTERNAL  FCN,PHI,ARGLAG,JFCN,JACLAG,SOLOUT

c ------ FILE TO OPEN ----------
        OPEN(9,FILE='sol.out')
        REWIND 9

C       PARAMETERS IN THE DIFFERENTIAL EQUATION
        RPAR(1)=4.0D-2
        RPAR(2)=1.0D+4
        RPAR(3)=3.0D+7
        RPAR(4)=0.1D-2
C       RPAR(4)=1.0D-2

C -----------------------------------------------------------------------
C
C --- DIMENSION OF THE SYSTEM
        N=ND
C --- COMPUTE THE JACOBIAN ANALYTICALLY
        IJAC=1
C --- JACOBIAN IS A FULL MATRIX
        MLJAC=N
C --- DIFFERENTIAL EQUATION IS IN EXPLICIT FORM
      IMAS=0
      MLMAS=N

C --- OUTPUT ROUTINE IS USED DURING INTEGRATION
        IOUT=0
C --- INITIAL VALUES
        X=0.0D0
        Y(1)= 1.0D0
        Y(2)= 0.0D0
        Y(3)= 0.0D0
C       Consistent with initial function
C --- ENDPOINT OF INTEGRATION
        XEND=1.0D+11
C --- REQUIRED (RELATIVE AND ABSOLUTE) TOLERANCE
        ITOL=0
        RTOL=1.D-9
        ATOL=RTOL*1.D-5
C --- INITIAL STEP SIZE
        H=1.0D-6
C --- DEFAULT VALUES FOR PARAMETERS
        DO 10 I=1,20
        IWORK(I)=0
C --- STEP-SIZE STRATEGY
        IWORK(8)=0
  10    WORK(I)=0.0D0
C --- MAX NUMBER OF STEPS
        IWORK(2)=1000000
C --- WORKSPACE FOR PAST
        IWORK(12)=MXST
C --- THE SECOND COMPONENT USES RETARDED ARGUMENT
        IWORK(15)=NRDENS
        IPAST(1)=2
C --- SET THE PRESCRIBED GRID-POINTS
       DO I=1,NGRID
         GRID(I)=RPAR(4)*I
       END DO
C --- WORKSPACE FOR GRID
       IWORK(13)=NGRID
C --- SIMPLIFIED NEWTON
       IWORK(14)=1

C _____________________________________________________________________
C --- CALL OF THE SUBROUTINE RADAR5
        CALL DTIME(TARRAY)
        CALL RADAR5(N,FCN,PHI,ARGLAG,X,Y,XEND,H,
     &                  RTOL,ATOL,ITOL,
     &                  JFCN,IJAC,MLJAC,MUJAC,
     &                  JACLAG,NLAGS,NJACL,
     &                  IMAS,SOLOUT,IOUT,
     &                  WORK,IWORK,RPAR,IPAR,IDID,
     &                  GRID,IPAST,QFUN,MLMAS,MUMAS)
        CALL DTIME(TARRAY)

C --- PRINT FINAL SOLUTION SOLUTION
        WRITE (6,90) X,Y(1),Y(2),Y(3)
C --- PRINT STATISTICS
         DO J=13,20
            ISTAT(J)=IWORK(J)
         END DO
        WRITE(6,*)' ***** TOL=',RTOL,'  ELAPSED TIME=',TARRAY(1),' ****'
        WRITE (6,91) (ISTAT(J),J=14,20)
        WRITE (6,92) ISTAT(13)
 90     FORMAT(1X,'X =',F8.2,'    Y =',3E18.10)
 91     FORMAT(' fcn=',I7,' jac=',I6,' step=',I6,
     &        ' accpt=',I6,' rejct=',I6,' dec=',I6,
     &        ' sol=',I7)
 92     FORMAT(' full Newt. its =',I7)
        WRITE(6,*) 'SOLUTION IS TABULATED IN FILE sol.out'

        STOP
        END
C
C
        SUBROUTINE SOLOUT (NR,XOLD,X,HSOL,Y,CONT,LRC,N,
     &                     RPAR,IPAR,IRTRN)
C ----- PRINTS THE DISCRETE OUTPUT AND THE CONTINUOUS OUTPUT
C       AT EQUIDISTANT OUTPUT-POINTS
        IMPLICIT REAL*8 (A-H,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(N) :: Y
        REAL(kind=DP), dimension(LRC) :: CONT
        REAL(kind=DP), dimension(1) :: RPAR
        EXTERNAL PHI

        WRITE (9,99) X,Y(1),Y(2),Y(3)
C
 99     FORMAT(1X,'X =',E15.10,'    Y =',3E18.10)
        RETURN
        END

C
        FUNCTION ARGLAG(IL,X,Y,RPAR,IPAR,PHI,PAST,IPAST,NRDS)
        IMPLICIT REAL*8 (A-H,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(1) :: Y
	  REAL(kind=DP), dimension(1) :: PAST
        INTEGER, dimension(1) :: IPAST
	  INTEGER, dimension(1) :: IPAR
        REAL(kind=DP), dimension(1) :: RPAR

        ARGLAG=X-RPAR(4)
        RETURN
        END
C
        SUBROUTINE FCN(N,X,Y,F,ARGLAG,PHI,RPAR,IPAR,
     &                  PAST,IPAST,NRDS)
        IMPLICIT REAL*8 (A-H,K,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(N) :: Y
        REAL(kind=DP), dimension(N) :: F
        REAL(kind=DP), dimension(1) :: PAST
        INTEGER, dimension(1) :: IPAST
        REAL(kind=DP), dimension(1) :: RPAR
        EXTERNAL PHI

        CALL LAGR5(1,X,Y,ARGLAG,PAST,THETA1,IPOS1,RPAR,IPAR,
     &	         PHI,IPAST,NRDS)
        Y2L1=YLAGR5(2,THETA1,IPOS1,PHI,RPAR,IPAR,
     &              PAST,IPAST,NRDS)
        P=RPAR(3)

        F(1)=-RPAR(1)*Y(1)+RPAR(2)*Y2L1*Y(3)
        F(2)= RPAR(1)*Y(1)-RPAR(2)*Y2L1*Y(3)-P*Y(2)**2
        F(3)= P*Y(2)**2

        RETURN
        END
C
        SUBROUTINE JFCN(N,X,Y,DFY,LDFY,ARGLAG,PHI,RPAR,IPAR,
     &                  PAST,IPAST,NRDS)
C ----- STANDARD JACOBIAN OF THE EQUATION
        IMPLICIT REAL*8 (A-H,K,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(N) :: Y
        REAL(kind=DP), dimension(LDFY,N) :: DFY
        REAL(kind=DP), dimension(1) :: PAST
        INTEGER, dimension(1) :: IPAST
        REAL(kind=DP), dimension(1) :: RPAR
        EXTERNAL PHI

        CALL LAGR5(1,X,Y,ARGLAG,PAST,THETA1,IPOS1,RPAR,IPAR,
     &             PHI,IPAST,NRDS)
        Y2L1=YLAGR5(2,THETA1,IPOS1,PHI,RPAR,IPAR,
     &              PAST,IPAST,NRDS)
        P=RPAR(3)
C       Matrix J(3,3)

        DFY(1,1)=-RPAR(1)
        DFY(1,2)= 0.D0
        DFY(1,3)= RPAR(2)*Y2L1
        DFY(2,1)= RPAR(1)
        DFY(2,2)= -2*P*Y(2)
        DFY(2,3)=-RPAR(2)*Y2L1
        DFY(3,1)= 0.D0
        DFY(3,2)= 2*P*Y(2)
        DFY(3,3)= 0.D0
        RETURN
        END
C
        SUBROUTINE JACLAG(N,X,Y,DFYL,ARGLAG,PHI,IVE,IVC,IVL,
     &                    RPAR,IPAR,PAST,IPAST,NRDS)
C ----- JACOBIAN OF DELAY TERMS IN THE EQUATION
        IMPLICIT REAL*8 (A-H,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(N) :: Y
        REAL(kind=DP), dimension(1) :: DFYL
        REAL(kind=DP), dimension(1) :: PAST
        INTEGER, dimension(1) :: IPAST
        REAL(kind=DP), dimension(1) :: RPAR
        INTEGER, dimension(1) :: IVE,IVC,IVL
        EXTERNAL PHI

        IVL(1)=1
        IVE(1)=1
        IVC(1)=2
        IVL(2)=1
        IVE(2)=2
        IVC(2)=2
        DFYL(1)= RPAR(2)*Y(3)
        DFYL(2)=-RPAR(2)*Y(3)

        RETURN
        END

C
        FUNCTION PHI(I,X,RPAR,IPAR)
        IMPLICIT REAL*8 (A-H,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(1) :: RPAR

        PHI=0.0D0
        RETURN
        END


!!!! Chuong trinh tinh ve phase tren 1 duong tron

   PROGRAM phase_circle
   IMPLICIT NONE

   INTEGER (KIND=8),PARAMETER:: N=4096
   INTEGER (KIND=8),PARAMETER:: Na1=1638,Nb1=410
   REAL (KIND=8),PARAMETER::  r0=10.,delr=3.

   INTEGER (KIND=8):: i,j,ia,ib,na,nb,na2,nb2
   REAL    (KIND=8):: pi,r,rx,ry,rdn_a,rdn_b,rdn_ra,rdn_rb

   INTEGER (KIND=8),DIMENSION(N) :: site_a,site_b
   REAL (KIND=8),DIMENSION(N) :: Ks,S,Sa,Sb

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

   pi=acos(-1.) ; site_a(:)=0 ; site_b(:)=0

   OPEN(unit=11,file='phi_equi.txt')
   OPEN(unit=12,file='phi_a.txt')
   OPEN(unit=13,file='phi_b.txt')

   S(:)=0. ; Sa(:)=0. ; Sb(:)=0.

!!! Doc gia tri
   ia=0 ; ib=0
   DO i=1,N
      READ(11,*)j,Ks(j),S(j)

      S(i)=S(i)-int(S(i)/2./pi)*2.*pi

      IF (S(i)<0.) THEN
         S(i)=S(i)+2.*pi
      END IF

      IF (Ks(i)>0.) THEN
         ia=ia+1
         Sa(ia)=S(i)
      ELSE
         ib=ib+1
         Sb(ib)=S(i)
      END IF
   END DO

   na=ia ; nb=ib
   WRITE(*,*)na,nb

!!! Select na1 at random
   na2=0
   DO WHILE (na2<na1)
      CALL random_number(rdn_a)
      ia=int(rdn_a*(na-1)+1)

      IF (site_a(ia)==0) THEN

         CALL random_number(rdn_ra)
         r=r0+delr*(rdn_ra-1.)
         rx=r*cos(Sa(ia))
         ry=r*sin(Sa(ia))

         WRITE(12,*)ia,Sa(ia),rx,ry
         na2=na2+1
         site_a(ia)=1
      END IF

   END DO

!!! Select nb1 at random
   nb2=0
   DO WHILE (nb2<nb1)
      CALL random_number(rdn_b)
      ib=int(rdn_b*(nb-1)+1)

      IF (site_b(ib)==0) THEN
         CALL random_number(rdn_rb)
         r=r0+delr*(rdn_rb-1.)
         rx=r*cos(Sb(ib))
         ry=r*sin(Sb(ib))

         WRITE(13,*)ib,Sb(ib),rx,ry
         nb2=nb2+1
         site_b(ib)=1
      END IF

   END DO

   CLOSE(11)
   CLOSE(12)
   CLOSE(13)

   END PROGRAM phase_circle


program main
   use pfasst
   use encap
   use pf_my_sweeper
   use pf_mod_mpi
   use pf_my_level
   use probin
   use pf_space_comm
   use pfasst_hypre

   type(pf_pfasst_t) :: pf
   type(hypre_vector_encap) :: x, y, z, v_f, v_c
   real(c_double) :: yval, xval, zval, vval, a, norm
   real(pfdp), pointer :: z_pack(:), v(:)
   type(hypre_vector_factory) :: sf
   integer :: level_index, l
   integer, allocatable :: lev_shape(:,:)
   class(pf_encap_t), allocatable :: y_base, x_base, z_base, v_f_base, v_c_base
   integer :: n
   integer :: ierror
   type(my_sweeper_t) :: s, s_finest
   type(my_level_t) :: my_lev
   type(pf_comm_t) :: comm
   integer :: space_comm, time_comm, space_color, time_color
   character(256) :: pf_fname
   integer :: piece
   real(pfdp) :: t, dtq
   integer :: f_level, c_level

   integer :: nproc, rank, error

   call mpi_init(ierror)
   call mpi_comm_size(MPI_COMM_WORLD, nproc, error)
   call mpi_comm_rank(MPI_COMM_WORLD, rank,  error)

   call probin_init(pf_fname)

   call create_simple_communicators(nspace, ntime, space_comm, time_comm, space_color, time_color, space_dim)

   call pf_mpi_create(comm, time_comm)

   call pf_pfasst_create(pf, comm, fname=pf_fname)

   call PfasstHypreInit(pf, lev_shape, space_color, time_color)

   n = num_grid_points**2
   level_index = 1
   yval = -1.6
   xval = -.43
   a = 2.8
   piece = 2
   t = .1
   dtq = .01

   print *,'Initialize vectors:'
   call sf%create_single(x_base, level_index, lev_shape(level_index,:))
   x = cast_as_hypre_vector(x_base)
   call sf%create_single(y_base, level_index, lev_shape(level_index,:))
   y = cast_as_hypre_vector(y_base)
   call sf%create_single(z_base, level_index, lev_shape(level_index,:))
   z = cast_as_hypre_vector(z_base)

   print *,'Set sin init cond:'
   call initial(y)
   call y%eprint()

   print *,'Setval:'
   call y%setval(yval)
   call y%eprint()

   call x%setval(xval)
   call x%eprint()

   norm = y%norm()
   print *,'Norm:'
   print *,norm
   print *,''

   print *,'Copy:'
   call y%copy(x)
   call y%eprint()

   print *,'Axpy:'
   call y%axpy(a, x)
   call y%eprint()

   print *,'Pack then unpack:'
   allocate(v(n))
   call x%setval(a)
   call x%pack(v)
   call y%unpack(v)
   call y%eprint()

   xval = 1.0
   call x%setval(xval)
   zval = 2.0
   call z%setval(zval)
   s = cast_as_my_sweeper_t(pf%levels(level_index)%ulevel%sweeper)
   print *,'FEval:'
   call s%f_eval(x, t, level_index, y, piece)
   call y%eprint()

   xval = 1.0
   call x%setval(xval)
   zval = 2.0
   call z%setval(zval)
   print *,'FComp:'
   call s%f_comp(y, t, dtq, x, level_index, z, piece)
   call y%eprint()

   if (pf%nlevels > 1) then
      f_level = level_index + 1
      c_level = level_index
      call sf%create_single(v_f_base, f_level, lev_shape(f_level,:))
      v_f = cast_as_hypre_vector(v_f_base)
      call sf%create_single(v_c_base, c_level, lev_shape(c_level,:))
      v_c = cast_as_hypre_vector(v_c_base)

      my_lev = cast_as_my_level_t(pf%levels(level_index)%ulevel);
      vval = 1.0
      call v_f%setval(vval)
      vval = 0.0
      call v_c%setval(vval)
      call my_lev%restrict(pf%levels(f_level), pf%levels(c_level), v_f, v_c, t);
      print *,'Restrict:'
      call v_c%eprint()

      my_lev = cast_as_my_level_t(pf%levels(level_index)%ulevel);
      vval = 1.0
      call v_c%setval(vval)
      vval = 0.0
      call v_f%setval(vval)
      call my_lev%interpolate(pf%levels(f_level), pf%levels(c_level), v_f, v_c, t);
      print *,'Interpolate:'
      call v_f%eprint()
   end if

   !if (rank == 0) then
   !end if
   !call mpi_barrier(MPI_COMM_WORLD, error)
   !if (rank == 1) then
   !   call y%eprint()
   !end if

   call s%destroy(pf, level_index)
   call sf%destroy_single(y_base)
   call sf%destroy_single(x_base)

   call mpi_finalize(ierror)

end program


! =====================================================================
! subroutine NRML
!
! This subroutine normalizes a wavefunction.
! ---------------------------------------------------------------------
      subroutine NRML(nRP,nR,nP,RdRP,U)
      implicit none

      integer :: nRP
      integer :: nR
      integer :: nP
      double precision :: RdRP(nR)
      double complex :: U(nRP)

      integer :: i
      double precision :: A

      double precision :: NRM

      A = NRM(nRP,nR,nP,RdRP,U)
      A = 1.0d0/dsqrt(A)

      do i = 1, nRP
         U(i) = dcmplx(A,0.0d0)*U(i)
      enddo

      return
      end
! =====================================================================


c     Subroutine to convert string vector to float vector
c     AJ_Kettle, 11Dec2018

      SUBROUTINE convert_variable_column2(f_ndflag,f_convertfactor,
     +   l_timestamp_rgh,l_timestamp,s_prcp_datavalue,

     +   f_prcp_datavalue)

      IMPLICIT NONE
c************************************************************************
c     Declare variables passed into program

      REAL                :: f_ndflag
      REAL                :: f_convertfactor

      INTEGER             :: l_timestamp_rgh
      INTEGER             :: l_timestamp

      CHARACTER(LEN=5)    :: s_prcp_datavalue(l_timestamp_rgh)
      REAL                :: f_prcp_datavalue(l_timestamp_rgh)
c*****
c     Variables used inside program
      INTEGER             :: i,j,k,ii,jj,kk
      INTEGER             :: i_len

      REAL                :: f_prelim
c************************************************************************
c      print*,'just inside convert_variable_column'

      DO i=1,l_timestamp
       f_prcp_datavalue(i)=f_ndflag   !initial float to f_ndflag

       i_len=LEN_TRIM(s_prcp_datavalue(i))

c      Act if string length>0
       IF (i_len.GT.0) THEN
        READ(s_prcp_datavalue(i),*) f_prelim
        f_prcp_datavalue(i)=f_prelim*f_convertfactor
       ENDIF

c      read(string,*)b
      ENDDO

c      print*,'just leaving convert_variable_column'
c************************************************************************
      RETURN
      END


c      program DRSLNREL
c>> 1999-07-27 DRSLNREL Krogh analyz => SANAL for global analysis.
c>> 1996-07-09 DRSLNREL Krogh Moved formats up.
c>> 1994-11-02 DRSLNREL Krogh  Changes to use M77CON
c>> 1994-07-06 DRSLNREL WVS set up for chgtyp
c
c     Demonstration driver for more accurate routines from chapter 2-15.
c     To illustrate worst-case, expressions are computed little-by-
c     little.  If possible, the routine should be compiled with an
c     option that causes results not to be stored in registers from one
c     assignment to the next.  For Lahey Fortran on a PC, use /7.
c
c--S replaces "?": DR?LNREL, ?GAMMA, ?LNREL, ?RLOG1, ?RLOG, ?REXP
c--   &              ?SINPX, ?COSPX, ?SINHM, ?COSHM, ?CSHMM, ?GAM1
c--   &              ?COS1, ?SIN1, ?ANAL
      real             DPI
      parameter (DPI = 3.141592653589793238462643383279502884197E0)
      real             D, R1MACH, SGAMMA, U, W
      external R1MACH, SGAMMA
      real             SLNREL, SRLOG1, SRLOG, SREXP, SSINPX, SCOSPX
      real             SSINHM, SCOSHM, SCSHMM, SGAM1
      real             SCOS1, SSIN1
      external SLNREL, SRLOG1, SRLOG, SREXP, SSINPX, SCOSPX
      external SSINHM, SCOSHM, SCSHMM, SGAM1
      external SCOS1, SSIN1
10    format (' Error is (relative error) / (round off level).'/
     1' Round off level is (smallest number r such that 1 + r .NE. 1).'/
     2' For the present machine, r =',1p,g13.6/
     3' Errors less than 0.5 r should be considered to be zero.')
c
c     SLNREL
      d = 1.0e0 / 2.0e0**12
      w = 1.0e0 + d
      w = log(w)
      u = slnrel(d)
      call SANAL ('SLNREL',d,u,w)
c
c     SRLOG1
      w = d - w
      u = srlog1(d)
      call SANAL ('SRLOG1',d,u,w)
c
c     SRLOG
      w = d - 1.0e0
      w = w - log(d)
      u = srlog(d)
      call SANAL ('SRLOG ',d,u,w)
c
c     SREXP
      w = exp(d)
      w = w - 1.0e0
      u = srexp(d)
      call SANAL ('SREXP ',d,u,w)
c
c     SSINPX
      d = 25.125e0
      w = sin(d*dpi)
      u = ssinpx(d)
      call SANAL ('SSINPX',d,u,w)
c
c     SCOSPX
      w = cos(d*dpi)
      u = scospx(d)
      call SANAL ('SCOSPX',d,u,w)
c
c     SSIN1
      d = 0.5e0**22
      w = sin(d)
      w = (d - w) / d**3
      u = ssin1(d)
      call SANAL ('SSIN1 ',d,u,w)
c
c     SCOS1
      w = cos(d)
      w = (d - w) / d**2
      u = scos1(d)
      call SANAL ('SCOS1 ',d,u,w)
c
c     SSINHM
      d = 0.25e0
      w = sinh(d)
      w = w - d
      u = ssinhm(d)
      call SANAL ('SSINHM',d,u,w)
c
c     SCOSHM
      w = cosh(d)
      w = w - 1.0e0
      u = scoshm(d)
      call SANAL ('SCOSHM',d,u,w)
c
c     SCSHMM
      w = cosh(d)
      w = w - 1.0e0
      w = w - 0.5*d*d
      u = scshmm(d)
      call SANAL ('SCSHMM',d,u,w)
c
c     SGAM1
      w = 1.0e0/sgamma(1.0e0+d)
      w = w - 1.0e0
      u = sgam1(d)
      call SANAL ('SGAM1 ',d,u,w)
c
      print 10, r1mach(4)
      stop
      end

      subroutine SANAL (ROUTIN, X, U, W)
      character*6 ROUTIN
      real             X, U, W, EW
      real             R1MACH
      external R1MACH
      real             ROUND
      save ROUND
      data ROUND /-1.0e0/
10    format (
     1' Function                    Result         ---- Not Using ----'/
     2' From This                   Using This     --- This Package --'/
     3' Package        Argument     Package        Result        Error')
20    format (1x,a6,5x,1p,e12.4,2x,e13.6,2x,e13.6,1x,e9.2)
      if (round .lt. 0.0e0) then
         round = r1mach(4)
         print 10
      end if
      ew = abs(w-u)/abs(u*round)
      print 20, routin,x,u,w,ew
      return
      end


PROGRAM test_extremes
!
!  Purpose:
!    To read in a real input data set, and use it to test subroutine
!    "extremes".  The optional arguments feature of the subroutine
!    will be tested by calling the subroutine 3 times with different
!    combinations of arguments.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    12/31/95    S. J. Chapman        Original code
!
USE procs
IMPLICIT NONE

! List of parameters:
INTEGER, PARAMETER :: max_size = 1000

! List of variables:
REAL, DIMENSION(max_size) :: a   ! Data array to sort
LOGICAL :: exceed = .FALSE.      ! Logical indicating that array
                                 ! limits are exceeded.
CHARACTER(len=20) :: filename    ! Input data file name
REAL :: large                    ! Largest value in a
INTEGER :: large_pos             ! Pos of largest value in a
INTEGER :: nvals = 0             ! Number of data values in a
REAL :: small                    ! Smallest value in a
INTEGER :: small_pos             ! Pos of smallest value in a
INTEGER :: status                ! I/O status: 0 for success
REAL :: temp                     ! Temporary variable

! Get the name of the file containing the input data.
WRITE (*,*) 'Enter the file name with input data set: '
READ (*,'(A20)') filename

! Open input data file.  Status is OLD because the input data must
! already exist.
OPEN ( UNIT=2, FILE=filename, STATUS='OLD', IOSTAT=status )

! Was the OPEN successful?
fileopen: IF ( status == 0 ) THEN       ! Open successful

   ! The file was opened successfully, so read the data to sort
   ! from it, sort the data, and write out the results.
   ! First read in data.
   DO
      READ (2, *, IOSTAT=status) temp      ! Get value
      IF ( status /= 0 ) EXIT              ! Exit on end of data
      nvals = nvals + 1                    ! Bump count
      size: IF ( nvals <= max_size ) THEN  ! Too many values?
         a(nvals) = temp                   ! No: Save value in array
      ELSE
         exceed = .TRUE.                   ! Yes: Array overflow
      END IF size
   END DO

   ! Was the array size exceeded?  If so, tell user and quit.
   toobig: IF ( exceed ) THEN
      WRITE (*,1000) nvals, max_size
      1000 FORMAT (' Maximum array size exceeded: ', I6, ' > ', I6 )
   ELSE

      ! Limit not exceeded.  Find extremes specifying all arguments
      ! in order.  Tell user.
      CALL extremes (a, nvals, large, large_pos, small, small_pos)
      WRITE (*,1020) 'All arguments in order:           ', &
                     large, large_pos, small, small_pos
      1020 FORMAT (1X,A,2(2X,F6.2,2X,I4))

      ! Find extremes specifying all arguments in arbitrary
      ! order.  Tell user.
      CALL extremes (a, nvals, MAXVAL=large, MINVAL=small, &
                     POS_MAXVAL=large_pos, POS_MINVAL=small_pos)
      WRITE (*,1020) 'All arguments in arbitrary order: ', &
                     large, large_pos, small, small_pos

      ! Find extremes specifying only max and min values.
      CALL extremes (a, nvals, MAXVAL=large, MINVAL=small)
      WRITE (*,1030) 'Large and small only:             ', &
                     large, small
      1030 FORMAT (1X,A,2(2X,F6.2,6X))

   END IF toobig

ELSE fileopen

   ! If we get here, the file open failed.  Tell user.
   WRITE (*,'(A,I6)') ' File open failed: status = ', status

END IF fileopen

END PROGRAM


module constants

implicit none

integer, parameter :: quad = selected_real_kind(33, 4931)

real(quad), parameter :: q_pi = 3.1415926535897932384626433832795

end module constants


C$Procedure  VZERO    ( Is a vector the zero vector? )

      LOGICAL FUNCTION VZERO ( V )

C$ Abstract
C
C     Indicate whether a 3-vector is the zero vector.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     MATH
C     VECTOR
C
C$ Declarations

      DOUBLE PRECISION      V ( 3 )

C$ Brief_I/O
C
C     Variable  I/O  Description
C     --------  ---  --------------------------------------------------
C     V          I   Vector to be tested.
C
C     The function returns the value .TRUE. if and only if V is the
C     zero vector.
C
C$ Detailed_Input
C
C     V              is a vector in 3-space.
C
C$ Detailed_Output
C
C     The function returns the value .TRUE. if and only if V is the
C     zero vector.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This function has the same truth value as the logical expression
C
C        VNORM ( V )  .EQ.  0.D0
C
C     Replacing the above expression by
C
C        VZERO ( V )
C
C     has several advantages:  the latter expresses the test more
C     clearly, looks better, and doesn't go through the work of scaling,
C     squaring, taking a square root, and re-scaling (all of which
C     VNORM must do) just to find out that a vector is non-zero.
C
C     A related function is VZEROG, which accepts vectors of arbitrary
C     dimension.
C
C$ Examples
C
C     1)  When testing whether a vector is the zero vector, one
C         normally constructs tests like
C
C            IF (  VNORM ( V )  .EQ.  0.D0  ) THEN
C                        .
C                        .
C                        .
C
C
C         These can be replaced with the code
C
C            IF (  VZERO ( V )  ) THEN
C                        .
C                        .
C                        .
C
C
C      2)  Check that a normal vector is non-zero before creating
C         a plane with PNV2PL:
C
C         IF (  VZERO ( NORMAL )  )  THEN
C
C            [ handle error ]
C
C         ELSE
C
C            CALL PNV2PL ( POINT, NORMAL, PLANE )
C                          .
C                          .
C                          .
C
C$ Restrictions
C
C     None.
C
C$ Literature_References
C
C     None.
C
C$ Author_and_Institution
C
C     N.J. Bachman   (JPL)
C     I.M. Underwood (JPL)
C
C$ Version
C
C-    SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C        Comment section for permuted index source lines was added
C        following the header.
C
C-    SPICELIB Version 1.0.0, 17-JUL-1990  (NJB) (IMU)
C
C-&

C$ Index_Entries
C
C     test whether a 3-dimensional vector is the zero vector
C
C-&

C
C     `Just do it'.
C
C
      VZERO   =        (  V(1) .EQ. 0.D0  )
     .          .AND.  (  V(2) .EQ. 0.D0  )
     .          .AND.  (  V(3) .EQ. 0.D0  )

      RETURN
      END


! -*- f95 -*-

module utility
    use, intrinsic :: iso_c_binding
    use sort, only : quick_sort, insertion_sort_2d
    implicit none
contains
    ! --------------------------------------------------------------------
    ! SUBROUTINE  mean_sd_1d
    !     Compute the mean and sample standard deviation of an array
    !
    !     In
    !     n  : integer(long), number of samples in x
    !     x  : real(double), array of values of length n
    !
    !     Out
    !     mn : real(double), mean of x
    !     sd : real(double), sample standard deviation of x
    ! --------------------------------------------------------------------
    subroutine mean_sd_1d(n, x, mn, sd) bind(C)
        integer(c_long), intent(in) :: n
        real(c_double), intent(in) :: x(n)
        real(c_double), intent(out) :: mn, sd
        ! local
        real(c_double) :: Ex, Ex2
        integer(c_long) :: i

        Ex2 = 0._c_double
        mn = 0._c_double

        do i=1, n
            mn = mn + x(i)
            Ex2 = Ex2 + (x(i) - x(1))**2
        end do

        ! can compute outside loop since mean is the same computation
        Ex = mn - (n * x(1))

        sd = sqrt((Ex2 - (Ex**2 / n)) / (n - 1))
        mn = mn / n
    end subroutine

    ! --------------------------------------------------------------------
    ! SUBROUTINE  unique
    !     Compute the unique values, and their counts in an array
    !
    !     In
    !     n     : integer(long), number of samples in x
    !     x(n)  : real(double), array of values of length n
    !
    !     Out
    !     uniq(n)   : real(double), first j values are the unique values of x
    !     counts(n) : integer(long), first j values are the counts of the unique values
    !     j         : integer(long), number of unique values in x
    ! --------------------------------------------------------------------
    subroutine unique(n, x, uniq, counts, j) bind(C)
        integer(c_long), intent(in) :: n
        real(c_double), intent(in) :: x(n)
        real(c_double), intent(out) :: uniq(n), counts(n)
        integer(c_long), intent(out) :: j
    !f2py intent(hide) :: n
        integer(c_long) :: i
        real(c_double) :: y(n)

        y = x
        call quick_sort(n, y)

        counts = 0._c_double

        uniq(1) = y(1)
        counts(1) = 1._c_double
        j = 2_c_long

        do i=2_c_long, n
            if (y(i) .NE. y(i-1)) then
                uniq(j) = y(i)
                counts(j) = counts(j) + 1
                j = j + 1
            else
                counts(j - 1) = counts(j - 1) + 1
            end if
        end do
        j = j - 1  ! make length of unique samples valid
    end subroutine

    ! --------------------------------------------------------------------
    ! SUBROUTINE  gmean
    !     Compute the geometric mean of a series
    !
    !     In
    !     n     : integer(long), number of samples in x
    !     x(n)  : real(double), array of values of length n
    !
    !     Out
    !     gm : real(double), geometric mean of the series x
    ! --------------------------------------------------------------------
    subroutine gmean(n, x, gm) bind(C)
        integer(c_long), intent(in) :: n
        real(c_double), intent(in) :: x(n)
        real(c_double), intent(out) :: gm
    !f2py intent(hide) :: n
        real(c_double) :: logsum, prod
        real(c_double), parameter :: large=1.d64, small=1.d-64
        integer(c_long) :: i

        logsum = 0._c_double
        prod = 1._c_double

        do i=1, n
            prod = prod * x(i)
            if ((prod > large) .OR. (prod < small)) then
                logsum = logsum + log(prod)
                prod = 1._c_double
            end if
        end do
        gm = exp((logsum + log(prod)) / n)
    end subroutine

    ! --------------------------------------------------------------------
    ! SUBROUTINE  embed_sort
    !     Create embedding vectors from the array x, and get the indices of the sorted embedding vectors
    !
    !     In
    !     n, m   : integer(long)
    !     x(n)   : real(double), array of values of length n
    !     order  : integer(long), order (number of values) of each embedding vector
    !     delay  : integer(long), number of samples to skip when extracting each embedding vector
    !
    !     Out
    !     res(m, order)  : integer(long), sorted embedding vectors
    ! --------------------------------------------------------------------
    subroutine embed_sort(n, m, x, order, delay, res) bind(C, name="embed_sort")
        integer(c_long), intent(in) :: n, m, order, delay
        real(c_double), intent(in) :: x(n)
        integer(c_long), intent(out) :: res(m, order)
        ! local
        integer(c_long) :: j
        real(c_double) :: temp(m, order)

        do j=0, order-1
            res(:, j+1) = j
        end do

        do j=0, order-1
            temp(:, j+1) = x(j * delay + 1:j * delay + 1 + m)
        end do

        call insertion_sort_2d(m, order, temp, res)
    end subroutine

    ! --------------------------------------------------------------------
    ! SUBROUTINE  hist
    !     Count the values of x in bins of equal width
    !
    !     Input
    !     n       : integer(8), number of samples in x
    !     x       : real(8), array of values of length n
    !     ncells  : integer(8), number of cells
    !     min_val : real(8), minimum value in x
    !     max_val : real(8), maximum value in x
    !
    !     Output
    !     counts  : integer(8), counts in each bin
    ! --------------------------------------------------------------------
    subroutine hist(n, x, ncells, min_val, max_val, counts) bind(C)
        integer(c_long), intent(in) :: n, ncells
        real(c_double), intent(in) :: x(n), min_val, max_val
        integer(c_long), intent(out) :: counts(ncells)
    !f2py intent(hide) :: n
        integer(c_long) :: i, idx
        real(c_double) :: bin_width

        counts = 0_c_long

        bin_width = (max_val - min_val) / ncells

        ! prevent counting when no variation
        if (bin_width == 0._c_double) then
            bin_width = 1._c_double  ! prevent 0 division
        end if

        do i=1, n
            if (.NOT. isnan(x(i))) then
                idx = int((x(i) - min_val) / bin_width, c_long) + 1
                if (idx > ncells) then
                    idx = ncells
                end if

                counts(idx) = counts(idx) + 1
            end if
        end do
    end subroutine

    ! --------------------------------------------------------------------
    ! SUBROUTINE  histogram
    !     Setup values for computing a histogram on x
    !
    !     Input
    !     n          : integer(8), number of samples in x
    !     k          : integer(8), number of cells, =ceiling(sqrt(n))
    !     x          : real(8), array of values of length n
    !
    !     Output
    !     descriptor : integer(8), length 3 array of description of the histogram
    !     counts     : integer(8), counts in each bin
    ! --------------------------------------------------------------------
    subroutine histogram(n, k, x, descriptor, counts) bind(C)
        integer(c_long), intent(in) :: n, k
        real(c_double), intent(in) :: x(n)
        real(c_double), intent(out) :: descriptor(3)
        integer(c_long), intent(out) :: counts(k)
    !f2py intent(hide) :: n
        real(c_double) :: min_val, max_val, delta

        min_val = minval(x)
        max_val = maxval(x)
        delta = (max_val - min_val) / (n - 1)

        descriptor(1) = min_val - delta / 2._c_double
        descriptor(2) = max_val + delta / 2._c_double
        descriptor(3) = real(k, c_double)

        call hist(n, x, k, min_val, max_val, counts)
    end subroutine
end module utility


program main
  implicit none
  integer(KIND=8) :: fsize, re_i, numc, i, j, cycle_length, maturity_length, curr_cycle, last_cycle, fish_sum
  integer(KIND=8), dimension(:), allocatable :: in_num, cycles, maturing
  character(len=:), allocatable :: mystr
  cycle_length = 7
  maturity_length = 3
  inquire(FILE='day 6.txt', size=fsize)
  allocate(character(fsize) :: mystr)
  open (69, file='day 6.txt')
  read(69, '(A)') mystr
  numc = countsubstring(mystr, ",")
  allocate (in_num(numc + 1))
  rewind 69
  read(69, *) in_num
  allocate(cycles(cycle_length))
  allocate(maturing(maturity_length))
  maturing = 0
  cycles = 0
  do i = 1, numc + 1
    cycles(in_num(i)+1) = cycles(in_num(i)+1) + 1
  end do
  do i = 1, 255
    curr_cycle = modulo(i, cycle_length) + 1
    last_cycle = modulo(i - 1, cycle_length) + 1
    cycles(last_cycle) = cycles(last_cycle) + maturing(1)
    do j = 1, maturity_length - 1
        maturing(j) = maturing(j+1)
    end do
    maturing(maturity_length) = cycles(curr_cycle)
    if (i .eq. 79) then
        fish_sum = sum(cycles) + sum(maturing)
        write (*,*) fish_sum
    end if
  end do
  fish_sum = sum(cycles) + sum(maturing)
  write (*,*) fish_sum
  re_i = system("pause")

contains
    function countsubstring(s1, s2) result(c)
      character(*), intent(in) :: s1, s2
      integer :: c, p, posn

      c = 0
      if(len(s2) == 0) return
      p = 1
      do
        posn = index(s1(p:), s2)
        if(posn == 0) return
        c = c + 1
        p = p + posn + len(s2)
      end do
    end function
endprogram


      recursive subroutine concon(iopt,m,x,y,w,v,s,nest,maxtr,maxbin,
     * n,t,c,sq,sx,bind,wrk,lwrk,iwrk,kwrk,ier)
      implicit none
c  given the set of data points (x(i),y(i)) and the set of positive
c  numbers w(i), i=1,2,...,m,subroutine concon determines a cubic spline
c  approximation s(x) which satisfies the following local convexity
c  constraints  s''(x(i))*v(i) <= 0, i=1,2,...,m.
c  the number of knots n and the position t(j),j=1,2,...n is chosen
c  automatically by the routine in a way that
c       sq = sum((w(i)*(y(i)-s(x(i))))**2) be <= s.
c  the fit is given in the b-spline representation (b-spline coef-
c  ficients c(j),j=1,2,...n-4) and can be evaluated by means of
c  subroutine splev.
c
c  calling sequence:
c
c     call concon(iopt,m,x,y,w,v,s,nest,maxtr,maxbin,n,t,c,sq,
c    * sx,bind,wrk,lwrk,iwrk,kwrk,ier)
c
c  parameters:
c    iopt: integer flag.
c          if iopt=0, the routine will start with the minimal number of
c          knots to guarantee that the convexity conditions will be
c          satisfied. if iopt=1, the routine will continue with the set
c          of knots found at the last call of the routine.
c          attention: a call with iopt=1 must always be immediately
c          preceded by another call with iopt=1 or iopt=0.
c          unchanged on exit.
c    m   : integer. on entry m must specify the number of data points.
c          m > 3. unchanged on exit.
c    x   : real array of dimension at least (m). before entry, x(i)
c          must be set to the i-th value of the independent variable x,
c          for i=1,2,...,m. these values must be supplied in strictly
c          ascending order. unchanged on exit.
c    y   : real array of dimension at least (m). before entry, y(i)
c          must be set to the i-th value of the dependent variable y,
c          for i=1,2,...,m. unchanged on exit.
c    w   : real array of dimension at least (m). before entry, w(i)
c          must be set to the i-th value in the set of weights. the
c          w(i) must be strictly positive. unchanged on exit.
c    v   : real array of dimension at least (m). before entry, v(i)
c          must be set to 1 if s(x) must be locally concave at x(i),
c          to (-1) if s(x) must be locally convex at x(i) and to 0
c          if no convexity constraint is imposed at x(i).
c    s   : real. on entry s must specify an over-estimate for the
c          the weighted sum of squared residuals sq of the requested
c          spline. s >=0. unchanged on exit.
c   nest : integer. on entry nest must contain an over-estimate of the
c          total number of knots of the spline returned, to indicate
c          the storage space available to the routine. nest >=8.
c          in most practical situation nest=m/2 will be sufficient.
c          always large enough is  nest=m+4. unchanged on exit.
c  maxtr : integer. on entry maxtr must contain an over-estimate of the
c          total number of records in the used tree structure, to indic-
c          ate the storage space available to the routine. maxtr >=1
c          in most practical situation maxtr=100 will be sufficient.
c          always large enough is
c                         nest-5      nest-6
c              maxtr =  (       ) + (        )  with l the greatest
c                           l          l+1
c          integer <= (nest-6)/2 . unchanged on exit.
c  maxbin: integer. on entry maxbin must contain an over-estimate of the
c          number of knots where s(x) will have a zero second derivative
c          maxbin >=1. in most practical situation maxbin = 10 will be
c          sufficient. always large enough is maxbin=nest-6.
c          unchanged on exit.
c    n   : integer.
c          on exit with ier <=0, n will contain the total number of
c          knots of the spline approximation returned. if the comput-
c          ation mode iopt=1 is used this value of n should be left
c          unchanged between subsequent calls.
c    t   : real array of dimension at least (nest).
c          on exit with ier<=0, this array will contain the knots of the
c          spline,i.e. the position of the interior knots t(5),t(6),...,
c          t(n-4) as well as the position of the additional knots
c          t(1)=t(2)=t(3)=t(4)=x(1) and t(n-3)=t(n-2)=t(n-1)=t(n)=x(m)
c          needed for the the b-spline representation.
c          if the computation mode iopt=1 is used, the values of t(1),
c          t(2),...,t(n) should be left unchanged between subsequent
c          calls.
c    c   : real array of dimension at least (nest).
c          on successful exit, this array will contain the coefficients
c          c(1),c(2),..,c(n-4) in the b-spline representation of s(x)
c    sq  : real. unless ier>0 , sq contains the weighted sum of
c          squared residuals of the spline approximation returned.
c    sx  : real array of dimension at least m. on exit with ier<=0
c          this array will contain the spline values s(x(i)),i=1,...,m
c          if the computation mode iopt=1 is used, the values of sx(1),
c          sx(2),...,sx(m) should be left unchanged between subsequent
c          calls.
c    bind: logical array of dimension at least nest. on exit with ier<=0
c          this array will indicate the knots where s''(x)=0, i.e.
c                s''(t(j+3)) .eq. 0 if  bind(j) = .true.
c                s''(t(j+3)) .ne. 0 if  bind(j) = .false., j=1,2,...,n-6
c          if the computation mode iopt=1 is used, the values of bind(1)
c          ,...,bind(n-6) should be left unchanged between subsequent
c          calls.
c   wrk  : real array of dimension at least (m*4+nest*8+maxbin*(maxbin+
c          nest+1)). used as working space.
c   lwrk : integer. on entry,lwrk must specify the actual dimension of
c          the array wrk as declared in the calling (sub)program.lwrk
c          must not be too small (see wrk). unchanged on exit.
c   iwrk : integer array of dimension at least (maxtr*4+2*(maxbin+1))
c          used as working space.
c   kwrk : integer. on entry,kwrk must specify the actual dimension of
c          the array iwrk as declared in the calling (sub)program. kwrk
c          must not be too small (see iwrk). unchanged on exit.
c   ier   : integer. error flag
c      ier=0 : normal return, s(x) satisfies the concavity/convexity
c              constraints and sq <= s.
c      ier<0 : abnormal termination: s(x) satisfies the concavity/
c              convexity constraints but sq > s.
c        ier=-3 : the requested storage space exceeds the available
c                 storage space as specified by the parameter nest.
c                 probably causes: nest too small. if nest is already
c                 large (say nest > m/2), it may also indicate that s
c                 is too small.
c                 the approximation returned is the least-squares cubic
c                 spline according to the knots t(1),...,t(n) (n=nest)
c                 which satisfies the convexity constraints.
c        ier=-2 : the maximal number of knots n=m+4 has been reached.
c                 probably causes: s too small.
c        ier=-1 : the number of knots n is less than the maximal number
c                 m+4 but concon finds that adding one or more knots
c                 will not further reduce the value of sq.
c                 probably causes : s too small.
c      ier>0 : abnormal termination: no approximation is returned
c        ier=1  : the number of knots where s''(x)=0 exceeds maxbin.
c                 probably causes : maxbin too small.
c        ier=2  : the number of records in the tree structure exceeds
c                 maxtr.
c                 probably causes : maxtr too small.
c        ier=3  : the algorithm finds no solution to the posed quadratic
c                 programming problem.
c                 probably causes : rounding errors.
c        ier=4  : the minimum number of knots (given by n) to guarantee
c                 that the concavity/convexity conditions will be
c                 satisfied is greater than nest.
c                 probably causes: nest too small.
c        ier=5  : the minimum number of knots (given by n) to guarantee
c                 that the concavity/convexity conditions will be
c                 satisfied is greater than m+4.
c                 probably causes: strongly alternating convexity and
c                 concavity conditions. normally the situation can be
c                 coped with by adding n-m-4 extra data points (found
c                 by linear interpolation e.g.) with a small weight w(i)
c                 and a v(i) number equal to zero.
c        ier=10 : on entry, the input data are controlled on validity.
c                 the following restrictions must be satisfied
c                   0<=iopt<=1, m>3, nest>=8, s>=0, maxtr>=1, maxbin>=1,
c                   kwrk>=maxtr*4+2*(maxbin+1), w(i)>0, x(i) < x(i+1),
c                   lwrk>=m*4+nest*8+maxbin*(maxbin+nest+1)
c                 if one of these restrictions is found to be violated
c                 control is immediately repassed to the calling program
c
c  further comments:
c    as an example of the use of the computation mode iopt=1, the
c    following program segment will cause concon to return control
c    each time a spline with a new set of knots has been computed.
c     .............
c     iopt = 0
c     s = 0.1e+60  (s very large)
c     do 10 i=1,m
c       call concon(iopt,m,x,y,w,v,s,nest,maxtr,maxbin,n,t,c,sq,sx,
c    *  bind,wrk,lwrk,iwrk,kwrk,ier)
c       ......
c       s = sq
c       iopt=1
c 10  continue
c     .............
c
c  other subroutines required:
c    fpcoco,fpcosp,fpbspl,fpadno,fpdeno,fpseno,fpfrno
c
c  references:
c   dierckx p. : an algorithm for cubic spline fitting with convexity
c                constraints, computing 24 (1980) 349-371.
c   dierckx p. : an algorithm for least-squares cubic spline fitting
c                with convexity and concavity constraints, report tw39,
c                dept. computer science, k.u.leuven, 1978.
c   dierckx p. : curve and surface fitting with splines, monographs on
c                numerical analysis, oxford university press, 1993.
c
c  author:
c   p. dierckx
c   dept. computer science, k.u.leuven
c   celestijnenlaan 200a, b-3001 heverlee, belgium.
c   e-mail : Paul.Dierckx@cs.kuleuven.ac.be
c
c  creation date : march 1978
c  latest update : march 1987.
c
c  ..
c  ..scalar arguments..
      real*8 s,sq
      integer iopt,m,nest,maxtr,maxbin,n,lwrk,kwrk,ier
c  ..array arguments..
      real*8 x(m),y(m),w(m),v(m),t(nest),c(nest),sx(m),wrk(lwrk)
      integer iwrk(kwrk)
      logical bind(nest)
c  ..local scalars..
      integer i,lwest,kwest,ie,iw,lww
      real*8 one
c  ..
c  set constant
      one = 0.1e+01
c  before starting computations a data check is made. if the input data
c  are invalid, control is immediately repassed to the calling program.
      ier = 10
      if(iopt.lt.0 .or. iopt.gt.1) go to 30
      if(m.lt.4 .or. nest.lt.8) go to 30
      if(s.lt.0.) go to 30
      if(maxtr.lt.1 .or. maxbin.lt.1) go to 30
      lwest = 8*nest+m*4+maxbin*(1+nest+maxbin)
      kwest = 4*maxtr+2*(maxbin+1)
      if(lwrk.lt.lwest .or. kwrk.lt.kwest) go to 30
      if(iopt.gt.0) go to 20
      if(w(1).le.0.) go to 30
      if(v(1).gt.0.) v(1) = one
      if(v(1).lt.0.) v(1) = -one
      do 10 i=2,m
         if(x(i-1).ge.x(i) .or. w(i).le.0.) go to 30
         if(v(i).gt.0.) v(i) = one
         if(v(i).lt.0.) v(i) = -one
  10  continue
  20  ier = 0
c  we partition the working space and determine the spline approximation
      ie = 1
      iw = ie+nest
      lww = lwrk-nest
      call fpcoco(iopt,m,x,y,w,v,s,nest,maxtr,maxbin,n,t,c,sq,sx,
     * bind,wrk(ie),wrk(iw),lww,iwrk,kwrk,ier)
  30  return
      end


      recursive
     *subroutine r1mpyq(m,n,a,lda,v,w)
      integer m,n,lda
      double precision a(lda,n),v(n),w(n)
c     **********
c
c     subroutine r1mpyq
c
c     given an m by n matrix a, this subroutine computes a*q where
c     q is the product of 2*(n - 1) transformations
c
c           gv(n-1)*...*gv(1)*gw(1)*...*gw(n-1)
c
c     and gv(i), gw(i) are givens rotations in the (i,n) plane which
c     eliminate elements in the i-th and n-th planes, respectively.
c     q itself is not given, rather the information to recover the
c     gv, gw rotations is supplied.
c
c     the subroutine statement is
c
c       subroutine r1mpyq(m,n,a,lda,v,w)
c
c     where
c
c       m is a positive integer input variable set to the number
c         of rows of a.
c
c       n is a positive integer input variable set to the number
c         of columns of a.
c
c       a is an m by n array. on input a must contain the matrix
c         to be postmultiplied by the orthogonal matrix q
c         described above. on output a*q has replaced a.
c
c       lda is a positive integer input variable not less than m
c         which specifies the leading dimension of the array a.
c
c       v is an input array of length n. v(i) must contain the
c         information necessary to recover the givens rotation gv(i)
c         described above.
c
c       w is an input array of length n. w(i) must contain the
c         information necessary to recover the givens rotation gw(i)
c         described above.
c
c     subroutines called
c
c       fortran-supplied ... dabs,dsqrt
c
c     argonne national laboratory. minpack project. march 1980.
c     burton s. garbow, kenneth e. hillstrom, jorge j. more
c
c     **********
      integer i,j,nmj,nm1
      double precision cos,one,sin,temp
      data one /1.0d0/
c
c     apply the first set of givens rotations to a.
c
      nm1 = n - 1
      if (nm1 .lt. 1) go to 50
      do 20 nmj = 1, nm1
         j = n - nmj
         if (dabs(v(j)) .gt. one) cos = one/v(j)
         if (dabs(v(j)) .gt. one) sin = dsqrt(one-cos**2)
         if (dabs(v(j)) .le. one) sin = v(j)
         if (dabs(v(j)) .le. one) cos = dsqrt(one-sin**2)
         do 10 i = 1, m
            temp = cos*a(i,j) - sin*a(i,n)
            a(i,n) = sin*a(i,j) + cos*a(i,n)
            a(i,j) = temp
   10       continue
   20    continue
c
c     apply the second set of givens rotations to a.
c
      do 40 j = 1, nm1
         if (dabs(w(j)) .gt. one) cos = one/w(j)
         if (dabs(w(j)) .gt. one) sin = dsqrt(one-cos**2)
         if (dabs(w(j)) .le. one) sin = w(j)
         if (dabs(w(j)) .le. one) cos = dsqrt(one-sin**2)
         do 30 i = 1, m
            temp = cos*a(i,j) + sin*a(i,n)
            a(i,n) = -sin*a(i,j) + cos*a(i,n)
            a(i,j) = temp
   30       continue
   40    continue
   50 continue
      return
c
c     last card of subroutine r1mpyq.
c
      end


!> @brief time_step module
!> @details this module contains derived types and routines that are used to
!> advance the solution defined on a domain in time according to some
!> partial differential equation and boundary and interface conditions

module time_step

  use common, only : wp

  implicit none

  !> @brief low storage Runge-Kutta method parameters
  type :: RK_type
     integer :: nstage ! number of stages
     real(kind = wp),dimension(:),allocatable :: A,B,C ! coefficients
  end type RK_type

contains

  subroutine init_RK(RK)

    !> @brief initializes RK_type that stores Runge-Kutta coefficients
    use common, only : wp
    implicit none

    integer,parameter :: order = 4 !< RK order of accuracy (read from input file)

    type(RK_type),intent(out) :: RK

    ! set RK coefficients

    select case(order)
    case default
       stop 'Invalid Runge-Kutta order in init_RK'
    case(1) ! explicit Euler
       RK%nstage = 1
       allocate(RK%A(RK%nstage),RK%B(RK%nstage),RK%C(0:RK%nstage))
       RK%A = (/ 0.0_wp /)
       RK%B = (/ 1.0_wp /)
       RK%C = (/ 0.0_wp,1.0_wp /)
    case(2) ! Heun
       RK%nstage = 2
       allocate(RK%A(RK%nstage),RK%B(RK%nstage),RK%C(0:RK%nstage))
       RK%A = (/ 0.0_wp,-1.0_wp /)
       RK%B = (/ 1.0_wp,1.0_wp/2.0_wp /)
       RK%C = (/ 0.0_wp,1.0_wp,1.0_wp /)
    case(3) ! Williamson (3,3)
       RK%nstage = 3
       allocate(RK%A(RK%nstage),RK%B(RK%nstage),RK%C(0:RK%nstage))
       RK%A = (/ 0.0_wp, -5.0_wp/9.0_wp, -153.0_wp/128.0_wp /)
       RK%B = (/ 1.0_wp/3.0_wp, 15.0_wp/16.0_wp, 8.0_wp/15.0_wp /)
       RK%C = (/ 0.0_wp, 1.0_wp/3.0_wp, 3.0_wp/4.0_wp, 1.0_wp /)
    case(4) ! Kennedy-Carpenter (5,4)
       RK%nstage = 5
       allocate(RK%A(RK%nstage),RK%B(RK%nstage),RK%C(0:RK%nstage))
       RK%A = (/ 0.0_wp, -567301805773.0_wp/1357537059087.0_wp, -2404267990393.0_wp/2016746695238.0_wp &
            , -3550918686646.0_wp/2091501179385.0_wp, -1275806237668.0_wp/842570457699.0_wp /)
       RK%B = (/ 1432997174477.0_wp/9575080441755.0_wp, 5161836677717.0_wp/13612068292357.0_wp &
            , 1720146321549.0_wp/2090206949498.0_wp, 3134564353537.0_wp/4481467310338.0_wp &
            , 2277821191437.0_wp/14882151754819.0_wp /)
       RK%C = (/ 0.0_wp, 1432997174477.0_wp/9575080441755.0_wp, 2526269341429.0_wp/6820363962896.0_wp &
            , 2006345519317.0_wp/3224310063776.0_wp, 2802321613138.0_wp/2924317926251.0_wp, 1.0_wp /)
    end select

  end subroutine init_RK

  subroutine time_step_RK(D,dt,RK, n)

    !> @brief advance solution in domain by one time step dt using low storage Runge-Kutta method

    use domain, only : domain_type,write_output,enforce_bound_iface_conditions, &
         exchange_fields, scale_rates, set_rates, update_fields, exchange_fields_interface
    !use plastic, only : update_fields_plastic
    !use moment_tensor, only : exact_moment_tensor

    implicit none

    type(domain_type),intent(inout) :: D
    real(kind = wp),intent(in) :: dt
    type(RK_type),intent(in) :: RK
    integer :: stage,stat
    integer,intent(in) :: n
    real(kind = wp) :: t0
    integer :: nqU,nrU,nsU,nqV,nrV,nsV
    real(kind = wp), allocatable, dimension(:,:,:,:) :: u,v
    real(kind = wp), allocatable, dimension(:,:) :: M_fin

    ! initial time

    t0 = D%t

    ! Get moment tensor exact solution

  !  if(D%B(1)%MT%use_moment_tensor) then

  !    call exact_moment_tensor(D%B(1),D%B(1)%MT,D%t)

  !  end if

  !  if(D%B(2)%MT%use_moment_tensor) then

  !    call exact_moment_tensor(D%B(2),D%B(2)%MT,D%t)

  !  end if

    ! loop over RK stages

    do stage = 1,RK%nstage

       call exchange_fields(D)

       ! multiply rates by RK coefficient A

       call scale_rates(D,RK%A(stage))

       ! set rates (only within blocks using elastic wave equation,
       ! does not include SAT forcing, does not set hat variables)

       call set_rates(D)

       ! prepare to enforce interface and boundary conditions

       call exchange_fields_interface(D)

       ! enforce boundary and interface conditions: set hat variables, computes SAT forcing,
       ! and adds SAT forcing to rates

       call enforce_bound_iface_conditions(D, stage)

       ! output fields at time t0
       ! it might seem that this could be done externally,
       ! in the main program time-step loop, before/after advancing the solution
       ! by one time step, but this would not provide "rates" (like slip velocity
       ! fault tractions) at time t0, which are set above during first stage of RK method

       if ((stage==1) .and. (mod(n-1,D%w_stride)==0)) call write_output(D)

       ! update fields

       D%t = t0 + RK%C(stage)*dt
       call update_fields(D, RK%B(stage)*dt,stage,RK%nstage)

       !if (stage == 4) stop

    end do

  end subroutine time_step_RK

end module time_step