program CollidingDipolesDriver
!> @file CollidingDipoles.f90
!> Driver program for the problem of two colliding Lamb dipoles in the plane.
!> @author Peter Bosler, Sandia National Laboratories Center for Computing Research
!>
!> Driver program for the problem of two colliding Lamb dipoles in the plane.@n
!> Demonstrates the solution of an inviscid incompressible flow in the plane using @ref PlanarIncompressible,
!> @ref PlanarIncompressibleSolver, @ref Refinement, and @ref BIVARRemesh.
!>
!> @image html collidingDipolesInitCond.png "Initial vorticity distribution for colliding dipoles problem."
!>
!>
use NumberKindsModule
use OutputWriterModule
use LoggerModule
use ParticlesModule
use EdgesModule
use FacesModule
use PolyMesh2dModule
use FieldModule
use MPISetupModule
use PlaneGeomModule
use PlanarIncompressibleModule
use PlanarIncompressibleSolverModule
use RefinementModule
use BIVARRemeshModule

implicit none

include 'mpif.h'

! mesh variables
type(PlaneMeshIncompressible) :: plane
integer(kint) :: initNest
integer(kint) :: maxNest
integer(kint) :: amrLimit
integer(kint) :: faceKind
integer(kint) :: meshSeed
real(kreal) :: meshRadius

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

namelist /meshDefine/ faceKind, initNest, maxNest, amrLimit, meshRadius

! test case variables
real(kreal), allocatable, dimension(:) :: kineticEnergy, enstrophy
real(kreal) :: radius1
real(kreal) :: initX1
real(kreal) :: initY1
real(kreal) :: initStrength1
real(kreal) :: radius2
real(kreal) :: initX2
real(kreal) :: initY2
real(kreal) :: initStrength2
real(kreal) :: circulationTol
real(kreal) :: flowMapVarTol
real(kreal), parameter :: LAMB_K0 = 3.8317_kreal

namelist /twoDipoles/ radius1, initX1, initY1, initStrength1, radius2, initX2, initY2, initStrength2, &
					  circulationTol, flowMapVarTol

! remeshing variables
integer(kint) :: remeshInterval
integer(kint) :: resetLagParamInterval
integer(kint) :: remeshCounter
type(PlaneMeshIncompressible) :: tempMesh
type(PlaneMeshIncompressible) :: refMesh

! timestepping variables
type(PlaneSolver) :: solver
real(kreal) :: t
real(kreal) :: dt
real(kreal) :: tfinal
integer(kint) :: timeJ
integer(kint) :: nTimesteps

namelist /timestepping/ dt, tfinal, remeshInterval, resetLagParamInterval

! i/o variables
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
logical(klog), save :: logInit = .FALSE.
character(len=MAX_STRING_LENGTH) :: logString
integer(kint), parameter :: logLevel = DEBUG_LOGGING_LEVEL
character(len=28) :: logKey = "twoDipoles"
integer(kint) :: mpiErrCode
real(kreal) :: timeStart, timeEnd
integer(kint) :: i

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

call InitLogger(exeLog, procRank)

timeStart = MPI_WTIME()

call ReadNamelistFile( procRank )

!
!	initialize mesh and spatial fields
!
call New( plane, initNest, maxNest, meshSeed, amrLimit, meshRadius)
call SetInitialVorticityOnMesh( plane, TwoDipolesVorticity )

useAMR = ( amrLimit > 0 )
if ( useAMR ) then

	doFlowMapRefine = .FALSE.

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

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

	do i = 1, amrLimit
		call IterateMeshRefinementOneVariableAndFlowMap( refinement, plane%mesh, plane%vorticity, &
			ScalarIntegralRefinement, circulationTol, "circulation refinement", flowMapVarTol, &
			nParticlesBefore, nParticlesAfter)
		call SetInitialVorticityOnMesh(plane, TwoDipolesVorticity)
	enddo

	call LoadBalance( plane%mpiParticles, plane%mesh%particles%N, numProcs)

	call Delete(refinement)
endif

call AddTracers( plane, 1, [2])
plane%tracers(1)%name = "initX"
call StoreLagParamAsTracer( plane, 1 )
call SetStreamFunctionOnMesh( plane )
call SetVelocityOnMesh( plane )

!
!	output initial state
!
frameCounter = 0
t = 0.0_kreal
if ( procRank == 0 ) then
	call LogStats(plane, exeLog)

	call MeshSeedString( meshString, meshSeed)

	if ( useAMR ) then
		write( meshString, '(A,I1,A,I1,A)') trim(meshString)//"_AMR_", initNest, 'to', initNest+amrLimit, '_'
	else
		write( meshString, '(A,I1,A)') trim(meshString)//'_', initNest, '_'
	endif

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

	call OutputToVTK(plane, vtkFile )

	frameCounter = frameCounter + 1

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

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

!
!	initialize remeshing
!
!call New(tempMesh, initNest, maxNest, meshSeed, amrLimit, meshRadius)
!call AddTracers( tempMesh, 1, [2])
!tempMesh%tracers(1)%name = "initX"
!
!call New( refMesh, initNest, maxNest, meshSeed, amrLimit, meshRadius )
!call AddTracers( refMesh, 1, [2])
!refMesh%tracers(1)%name = "initX"

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

do timeJ = 0, nTimesteps - 1
	!
	! remesh
	!
	if ( mod( timeJ+1, remeshInterval) == 0 ) then
		remeshCounter = remeshCounter + 1
		!
		!	choose remeshing procedure
		!
		if ( remeshCounter < resetLagParamInterval ) then
			!
			!	remesh to t = 0
			!
			call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logKey)//" remeshing to t = 0, remeshCounter = ", remeshCounter)

			call New(tempMesh, initNest, maxNest, meshSeed, amrLimit, meshRadius)
			call AddTracers( tempMesh, 1, [2])

			call LagrangianRemeshPlanarIncompressibleWithVorticityFunction( tempMesh, plane, TwoDipolesVorticity, &
					ScalarIntegralRefinement, circulationTol, "circulation refinement", RefineFlowMapYN = doFlowMapRefine, &
					flowMapVarTol = flowMapVarTol )
			call StoreLagParamAsTracer( tempMesh, 1)

			call Copy( plane, tempMesh)
			call Delete(tempMesh)
		elseif ( remeshCounter == resetLagParamInterval ) then
			!
			!	remesh to t = 0, keep old mesh as reference defined for t = t_remesh
			!
			call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logKey)//" remeshing to t = 0, remeshCounter = ", remeshCounter)

			t = plane%mesh%t
			call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logKey)//" setting new ref_t = ", t)

			call New( refMesh, initNest, maxNest, meshSeed, amrLimit, meshRadius )
			call AddTracers( refMesh, 1, [2])
			refMesh%tracers(1)%name = "initX"

			call LagrangianRemeshPlanarIncompressibleWithVorticityFunction( refMesh, plane, TwoDipolesVorticity, &
					ScalarIntegralRefinement, circulationTol, "circulation refinement", RefineFlowMapYN = doFlowMapRefine, &
					flowMapVarTol = flowMapVarTol )
			call StoreLagParamAsTracer(refMesh, 1)

			call Copy(plane, refMesh)
			refMesh%mesh%t = t

			call ResetLagrangianParameter(refMesh%mesh%particles)
			call ResetLagrangianParameter(plane%mesh%particles)
		elseif ( remeshCounter > resetLagParamInterval .AND. mod(remeshCounter, resetLagParamInterval) == 0 ) then
			!
			!	remesh to previous reference time, then keep current mesh as new reference
			!
			call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logKey)//" remeshing to t = ", refMesh%mesh%t)
			t = plane%mesh%t
			call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logKey)//" setting new ref_t = ", t)

			call New(tempMesh, initNest, maxNest, meshSeed, amrLimit, meshRadius )
			call AddTracers( tempMesh, 1, [2])
			tempMesh%tracers(1)%name = "initX"

			call LogMessage(exeLog, DEBUG_LOGGING_LEVEL, trim(logKey)//" calling remesh routine = ", t)

			call LagrangianRemeshPlanarIncompressibleToReferenceMesh( tempMesh, plane, refMesh, ScalarIntegralRefinement, &
					circulationTol, "circulation refinement", RefineFlowMapYN = doFlowMapRefine, &
					flowMapVarTol = flowMapVarTol)

			call LogMessage(exeLog, DEBUG_LOGGING_LEVEL, trim(logKey)//" returned from remesh = ", t)

			call Copy(plane, tempMesh)
			call Copy(refMesh, tempMesh)
			refMesh%mesh%t = t

			call ResetLagrangianParameter(refMesh%mesh%particles)
			call ResetLagrangianParameter(plane%mesh%particles)
			call Delete(tempMesh)
		else
			!
			!	remesh to reference time
			!
			call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logKey)//" remeshing to t = ", refMesh%mesh%t)
			call New(tempMesh, initNest, maxNest, meshSeed, amrLimit, meshRadius )
			call AddTracers( tempMesh, 1, [2])
			tempMesh%tracers(1)%name = "initX"

			call LagrangianRemeshPlanarIncompressibleToReferenceMesh( tempMesh, plane, refMesh, ScalarIntegralRefinement, &
					circulationTol, "circulation refinement", RefineFlowMapYN = doFlowMapRefine, &
					flowMapVarTol = flowMapVarTol)

			call Copy(plane, tempMesh)
			call Delete(tempMesh)
		endif

		call Delete(solver)
		call New(solver, plane)
	endif

	!
	! advance time step
	!
	call Timestep(solver, plane, dt)
	plane%mesh%t = real( timeJ + 1, kreal) * dt

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

	if ( procRank == 0 .AND. mod(timeJ + 1, frameOut) == 0 ) then
		write(vtkFile,'(A,I0.4,A)') trim(vtkRoot), frameCounter, '.vtk'
		call OutputToVTK(plane, vtkFile)
		frameCounter = frameCounter + 1
		call LogMessage(exeLog, TRACE_LOGGING_LEVEL, trim(logKey)//" t = ", plane%mesh%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(refMesh)
call Delete(solver)
call Delete(plane)

call MPI_FINALIZE(mpiErrCode)

contains

!> @brief Stores the Lagrangian coordinate of each particle as a passive tracer.
!> Helpful for visualization of transport
!>
!> @param[inout] aPlane @ref PlanarIncompressible mesh
!> @param[in] tracerID index to `PlanarIncompressible%%tracers(:)` array to store the Lagrangian coordinate
subroutine StoreLagParamAsTracer( aPlane, tracerID )
	type(PlaneMeshIncompressible), intent(inout) :: aPlane
	integer(kint), intent(in) :: tracerID
	!
	integer(kint) :: i

	do i = 1, aPlane%mesh%particles%N
		aPlane%tracers(tracerID)%xComp(i) = aPlane%mesh%particles%x0(i)
		aPlane%tracers(tracerID)%yCOmp(i) = aPlane%mesh%particles%y0(i)
	enddo
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::scalarFnOf2DSpace interface.
!>
!> @param[in] x
!> @param[in] y
!> @return vorticity value at initial time at location (x,y)
function TwoDipolesVorticity( x, y )
	real(kreal) :: TwoDipolesVorticity
	real(kreal), intent(in) :: x, y

	TwoDipolesVorticity = LambDipole( x, y, radius1, initStrength1, initX1, initY1 ) + &
						  LambDipole( x, y, radius2, initStrength2, initX2, initY2 )
end function

!> @brief Vorticity function associated with a single Lamb dipole at location `(xcent, ycent)`
!>
!> @param[in] x x-coordinate of output vorticity
!> @param[in] y y-coordinate of output vorticity
!> @param[in] lambR radius of dipole
!> @param[in] U0 strength parameter
!> @param[in] xcent x-coordinate of dipole center
!> @param[in] ycent y-coordinate of dipole center
function LambDipole( x, y, lambR, U0, xcent, ycent)
	real(kreal) ::LambDipole
	real(kreal), intent(in) :: x, y, xCent, yCent, lambR, U0
	!
	real(kreal) :: r, k, sintheta, denom
	real(kreal) :: BESSJ0, BESSJ1
	external BESSJ1, BESSJ0

	r = sqrt( (x - xcent) * (x - xcent) + (y - ycent) * (y - ycent) )

	if ( r > lambR .OR. r < ZERO_TOL) then
		LambDipole = 0.0_kreal
	else
		k = LAMB_K0 / lambR

		sintheta = y / r

		denom = BESSJ0( LAMB_K0 )

		LambDipole = -2.0_kreal * U0 * k * BESSJ1( k * r) * sintheta / denom
	endif
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 = 7
	integer(kint), parameter :: initBcast_realSize = 13
	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=TwoDipoles)
			rewind(READ_UNIT)
			read(READ_UNIT, nml=timestepping)
			rewind(READ_UNIT)
			read(READ_UNIT, nml=fileIO)
		close(READ_UNIT)

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

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

		bcastReals(1) = dt
		bcastReals(2) = tfinal
		bcastReals(3) = radius1
		bcastReals(4) = initX1
		bcastReals(5) = initY1
		bcastReals(6) = initStrength1
		bcastReals(7) = radius2
		bcastReals(8) = initX2
		bcastReals(9) = initY2
		bcastReals(10) = initStrength2
		bcastReals(11) = circulationTol
		bcastReals(12) = flowMapVarTol
		bcastReals(13) = meshRadius
	endif

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

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

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

	dt = bcastReals(1)
	tfinal = bcastReals(2)
	radius1 = bcastReals(3)
	initX1 = bcastReals(4)
	initY1 = bcastReals(5)
	initStrength1 = bcastReals(6)
	radius2 = bcastReals(7)
	initX2 = bcastReals(8)
	initY2 = bcastReals(9)
	initStrength2 = bcastReals(10)
	circulationTol = bcastReals(11)
	flowMapVarTol = bcastReals(12)
	meshRadius = bcastReals(13)
end subroutine

!> @brief Initializes a @ref Logger for this executable program.
!>
!> Output is controlled by message priority level and MPI rank.
!>
!> @param[in] aLog @ref Logger to initialize
!> @param[in] rank MPI rank
subroutine InitLogger(aLog,rank)
	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
	logInit = .TRUE.
end subroutine

end program

!>    @brief This function calculates the first kind modified Bessel function
!>     of integer order N, for any REAL X.
!>
!>     We use here the classical
!>     recursion formula, when X > N. For X < N, the Miller's algorithm
!>     is used to avoid overflows.
!>
!>     REFERENCE:
!>     C.W.CLENSHAW, CHEBYSHEV SERIES FOR MATHEMATICAL FUNCTIONS,
!>     MATHEMATICAL TABLES, VOL.5, 1962.
!>
!> @param[in] n order of Bessel function
!> @param[in] x
!> @return Bessel function output, @f$ B_n(x) @f$
FUNCTION BESSJ (N,X)

      PARAMETER (IACC = 40,BIGNO = 1.D10, BIGNI = 1.D-10)
      REAL *8 X,BESSJ,BESSJ0,BESSJ1,TOX,BJM,BJ,BJP,SUM
      IF (N.EQ.0) THEN
      BESSJ = BESSJ0(X)
      RETURN
      ENDIF
      IF (N.EQ.1) THEN
      BESSJ = BESSJ1(X)
      RETURN
      ENDIF
      IF (X.EQ.0.) THEN
      BESSJ = 0.
      RETURN
      ENDIF
      print*,'here'
      TOX = 2./X
      IF (X.GT.FLOAT(N)) THEN
      BJM = BESSJ0(X)
      BJ  = BESSJ1(X)
      DO 11 J = 1,N-1
      BJP = J*TOX*BJ-BJM
      BJM = BJ
      BJ  = BJP
   11 CONTINUE
      BESSJ = BJ
      ELSE
      M = 2*((N+INT(SQRT(FLOAT(IACC*N))))/2)
      BESSJ = 0.
      JSUM = 0
      SUM = 0.
      BJP = 0.
      BJ  = 1.
      DO 12 J = M,1,-1
      BJM = J*TOX*BJ-BJP
      BJP = BJ
      BJ  = BJM
      IF (ABS(BJ).GT.BIGNO) THEN
      BJ  = BJ*BIGNI
      BJP = BJP*BIGNI
      BESSJ = BESSJ*BIGNI
      SUM = SUM*BIGNI
      ENDIF
      IF (JSUM.NE.0) SUM = SUM+BJ
      JSUM = 1-JSUM
      IF (J.EQ.N) BESSJ = BJP
   12 CONTINUE
      SUM = 2.*SUM-BJ
      BESSJ = BESSJ/SUM
      ENDIF
      RETURN
      END

!>  @brief   This function calculates the First Kind Bessel Function of
!>     order 0, for any real number X.
!>
!> The polynomial approximation by
!> series of Chebyshev polynomials is used for 0<X<8 and 0<8/X<1.
!>
!>     REFERENCES:
!>     M.ABRAMOWITZ,I.A.STEGUN, HANDBOOK OF MATHEMATICAL FUNCTIONS, 1965.
!>     C.W.CLENSHAW, NATIONAL PHYSICAL LABORATORY MATHEMATICAL TABLES,
!>     VOL.5, 1962.
!>
!> @param[in] x
!> @return Bessel function output, @f$ B_0(x) @f$
      FUNCTION BESSJ0 (X)
      REAL *8 X,BESSJ0,AX,FR,FS,Z,FP,FQ,XX

      REAL *8 Y,P1,P2,P3,P4,P5,R1,R2,R3,R4,R5,R6  &
               ,Q1,Q2,Q3,Q4,Q5,S1,S2,S3,S4,S5,S6
      DATA P1,P2,P3,P4,P5 /1.D0,-.1098628627D-2,.2734510407D-4, &
      -.2073370639D-5,.2093887211D-6 /
      DATA Q1,Q2,Q3,Q4,Q5 /-.1562499995D-1,.1430488765D-3, &
      -.6911147651D-5,.7621095161D-6,-.9349451520D-7 /
      DATA R1,R2,R3,R4,R5,R6 /57568490574.D0,-13362590354.D0, &
      651619640.7D0,-11214424.18D0,77392.33017D0,-184.9052456D0 /
      DATA S1,S2,S3,S4,S5,S6 /57568490411.D0,1029532985.D0, &
      9494680.718D0,59272.64853D0,267.8532712D0,1.D0 /
      IF(X.EQ.0.D0) GO TO 1
      AX = ABS (X)
      IF (AX.LT.8.) THEN
      Y = X*X
      FR = R1+Y*(R2+Y*(R3+Y*(R4+Y*(R5+Y*R6))))
      FS = S1+Y*(S2+Y*(S3+Y*(S4+Y*(S5+Y*S6))))
      BESSJ0 = FR/FS
      ELSE
      Z = 8./AX
      Y = Z*Z
      XX = AX-.785398164
      FP = P1+Y*(P2+Y*(P3+Y*(P4+Y*P5)))
      FQ = Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*Q5)))
      BESSJ0 = SQRT(.636619772/AX)*(FP*COS(XX)-Z*FQ*SIN(XX))
      ENDIF
      RETURN
    1 BESSJ0 = 1.D0
      RETURN
      END
! ---------------------------------------------------------------------------

!>  @brief   This function calculates the First Kind Bessel Function of
!>     order 1, for any real number X.
!>
!> The polynomial approximation by
!> series of Chebyshev polynomials is used for 0<X<8 and 0<8/X<1.
!>
!>     REFERENCES:
!>     M.ABRAMOWITZ,I.A.STEGUN, HANDBOOK OF MATHEMATICAL FUNCTIONS, 1965.
!>     C.W.CLENSHAW, NATIONAL PHYSICAL LABORATORY MATHEMATICAL TABLES,
!>     VOL.5, 1962.
!>
!> @param[in] x
!> @return Bessel function output, @f$ B_1(x) @f$
      FUNCTION BESSJ1 (X)
      REAL *8 X,BESSJ1,AX,FR,FS,Z,FP,FQ,XX
      REAL *8 Y,P1,P2,P3,P4,P5,P6,R1,R2,R3,R4,R5,R6  &
               ,Q1,Q2,Q3,Q4,Q5,S1,S2,S3,S4,S5,S6
      DATA P1,P2,P3,P4,P5 /1.D0,.183105D-2,-.3516396496D-4,  &
      .2457520174D-5,-.240337019D-6 /,P6 /.636619772D0 /
      DATA Q1,Q2,Q3,Q4,Q5 /.04687499995D0,-.2002690873D-3,   &
      .8449199096D-5,-.88228987D-6,.105787412D-6 /
      DATA R1,R2,R3,R4,R5,R6 /72362614232.D0,-7895059235.D0, &
      242396853.1D0,-2972611.439D0,15704.48260D0,-30.16036606D0 /
      DATA S1,S2,S3,S4,S5,S6 /144725228442.D0,2300535178.D0, &
      18583304.74D0,99447.43394D0,376.9991397D0,1.D0 /

      AX = ABS(X)
      IF (AX.LT.8.) THEN
      Y = X*X
      FR = R1+Y*(R2+Y*(R3+Y*(R4+Y*(R5+Y*R6))))
      FS = S1+Y*(S2+Y*(S3+Y*(S4+Y*(S5+Y*S6))))
      BESSJ1 = X*(FR/FS)
      ELSE
      Z = 8./AX
      Y = Z*Z
      XX = AX-2.35619491
      FP = P1+Y*(P2+Y*(P3+Y*(P4+Y*P5)))
      FQ = Q1+Y*(Q2+Y*(Q3+Y*(Q4+Y*Q5)))
      BESSJ1 = SQRT(P6/AX)*(COS(XX)*FP-Z*SIN(XX)*FQ)*SIGN(S6,X)
      ENDIF
      RETURN
      END


program test_array_manipulation
  use array_manipulation
  integer, dimension(3,3)::array1, array2
  integer, allocatable :: array3(:,:)

  do i=1,3
     do j=1,3
        array1(i,j) = 1
        array2(i,j) = 2
     end do
  end do

  call print_map(array1)
  call print_map(array2)

  print*, "Horizontal Concatenate"
  array3 = concatenate(array1, array2, HORIZONTAL)
  call print_map(array3)
  deallocate(array3)

  print*, "Vertical Concatenate"
  array3 = concatenate(array1, array2, VERTICAL)
  call print_map(array3)
  deallocate(array3)

  print*, "Horizontal Flip"
  allocate(array3(2,2))
  array3 = reshape((/1,2,3,4/), (/2,2/))
  call print_map(array3)

  array3 = horizontal_flip(array3)
  call print_map(array3)
  deallocate(array3)

  print*, "Vertical Flip"
  allocate(array3(2,2))
  array3 = reshape((/1,2,3,4/), (/2,2/))
  call print_map(array3)

  array3 = vertical_flip(array3)
  call print_map(array3)

end program


module map_coef

  ! Healpix module
  use healpix_types

  implicit none

  contains

    subroutine a_lm_gasdev(p_lm_max, coef, seed, mean, std)

      ! p_lm_max - maximum of l and m
      ! coef - array for writing
      ! seed - number for nr ran. num. generator
      ! mean, std - mean and std values for normal distribution

      ! Numerical recipes modules
      use nr, only: gasdev
      use ran_state, only: ran_seed

      implicit none
      integer(kind=i8b), intent(in) :: p_lm_max
      complex(kind=dpc), dimension(0:p_lm_max, 0:p_lm_max), &
                                  intent(out) :: coef
      integer(kind=i4b), intent(in) :: seed
      real(kind=dp), intent(in) :: mean, std

      integer(kind=i8b) :: m, l ! Vars for iterating
      real(kind=sp) :: rand1_sp, rand2_sp ! Vars for complex ran. num.

      ! Initialization
      coef = (0.0_dp, 0.0_dp)

      call ran_seed(seed)

      do l = 0, p_lm_max, 1
        call gasdev(rand1_sp)
        call gasdev(rand2_sp)
        coef(0, l) = dcmplx(std * rand1_sp + mean, 0.0_dp + mean)
        coef(l, l) = dcmplx(std * rand2_sp + mean, 0.0_dp + mean)
      end do

      do m = 1, p_lm_max, 1
        do l = m + 1, p_lm_max, 1
          call gasdev(rand1_sp)
          call gasdev(rand2_sp)
          coef(m, l) = dcmplx(std * rand1_sp + mean, std * rand2_sp + mean)
        end do
      end do

      ! 0- and 1- mode disabled
      coef(0, 0) = (0.0_dp, 0.0_dp)
      coef(0, 1) = (0.0_dp, 0.0_dp)
      coef(1, 1) = (0.0_dp, 0.0_dp)

    end subroutine a_lm_gasdev

end module map_coef


      SUBROUTINE fax(ifax, n, mode)
C-----------------------------------------------
C   M o d u l e s
C-----------------------------------------------
      IMPLICIT NONE
C-----------------------------------------------
C   D u m m y   A r g u m e n t s
C-----------------------------------------------
      INTEGER n, mode
      INTEGER, DIMENSION(13) :: ifax
C-----------------------------------------------
C   L o c a l   V a r i a b l e s
C-----------------------------------------------
      INTEGER :: nn, k, l, inc, nfax, ii, istop, i, item
C-----------------------------------------------
      nn=n
      IF (IABS(mode).eq.1) GOTO 10
      IF (IABS(mode).eq.8) GOTO 10
      nn=n/2
      IF ((nn+nn).eq.n) GOTO 10
      ifax(1)=-99
      RETURN
   10 k=1
c     test for factors of 4
   20 IF (MOD(nn,4).ne.0) GOTO 30
      k=k+1
      ifax(k)=4
      nn=nn/4
      IF (nn.eq.1) GOTO 80
      GOTO 20
c     test for extra factor of 2
   30 IF (MOD(nn,2).ne.0) GOTO 40
      k=k+1
      ifax(k)=2
      nn=nn/2
      IF (nn.eq.1) GOTO 80
c     test for factors of 3
   40 IF (MOD(nn,3).ne.0) GOTO 50
      k=k+1
      ifax(k)=3
      nn=nn/3
      IF (nn.eq.1) GOTO 80
      GOTO 40
c     now find remaining factors
   50 l=5
      inc=2
c     inc alternately takes on values 2 and 4
   60 IF (MOD(nn,l).ne.0) GOTO 70
      k=k+1
      ifax(k)=l
      nn=nn/l
      IF (nn.eq.1) GOTO 80
      GOTO 60
   70 l=l+inc
      inc=6-inc
      GOTO 60
   80 ifax(1)=k-1
c     ifax(1) CONTAINS number of factors
      nfax=ifax(1)
c     sort factors into ascending order
      IF (nfax.eq.1) GOTO 110
      DO 100 ii=2,nfax
      istop=nfax+2-ii
      DO 90 i=2,istop
      IF (ifax(i+1).ge.ifax(i)) GOTO 90
      item=ifax(i)
      ifax(i)=ifax(i+1)
      ifax(i+1)=item
   90 CONTINUE
  100 CONTINUE
  110 CONTINUE

      END SUBROUTINE fax


! integer_set.f90
!     Experiment with an unusual programming style
!
module integer_sets
    implicit none

    type INTEGER_OPERAND
        integer                        :: operation
        integer                        :: value
        type(INTEGER_OPERAND), pointer :: first
        type(INTEGER_OPERAND), pointer :: second
    end type INTEGER_OPERAND

    type INTEGER_RELATION
        integer                        :: relation
        logical                        :: value
        type(INTEGER_OPERAND), pointer :: first
        type(INTEGER_OPERAND), pointer :: second
    end type INTEGER_RELATION

    type INTEGER_SET
        type(INTEGER_RELATION)         :: relation
    end type INTEGER_SET

    type(INTEGER_OPERAND)              :: x
    type(INTEGER_OPERAND)              :: y

    interface assignment(=)
        module procedure integer_set_value
    end interface

    interface operator(+)
        module procedure integer_add
    end interface

    interface operator(.eq.)
        module procedure integer_equal
        module procedure integer_equal_v
    end interface

contains

subroutine integer_set_value( x, value )
    type(INTEGER_OPERAND), intent(out) :: x
    integer, intent(in)                :: value

    x%operation = 0
    x%value     = value
    x%first     => null()
    x%second    => null()
end subroutine integer_set_value

function integer_add( x, y ) result(add)
    type(INTEGER_OPERAND), intent(in), target  :: x
    type(INTEGER_OPERAND), intent(in), target  :: y
    type(INTEGER_OPERAND), pointer             :: add

    allocate( add )

    add%operation =  1
    add%first     => x
    add%second    => y
end function integer_add

function integer_equal( x, y ) result(equal)
    type(INTEGER_OPERAND), intent(in), target   :: x
    type(INTEGER_OPERAND), intent(in), target   :: y
    type(INTEGER_RELATION), pointer             :: equal

    allocate( equal )

    equal%relation =  1
    equal%first    => x
    equal%second   => y
end function integer_equal

function integer_equal_v( x, y ) result(equal)
    type(INTEGER_OPERAND), intent(in), target   :: x
    integer, intent(in)                         :: y
    type(INTEGER_RELATION), pointer             :: equal

    type(INTEGER_OPERAND), pointer  :: yy

    allocate( equal )
    allocate( yy    )

    yy = y

    equal%relation =  1
    equal%first    => x
    equal%second   => yy
end function integer_equal_v

recursive subroutine integer_eval( x )
    type(INTEGER_OPERAND)   :: x

    if ( associated( x%first  ) ) call integer_eval( x%first  )
    if ( associated( x%second ) ) call integer_eval( x%second )

    select case( x%operation )
    case ( 0 )
        ! Nothing to be done
    case ( 1 )
        x%value = x%first%value + x%second%value
    case default
    end select

end subroutine integer_eval

function integer_relation_eval( relation ) result(value)
    type(INTEGER_RELATION)  :: relation
    logical                 :: value

    call integer_eval( relation%first  )
    call integer_eval( relation%second )

    select case( relation%relation )
    case ( 1 )
        value = relation%first%value == relation%second%value
    case default
        ! TODO
    end select

end function integer_relation_eval

end module integer_sets

program test_sets
    use integer_sets

    type(INTEGER_RELATION), pointer :: relation

    relation => x + y == 0
!   relation => integer_equal_v( integer_add(x,y), 0 )

    x = 1
    y = -1
    write(*,*) 'x, y: 1, -1 ', integer_relation_eval( relation )

    x = 2
    y = -1
    write(*,*) 'x, y: 2, -1 ', integer_relation_eval( relation )

end program


module z_algorithm_mod
    use,intrinsic :: iso_fortran_env
    implicit none

contains
    function zalgo(str) result(ret)
        ! input => str
        ! output => ret  O(N)
        ! ex) str => a  a b a a b a a b a a b
        !     ret => 12 1 0 9 1 0 6 1 0 3 1 0
        ! ret(i) => 文字列の先頭からと、i文字目からで、何文字分共通か。
        character(*):: str
        integer(int32):: n,i,same, from, last
        integer(int32), allocatable:: ret(:)

        n = len_trim(str)
        allocate(ret(n),source=0)
        from=0; last=0
        ret(1) = n
        do i=2,n
            same = ret(i)
            if (from /= 0) then
                same = min(ret(i-from+1), last-i)
                same = max(same,0)
                ret(i) = same
            end if
            do while(str(same+1:same+1) == str(same+i:same+i))
                same=same+1
                if (same+i > n) exit
            end do
            ret(i) = same
            if (last < i+same) then
                last = i+same-1
                from = i
            end if
        end do
    end function
end module


#include "scalar.fpp"

!=====================================================================!
! SPRING MASS DAMPER physics. This is a simple example of setting up a
! physical system for analysis within the framework.
!
! Author: Komahan Boopathy (komahan@gatech.edu)
!=====================================================================!

module spring_dynamics_class

  use constants                 , only : WP
  use dynamic_physics_interface , only : dynamics

  implicit none

  private

  public :: smd

  !-------------------------------------------------------------------!
  ! Type that implements spring mass damper ODE
  !-------------------------------------------------------------------!

  type, extends(dynamics) :: smd

     ! Define constants and other parameters needed for residual and
     ! jacobian assembly here

     type(scalar) :: M
     type(scalar) :: C
     type(scalar) :: K

   contains

     ! Implement deferred procedures from superclasses
     procedure :: add_residual
     procedure :: add_jacobian
     procedure :: get_initial_condition

     ! Destructor
     final :: destruct

  end type smd

  ! Interface to construct SMD system
  interface smd
     procedure construct
  end interface smd

contains

  !===================================================================!
  ! Constructor for smd system
  !===================================================================!

  pure type(smd) function construct(M, C, K) &
       & result (this)

    type(scalar), intent(in) :: M, C, K

    call this % set_description('S M D')

    ! Set the number of state variables of SMD system
    call this % set_num_state_vars(1)

    ! Set time order of SMD system
    call this % set_differential_order(2)

    ! Set the system parameters
    this % M = M
    this % C = C
    this % K = K

  end function construct

  !===================================================================!
  ! Destructor for smd system
  !===================================================================!

  pure subroutine destruct(this)

    type(smd), intent(inout) :: this

  end subroutine destruct

  !===================================================================!
  ! Residual assembly at each time step. This is a mandary function
  ! that the user needs to implement to use the integration
  ! scheme. This is where the differential equations are supplied to
  ! the solver.
  !===================================================================!

  pure subroutine add_residual(this, residual, U, X)

    class(smd)   , intent(inout) :: this
    type(scalar) , intent(inout) :: residual(:)
    type(scalar) , intent(in)    :: U(:,:)
    type(scalar) , intent(in)    :: X(:,:)

    associate( q => U(1,:), qdot => U(2,:), qddot => U(3,:), &
         & M => this % M, C => this % C, K => this % K)

      residual = residual + M*qddot + C*qdot + K*q

    end associate

  end subroutine add_residual

  !===================================================================!
  ! Jacobian assembly at each time step.
  !
  ! Jacobian is the matrix of partial derivatives. Each row in the
  ! Jacobian matrix arises from differentiating a single
  ! equation. Each column in the Jacobian comes from a variable in the
  ! problem. Note the NEQN should be equal to NVARS for the system to
  ! be solved.
  !
  ! Note: alpha, beta and gamma are scalars that need to be multiplied
  ! with the partial derivatives DRDQ, DRDudot and DRDuddot
  ! respectively.
  !===================================================================!

  pure subroutine add_jacobian(this, jacobian, coeff, U, X)

    class(smd)   , intent(inout) :: this
    type(scalar) , intent(inout) :: jacobian(:,:)
    type(scalar) , intent(in)    :: coeff(:)
    type(scalar) , intent(in)    :: U(:,:)
    type(scalar) , intent(in)    :: X(:,:)

    associate(&
         & q=>U(1,:), qdot=> U(2,:), qddot=> U(3,:), &
         & M=>this%M, C=>this%C, K=>this%K, &
         & alpha=>coeff(1), beta=>coeff(2), gamma=>coeff(3)&
         & )

      jacobian = jacobian + alpha*K + beta*C + gamma*M

    end associate

  end subroutine add_jacobian

  !===================================================================!
  ! Sets the initial condition for use in the integator. If first order
  ! system just set initial Q, if a second order system set initial Q
  ! and qdot
  !===================================================================!

  pure subroutine get_initial_condition(this, U, X)

    class(smd)   , intent(in)    :: this
    type(scalar) , intent(inout) :: U(:,:)
    type(scalar) , intent(in)    :: X(:,:)

    U(1,:) = -0.5_WP
    U(2,:) = 1.0_WP

  end subroutine get_initial_condition

end module spring_dynamics_class


program facbench
  use fmzm
  implicit none

  integer :: i
  type(im) :: res
  character(10000) :: out

  res = 0
  do i = 1, 3000
     res = res + fac(i)
  end do

  call im_form('i10000', res, out)
  print '(a)', trim(adjustl(out))

contains

  type(im) function fac(n)
    integer, intent(in) :: n
    integer :: i

    fac = 1
    do i = 1, n
       fac = fac * i
    end do
  end function fac

end program facbench


Module interpolation
        implicit none

        contains

            subroutine doVertInter(outdat,dat,bathymetry,zr,zs,Nroms,Nsoda,II,JJ,xi_rho,eta_rho)

            ! ----------------------------------
            ! Program : doVertInter
            !
            ! This routine interpolates from z-levels to sigma levels using linear interpolation.
            !
            ! The index values in python goes from 0 toN while in Fortran they run from 1 to N+1. This is important to
            ! remember if one wants to compare input index wtih output index in fortran and python.
            !
            ! This routine assumes that the two depth matrixes zr (ROMS) and zs (SODA) are arranged from shallowest
            ! (index=1) to deepest (index=N+1). The depth matrizes must also be negative (if positive, reverse all
            ! comparison signs (e.g. LT, GT) in the program or multiply with minus 1). The input data are arranged with
            ! deepest values at highest index (N+1 e.g. dat(N+1)==bottom, dat(1)==surface). This is done so because
            ! it is the way SODA data are organized (bottom at highest index). However, ROMS output files are organized vice versa, so
            ! to accomodate that the output values are stored according to the ROMS structure. Highest index (N+1) equals surface,
            ! while lowest index equals bottom (index=1)(see how outdat(kc,jc,ic) is used opposite of the loop over kc).
            !
            ! Trond Kristiansen, December 2008, January, and March 2009
            ! Rutgers University, NJ.
            ! -------------------------------------------------------------------------------------------------------
            !
            ! USAGE: Compile this routine using Intel Fortran compiler and create
            ! a python module using the command:
            !
            ! or
            ! f2py-64 --verbose -DF2PY_REPORT_ON_ARRAY_COPY=1 --fcompiler=intelem -c -m interpolation interpolation.f90
            ! or
            ! f2py --verbose --fcompiler=intelem -c -m interpolation interpolation.f90
            !
            ! The resulting module is imported to python using:
            ! import vertInterp as interp2D
            ! To call the function from python use:
            ! interp2D.doHorInterpolation(dat,bathymetry,outdat,zr,zs,Nroms,Nsoda,II,JJ)
            !
            ! where: dat is the data such as temperature (3D structure (z,y,x))
            !        bathymetry is the 2D bottom matrix from the output grid (in ROMS this is usually 'h')
            !        outdat is a 3D output array with the correct size (Nroms,JJ,II)
            !        zr is the depth matrix for the output grid (Nroms,JJ,II)
            !        zs is the 1D SODA depth-matrix (e.g. zs=[5,10,20,30])
            !        Nroms is the total depth levels in output grid
            !        JJ is the total grid points in eta direction
            !        II is the total grid points in xi direction
            ! -------------------------------------------------------------------------------------------------------

            REAL(4) rz2, rz1, fill
            integer eta_rho, xi_rho, II, JJ, ic, jc, kc, kT, kkT, Nsoda, Nroms
            REAL(4), dimension(Nsoda,JJ,II) :: dat
            REAL(4), dimension(eta_rho,xi_rho) :: bathymetry
            REAL(4), dimension(Nroms,JJ,II) :: outdat
            REAL(4), dimension(Nsoda) ::  zs
            REAL(4), dimension(Nroms,eta_rho,xi_rho) :: zr

!f2py intent(in,out,overwrite) outdat
!f2py intent(in,overwrite) dat, bathymetry, zr, zs
!f2py intent(in,overwrite) Nroms, Nsoda, JJ, II, xi_rho, eta_rho
!f2py intent(hide) ic,jc,kc,kT,rz1,rz2, kkT
            fill=-10000

            do jc=1,JJ
              do ic=1,II
                  do kc=1,Nroms
                      ! CASE 1: ROMS deeper than SODA. This part searches for deepest good value if ROMS depth is deeper
                      ! than SODA. This means that if no value, or only fill_value, is available from SODA where ROMS is
                      ! deepest, the closest value from SODA is found by looping upward in the water column.
                      IF (zr(kc,jc,ic) .LT. zs(Nsoda)) THEN
                          outdat(kc,jc,ic)=dat(Nsoda,jc,ic)
                          if (MAXVAL(dat(:,jc,ic)) .GT. fill) then
                            if (dat(Nsoda,jc,ic) .LT. fill) then
                              !print*,'Inside dovert and finding deepest depth with good values. current',dat(Nsoda,jc,ic)
                              DO kT=1,Nsoda
                                if (dat(Nsoda-kT,jc,ic) .GT. fill) then
                                    print*,'working on depth',kT,'with value',dat(kT,jc,ic)
                                    outdat(kc,jc,ic)=dat(Nsoda-kT,jc,ic)
                                    print*,'Able to find good value at depth ', Nsoda-kT
                                    exit
                                end if
                              end do
                             end if
                            end if
                          !print*,zr(kc,jc,ic),zs(Nsoda),dat(Nsoda,jc,ic),jc,ic,'case 1'

                      ! CASE 2: ROMS shallower than SODA
                      ELSE IF (zr(kc,jc,ic) .GT. zs(1)) THEN
                          outdat(kc,jc,ic)=dat(1,jc,ic)

                      ELSE
                          ! DO LOOP BETWEEN SURFACE AND BOTTOM
                          DO kT=1,Nsoda
                              ! CASE 3: ROMS deeper than SODA for one layer, but shallower than next SODA layer (bottom in between)
                              ! Deeper than some SODA depth layer, but shallower than next layer which is below bottom
                              IF (zr(kc,jc,ic) .LE. zs(kT) .AND.               &
                                -(bathymetry(jc,ic)) .GT. zs(kT+1)) THEN
                                outdat(kc,jc,ic)=dat(kT,jc,ic)

                                ! We do not want to give the deepest depth a fill_value, so we find
                                ! the closest value to deepest depth.
                                if (MAXVAL(dat(:,jc,ic)) .GT. fill) then

                                    if (dat(kT,jc,ic) .LE. fill) then
                                       !print*,'case3:Need to find better value for depth ',kT,'which has value ',dat(kT,jc,ic)
                                        DO kkT=1,Nsoda
                                            if (dat(kT-kkT,jc,ic) .GT. fill) then
                                                 outdat(kc,jc,ic)=dat(kT-kkT,jc,ic)

                                                exit
                                            end if
                                        end do
                                    end if
                                end if

                                ! CASE 4: Special case where ROMS layers are much deeper than in SODA
                                ELSE IF (zr(kc,jc,ic) .LE. zs(kT) .AND. dat(kT,jc,ic) .GT. fill &
                                .AND. dat(kT+1,jc,ic) .LE. fill) THEN
                                outdat(kc,jc,ic)=dat(kT,jc,ic)

                              ! CASE 5: ROMS layer in between two SODA layers
                              ! This is the typical case for most layers
                              ELSE IF ( (zr(kc,jc,ic) .LE. zs(kT)) .AND.       &
                              (zr(kc,jc,ic) .GE. zs(kT+1)) .AND.               &
                              (-bathymetry(jc,ic) .LE. zs(kT+1)) ) THEN

                                 rz2 = abs((zr(kc,jc,ic)-zs(kT+1))/            &
                                 (abs(zs(kT+1))-abs(zs(kT))))

                                 rz1 = 1.0-rz2

                                 outdat(kc,jc,ic) = (rz1*dat(kT+1,jc,ic) &
                                 + rz2*dat(kT,jc,ic))

                                if (MAXVAL(dat(:,jc,ic)) .GT. fill) then

                                    if (dat(kT,jc,ic) .LE. fill .OR. dat(kT+1,jc,ic) .LE. fill) then
                                       !print*,'case4:Need to find better value for depth ',kT,kT+1,'which has &
                                   !    values ',dat(kT,jc,ic),dat(kT+1,jc,ic)
                                        DO kkT=1,Nsoda
                                            if (dat(kT-kkT,jc,ic) .GT. fill .and. dat(kT-kkT+1,jc,ic) .GT. fill  ) then
                                                 !print*,'CASE 4: Found good value at depth',kT-kkT,kt-kkT+1
                                                 !print*,'with values',dat(kT-kkT,jc,ic), dat(kt-kkT+1,jc,ic)
                                                 outdat(kc,jc,ic) = (rz1*dat(kT+1-kkT,jc,ic) &
                                                 + rz2*dat(kT-kkT,jc,ic))

                                                exit
                                            end if
                                        END DO
                                    end if
                                 end if

                                 exit

                              END IF
                          ! DO LOOP BETWEEN SURFACE AND BOTTOM: CASE 3,4,5
                          END DO
                      ! TEST ALL CASES IF LOOP: CASE 1,2,3,4,5
                      END IF

                  end do
              end do
            end do

      end subroutine doVertInter

      subroutine rho2u(udata,rhodata,II,JJ,KK)

            ! ----------------------------------
            ! Program : rho2u
            !
            ! This routine interpolates RHO points to U points using simple linear interpolation
            ! The input matrix (rhodata) is a matrix of size (JJ,II). The output matrix is the
            ! interpolated RHO values at U points with dimensions (JJ,II-1).
            ! Trond Kristiansen, January 2009
            ! Rutgers University, NJ.
            ! -------------------------------------------------------------------------------------------------------

            integer KK, II, JJ, kc, ic, jc, fill
            REAL(4), dimension(KK,JJ,II) :: rhodata
            REAL(4), dimension(KK,JJ,II-1) :: udata

!f2py intent(in,out,overwrite) udata
!f2py intent(in,overwrite) rhodata, KK, JJ, II
!f2py intent(hide) ic,jc,kc, fill

            fill=10000
            print*,'---> Started horisontal rho2u interpolation'
            do kc=1,KK
                do jc=1,JJ
                    do ic=2,II-1

                        udata(kc,jc,1)=rhodata(kc,jc,1)
                        ! Now make sure that if we have two stations where one has values
                        ! and the other not, we only use the good value
                        ! case 1: one value is good (jc+1) other bad (jc-1)
                        if (abs(rhodata(kc,jc,ic-1)) > fill .AND. abs(rhodata(kc,jc,ic+1)) < fill) then
                            udata(kc,jc,ic)=(rhodata(kc,jc,ic+1))
                        ! case 2: one value is good (jc-1) other bad (jc+1)
                        else if (abs(rhodata(kc,jc,ic-1)) < fill .AND. abs(rhodata(kc,jc,ic+1)) > fill) then
                            udata(kc,jc,ic)=(rhodata(kc,jc,ic-1))
                        ! Both values are bad:
                        else if (abs(rhodata(kc,jc,ic-1)) > fill .AND. abs(rhodata(kc,jc,ic+1)) > fill) then
                            udata(kc,jc,ic)=0.0
                        ! Both values are good and we do linear interpolation
                        else
                            udata(kc,jc,ic)=(rhodata(kc,jc,ic-1)+rhodata(kc,jc,ic+1))*0.5
                        end if
                    end do
                end do
            end do
            print*,'-----> Ended horisontal rho2u interpolation'
        end subroutine rho2u

      subroutine rho2v(vdata,rhodata,II,JJ,KK)

            ! ----------------------------------
            ! Program : rho2v
            !
            ! This routine interpolates RHO points to V points using simple linear interpolation
            ! The input matrix (rhodata) is a matrix of size (JJ,II). The output matrix is the
            ! interpolated RHO values at U points with dimensions (JJ-1,II).
            ! Trond Kristiansen, January, February, and March2009
            ! Rutgers University, NJ.
            ! -------------------------------------------------------------------------------------------------------

           integer KK, II, JJ, kc, ic, jc, fill
           REAL(4), dimension(KK,JJ,II) :: rhodata
           REAL(4), dimension(KK,JJ-1,II) :: vdata

!f2py intent(in,out,overwrite) vdata
!f2py intent(in,overwrite) rhodata, KK, JJ, II
!f2py intent(hide) ic,jc,kc, fill

            fill=10000
            print*,'---> Started horisontal rho2v interpolation'
            do kc=1,KK
                do jc=2,JJ-1
                    do ic=1,II

                        vdata(kc,1,ic)=rhodata(kc,1,ic)

                        if (abs(rhodata(kc,jc-1,ic)) > fill .AND. abs(rhodata(kc,jc+1,ic)) < fill) then
                            vdata(kc,jc,ic)=(rhodata(kc,jc+1,ic))
                        else if (abs(rhodata(kc,jc-1,ic)) < fill .AND. abs(rhodata(kc,jc+1,ic)) > fill) then
                            vdata(kc,jc,ic)=(rhodata(kc,jc-1,ic))
                        else if (abs(rhodata(kc,jc-1,ic)) > fill .AND. abs(rhodata(kc,jc+1,ic)) > fill) then
                            vdata(kc,jc,ic)=0.0
                        else
                            vdata(kc,jc,ic)=(rhodata(kc,jc-1,ic)+rhodata(kc,jc+1,ic))*0.5
                        end if
                    end do
                end do
            end do
            print*,'-----> Ended horisontal rho2v interpolation'
        end subroutine rho2v

        subroutine rotate(urot,vrot,u_rho,v_rho,angle,II,JJ,KK)
            ! ----------------------------------
            ! Program : rotate
            !
            ! This routine rotates u and v velocities in the North-South grid to an
            ! the output North-South grid with angle "angle"
            ! Trond Kristiansen, January 2009
            ! Rutgers University, NJ.
            ! -------------------------------------------------------------------------------------------------------

           REAL(4), dimension(KK,JJ,II) :: urot, vrot
           REAL(4), dimension(KK,JJ,II) :: u_rho, v_rho
           REAL(4), dimension(JJ,II)  :: angle
           integer KK, II, JJ, kc, ic, jc

!f2py intent(in,out,overwrite) urot, vrot
!f2py intent(in,overwrite)  u_rho, v_rho, angle, KK, JJ, II
!f2py intent(hide) ic,jc,kc

           print*,'---> Started rotation of velocities'
           do kc=1,KK
             do jc=1,JJ
                do ic=1,II

                    ! https://www.myroms.org/forum/viewtopic.php?f=3&t=295

                    urot(kc,jc,ic)=u_rho(kc,jc,ic)*COS(angle(jc,ic)) + v_rho(kc,jc,ic)*SIN(angle(jc,ic))
                    vrot(kc,jc,ic)=u_rho(kc,jc,ic)*SIN(angle(jc,ic)) - v_rho(kc,jc,ic)*COS(angle(jc,ic))

                    !print*, vrot(kc,jc,ic), urot(kc,jc,ic), kc,jc,ic !, sin(angle(jc,ic)), cos(angle(jc,ic))
                    !print*, v_rho(kc,jc,ic), u_rho(kc,jc,ic), ic,jc
                end do
             end do
            end do
            print*,'-----> Ended rotation of velocities'
        end subroutine rotate

     end module interpolation


C SUBROUTINE GRADLS.F
C
C SOURCE
C   BEVINGTON, PAGES 220-222.
C
C PURPOSE
C   MAKE A GRADIENT-SEARCH LEAST-SQUARES FIT TO DATA WITH A
C      SPECIFIED FUNCTION WHICH IS NOT LINEAR IN COEFFICIENTS
C
C USAGE
C   CALL GRADLS (X, Y, SIGMAY, NPTS, NTERMS, MODE, A, DELTAA,
C      YFIT, CHISQR)
C
C DESCRIPTION OF PARAMETERS
C   X	   - ARRAY OF DATA POINTS FOR INDEPENDENT VARIABLE
C   Y	   - ARRAY OF DATA POINTS FOR DEPENDENT VARIABLE
C   SIGMAY - ARRAY OF STANDARD DEVIATIONS FOR Y DATA POINTS
C   NPTS   - NUMBER OF PAIRS OF DATA POINTS
C   NTERMS - NUMBER OF PARAMETERS
C   MODE   - DETERMINES METHOD OF WEIGHTING LEAST-SQUARES FIT
C	     +1 (INSTRUMENTAL) WEIGHT(I) = 1./SIGMAY(I)**2
C	      0 (NO WEIGHTING) WEIGHT(I) = 1.
C	     -1 (STATISTICAL)  WEIGHT(I) = 1./Y(I)
C   A	   - ARRAY OF PARAMETERS
C   DELTAA - ARRAY OF INCREMENTS FOR PARAMETERS A
C   YFIT   - ARRAY OF CALCULATED VALUES OF Y
C   CHISQR - REDUCED CHI SQUARE FOR FIT
C
C SUBROUTINES AND FUNCTION SUBPROGRAMS REQUIRED
C   FUNCTN (X, I, A)
C      EVALUATES THE FITTING FUNCTION FOR THE ITH TERM
C   FCHISQ (Y, SIGMAY, NPTS, NFREE, MODE, YFIT)
C      EVALUATES REDUCED CHI SQUARED FOR FIT TO DATA
C
C COMMENTS
C   DIMENSION STATEMENT VALID FOR NTERMS UP TO 10
C
      SUBROUTINE GRADLS (X,Y,SIGMAY,NPTS,NTERMS,MODE,A,DELTAA,
     *YFIT,CHISQR)
      DIMENSION X(1),Y(1),SIGMAY(1),A(1),DELTAA(1),YFIT(1)
      DIMENSION GRAD(10)
      REAL FUNCTN
      EXTERNAL FUNCTN

C
C EVALUATE CHI SQUARE AT BEGINNING
C
11    NFREE=NPTS-NTERMS
      IF (NFREE) 13,13,21
13    CHISQR=0.
      GOTO 110
21    DO 22 I=1,NPTS
22    YFIT(I)=FUNCTN (X,I,A)
      CHISQ1=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT)
C
C EVALUATE GRADIENT OF CHI SQUARE
C
31    SUM=0.
32    DO 39 J=1,NTERMS
      DELTA=0.1*DELTAA(J)
      A(J)=A(J)+DELTA
      DO 36 I=1,NPTS
36    YFIT(I)=FUNCTN (X,I,A)
      A(J)=A(J)-DELTA
      GRAD(J)=CHISQ1-FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT)
39    SUM=SUM+GRAD(J)**2
41    DO 42 J=1,NTERMS
42    GRAD(J)=DELTAA(J)*GRAD(J)/SQRT(SUM)
C
C EVALUATE CHI SQUARE AT NEW POINT
C
51    DO 52 J=1,NTERMS
52    A(J)=A(J)+GRAD(J)
53    DO 54 I=1,NPTS
54    YFIT(I)=FUNCTN (X,I,A)
      CHISQ2=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT)
C
C MAKE SURE CHI SQUARE DECREASES
C
61    IF (CHISQ1-CHISQ2) 62,62,71
62    DO 64 J=1,NTERMS
      A(J)=A(J)-GRAD(J)
64    GRAD(J)=GRAD(J)/2.
      GOTO 51
C
C INCREMENT PARAMETERS UNTIL CHI SQUARE STARTS TO INCREASE
C
71    DO 72 J=1,NTERMS
72    A(J)=A(J)+GRAD(J)
      DO 74 I=1,NPTS
74    YFIT(I)=FUNCTN (X,I,A)
75    CHISQ3=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT)
76    IF (CHISQ3-CHISQ2) 81,91,91
81    CHISQ1=CHISQ2
82    CHISQ2=CHISQ3
      GOTO 71
C
C FIND MINIMUM OF PARABOLA DEFINED BY LAST THREE POINTS
C
91    DELTA=1./(1.+(CHISQ1-CHISQ2)/(CHISQ3-CHISQ2))+0.5
      DO 93 J=1,NTERMS
93    A(J)=A(J)-DELTA*GRAD(J)
      DO 95 I=1,NPTS
95    YFIT(I)=FUNCTN (X,I,A)
      CHISQR=FCHISQ (Y,SIGMAY,NPTS,NFREE,MODE,YFIT)
101   IF (CHISQ2-CHISQR) 102,110,110
102   DO 103 J=1,NTERMS
103   A(J)=A(J)+(DELTA-1.)*GRAD(J)
104   DO 105 I=1,NPTS
105   YFIT(I)=FUNCTN (X,I,A)
106   CHISQR=CHISQ2
110   RETURN
      END


! libRQZ
! author: daan.camps@cs.kuleuven.be
! Description:
!   Implements the routines for selecting the shifts and poles during
!   the iteration.
! ___________________________________________________________________
module z_computepoles
 use u_parameters

 implicit none
 private
 public z_get_shift, z_get_pole

contains

 subroutine z_get_shift(A, B, idx, alpha, beta)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Computes the eigenvalues of the trailing two by two block
  ! and returns the one closest to the last diagonal element
  ! based on the input.
  ! The user can overwrite this function to use a different shift
  ! selection procedure.
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! A       complex double array [IN]
  !           Upper Hessenberg matrix A
  ! B       complex double array [IN]
  !           Upper Hessenberg matrix B
  ! idx     integer [IN]
  !           Index indicating the two-by-two block,
  !             idx-1:idx,idx-1:idx
  ! alpha   complex double [OUT]
  !           Defines the eigenvalue of the
  !           block closest to element idx,idx
  ! beta    complex double [OUT]
  !           Defines the eigenvalue of the
  !           block closest to element idx,idx
  !___________________________________________________________________________
  ! last edit: June 7, 2018
  complex(kind=dp),intent(in) :: A(:,:), B(:,:)
  integer, intent(in) :: idx
  complex(kind=dp),intent(out) :: alpha, beta

  call z_get_eigenvalues2x2(A(idx-1:idx,idx-1:idx),B(idx-1:idx,idx-1:idx),&
                            alpha,beta)

  if (abs(B(idx,idx)*alpha-A(idx,idx)) .lt. &
      abs(B(idx,idx)*beta-A(idx,idx))) then
   beta = cone
  else
   alpha = beta
   beta = cone
  endif

 end subroutine

 subroutine z_get_pole(A, B, idx, alpha, beta)
  ! DESCRIPTION
  !___________________________________________________________________________
  ! Computes the eigenvalues of the leading two by two block
  ! and returns the one closest to the first diagonal element
  ! based on the input.
  ! The user can overwrite this function to use a different shift
  ! selection procedure.
  !
  ! ARGUMENTS
  !___________________________________________________________________________
  ! A       complex double array [IN]
  !           Upper Hessenberg matrix A
  ! B       complex double array [IN]
  !           Upper Hessenberg matrix B
  ! idx     integer [IN]
  !           Index indicating the two-by-two block,
  !             idx:idx+1,idx:idx+1
  ! alpha   complex double [OUT]
  !           Defines the eigenvalue of the
  !           block closest to element idx,idx
  ! beta    complex double [OUT]
  !           Defines the eigenvalue of the
  !           block closest to element idx,idx
  !___________________________________________________________________________
  ! last edit: June 7, 2018
  complex(kind=dp),intent(in) :: A(:,:), B(:,:)
  integer, intent(in) :: idx
  complex(kind=dp),intent(out) :: alpha, beta

  call z_get_eigenvalues2x2(A(idx:idx+1,idx:idx+1),B(idx:idx+1,idx:idx+1),&
                            alpha,beta)

  if (abs(B(idx,idx)*alpha-A(idx,idx)) .lt. &
      abs(B(idx,idx)*beta-A(idx,idx))) then
   beta = cone
  else
   alpha = beta
   beta = cone
  endif
 end subroutine

 subroutine z_get_eigenvalues2x2(A,B,l1,l2)
 ! DESCRIPTION
 !___________________________________________________________________________
 ! Computes the eigenvalues of a 2-by-2 block
 !
 ! ARGUMENTS
 !___________________________________________________________________________
 ! A       complex double array [IN]
 !           2 x 2 complex array
 ! B       complex double array [IN]
 !           2 x 2 complex array
 ! l1      complex double [OUT]
 !          eigenvalue of (A,B)
 ! l2      complex double [OUT]
 !          eigenvalue of (A,B)
 !
 !___________________________________________________________________________
 ! last edit: June 7, 2018
  complex(kind=dp),intent(in) :: A(:,:), B(:,:)
  complex(kind=dp),intent(out) :: l1, l2

  complex(kind=dp) :: DET, AB11, AB12, AB21, AB22, T1, RTDISC

  DET = B(1,1)*B(2,2) - B(1,2)* B(2,1)

  if (abs(DET) .gt. mp) then
   AB11 = A(1,1)*B(2,2)-A(2,1)*B(1,2)
   AB12 = A(1,2)*B(2,2)-A(2,2)*B(1,2)
   AB21 = A(2,1)*B(1,1)-A(1,1)*B(2,1)
   AB22 = A(2,2)*B(1,1)-A(1,2)*B(2,1)

   T1 =  (1.0_dp/2.0_dp)*(AB11+AB22)
   RTDISC = sqrt(T1**2 + AB12*AB21-AB11*AB22)

   l1 = (T1 + RTDISC)/DET
   l2 = (T1 - RTDISC)/DET
  else
    write(*,*) 'SINGULAR B - TODO'
    write(*,*) A,B
    stop
  end if
 end subroutine
end module


SUBROUTINE LUDCMP(A,N,NP,INDX,D)
  USE Precision
  IMPLICIT NONE
  REAL(kind=long), PARAMETER :: TINY=1.0E-20
  INTEGER i, j, k, imax, n, np, indx(n)
  REAL(kind=long) ::  A(NP,NP), VV(N), AAMAX, SUM, D, DUM, one=1._long, &
       zero=0._long
  D=one
  DO  I=1,N
     AAMAX=zero
     DO  J=1,N
        IF (ABS(A(I,J)).GT.AAMAX) AAMAX=ABS(A(I,J))
     END DO
     IF (AAMAX.EQ.0.) then
	 write(*,'(A)') 'Singular matrix.'
	read*
! pause
     ENDIF
     VV(I)=1./AAMAX
  END DO
  DO  J=1,N
     DO  I=1,J-1
        SUM=A(I,J)
        DO  K=1,I-1
           SUM=SUM-A(I,K)*A(K,J)
        END DO
        A(I,J)=SUM
     END DO
     AAMAX=zero
     DO  I=J,N
        SUM=A(I,J)
        DO  K=1,J-1
           SUM=SUM-A(I,K)*A(K,J)
        END DO
        A(I,J)=SUM
        DUM=VV(I)*ABS(SUM)
        IF (DUM.GE.AAMAX) THEN
           IMAX=I
           AAMAX=DUM
        ENDIF
     END DO
     IF (J.NE.IMAX)THEN
        DO  K=1,N
           DUM=A(IMAX,K)
           A(IMAX,K)=A(J,K)
           A(J,K)=DUM
        END DO
        D=-D
        VV(IMAX)=VV(J)
     ENDIF
     INDX(J)=IMAX
     IF(A(J,J).EQ.0.)A(J,J)=TINY
     IF(J.NE.N)THEN
        DUM=1./A(J,J)
        DO  I=J+1,N
           A(I,J)=A(I,J)*DUM
        END DO
     ENDIF
  END DO
  RETURN
END SUBROUTINE LUDCMP


! { dg-do compile }
! { dg-options "-Wconversion -Wconversion-extra" }
! PR 47659 - warning about conversions on assignment
! Based on a test case by Thomas Henlich
program main
  double precision d1, d2
  complex(8), parameter :: z = cmplx (0.5, 0.5)  ! { dg-warning "Conversion" }
  real :: r1, r2
  r1 = 2.3d0 ! { dg-warning "Change of value in conversion" }
  r2 = 2.5d0 ! { dg-warning "Conversion" }
  d1 = .13 ! { dg-warning "Conversion" }
  d2 = .13d0
  d1 = z     ! { dg-warning "Non-zero imaginary part" }
end program main


c
c     version 1.3  Aug 1992
c
c     General plot routines
c
c     ----------------------------------------------------------------
c
      subroutine axis(xorig,yorig,amin,amax,amm,ascale,theta,iside,
     +                amint,amaxt,ntick,ndeci,label,nchar,albht)
c
c     plot axis
c
c     xorig, yorig - (x,y) origin of axis
c     amin, amax   - min and max value of axis
c     amm          - length of axis (mm)
c     ascale       - plot scale in axis-units/plot-units
c     theta        - angle of axis in degrees (i.e. 0 or 90)
c     iside        - side of axis that is labelled
c                    (+1 for left or bottom, -1 for right or top)
c     amint, amaxt - min and max value of tick marks
c     ntick        - number of intervals separated by tick marks
c                    (i.e. the number of tick marks equals ntick+1)
c     ndeci        - number of digits after decimal for axis numbers
c     label        - axis label
c     nchar        - number of characters in axis label
c     albht        - height of axis label
c
c     Note: amax must be greater than amin always
c
      real xtick(101),ytick(101)
      character label(nchar)
c
      whrat=0.75
      ticfac=1.
      ticlen=ticfac*abs(albht)
c
c     plot axis line
c
      call plot(xorig,yorig,3)
      if(theta.eq.0.) then
        call plot(xorig+amm,yorig,2)
        iplt=1
      else
        call plot(xorig,yorig+amm,2)
        iplt=2
      end if
c
      if(ascale.gt.0.) then
        aadj=amin
        aadjt=amint
      else
        aadj=amax
        aadjt=amaxt
      end if
c
c     plot tick marks
c
      ainc=(amaxt-amint)/(abs(ascale)*float(ntick))
      if(iplt.eq.1) then
        xot=(aadjt-aadj)/ascale+xorig
        do 10 i=1,ntick+1
           xtick(i)=xot+float(i-1)*ainc
           ypos=yorig
           call plot(xtick(i),ypos,3)
           ypos=yorig-float(iside)*ticlen
           call plot(xtick(i),ypos,2)
10      continue
      else
        yot=(aadjt-aadj)/ascale+yorig
        do 20 i=1,ntick+1
           ytick(i)=yot+float(i-1)*ainc
           xpos=xorig
           call plot(xpos,ytick(i),3)
           xpos=xorig-float(iside)*ticlen
           call plot(xpos,ytick(i),2)
20      continue
      end if
c
c     plot axis scale
c
      if(albht.lt.0.) return
      if(amaxt.ne.0.) then
        maxdig=int(alog10(abs(amaxt)))+ndeci+2
      else
        maxdig=1
      end if
      anlen=float(maxdig)*albht*whrat
      if(ascale.gt.0.) then
        ainc=(amaxt-amint)/float(ntick)
        a1=amint
      else
        ainc=(amint-amaxt)/float(ntick)
        a1=amaxt
      end if
      if(iplt.eq.1) then
        if(iside.eq.1) then
          shfctr=1.5
        else
          shfctr=.5
        end if
        ypos=ypos-float(iside)*albht*shfctr
        xadj=anlen/2.
        do 30 i=1,ntick+1
           value=a1+float(i-1)*ainc
           xpos=xtick(i)-xadj
           call number(xpos,ypos,albht,value,0.,ndeci)
30      continue
      else
        if(iside.eq.1) then
          shfctr=.5
        else
          shfctr=1.5
        end if
        xpos=xpos-float(iside)*albht*shfctr
        yadj=anlen/2.
        do 40 i=1,ntick+1
           value=a1+float(i-1)*ainc
           ypos=ytick(i)-yadj
           call number(xpos,ypos,albht,value,90.,ndeci)
40      continue
      end if
c
c     plot axis label
c
      alblen=float(nchar)*albht*whrat
      if(iplt.eq.1) then
        ypos=ypos-float(iside)*albht*1.5
        xpos=xorig+(amm-alblen)/2.
        call symbol(xpos,ypos,albht,label,0.,nchar)
      else
        xpos=xpos-float(iside)*albht*1.5
        ypos=yorig+(amm-alblen)/2.
        call symbol(xpos,ypos,albht,label,90.,nchar)
      end if
c
      return
      end
c
c     ----------------------------------------------------------------
c
      subroutine dashln(x,y,npts,dash)
c
c     connect the npts (x,y) points with dashed straight line segments
c     of length dash
c
      parameter (nmax=10000)
      real x(npts),y(npts),xp(nmax),yp(nmax)
c
      nplt=1
      xp(1)=x(1)
      yp(1)=y(1)
      rem=0.
      do 10 i=1,npts-1
         if(rem.gt.0.) then
           dx=x(i+1)-x(i)
           dy=y(i+1)-y(i)
           distxy=sqrt(dx**2+dy**2)
           if(distxy.lt..00001) go to 10
           fctr=rem/distxy
           if(fctr.le.1.) then
             nplt=nplt+1
             if(nplt.gt.nmax) go to 999
             xp(nplt)=x(i)+dx*fctr
             yp(nplt)=y(i)+dy*fctr
           else
             rem=rem-distxy
             go to 10
           end if
         end if
         dx=x(i+1)-xp(nplt)
         dy=y(i+1)-yp(nplt)
         distxy=sqrt(dx**2+dy**2)
         fctr=dash/distxy
         nptss=int(1./fctr+.00001)
         if(nptss.gt.0) then
           do 20 j=1,nptss
              nplt=nplt+1
              if(nplt.gt.nmax) go to 999
              xp(nplt)=xp(nplt-1)+dx*fctr
              yp(nplt)=yp(nplt-1)+dy*fctr
20         continue
         end if
         if(abs(1./fctr-float(nptss)).gt..00001) then
           rem=dash*(1.-1./fctr+float(nptss))
         else
           rem=0.
         end if
10    continue
c
      ipen=3
      do 30 i=1,nplt
         call plot(xp(i),yp(i),ipen)
         if(ipen.eq.3) then
           ipen=2
         else
           ipen=3
         end if
30    continue
      call plot(x(npts),y(npts),ipen)
      return
999   call line(x,y,npts)
c
      return
      end
c
c     ----------------------------------------------------------------
c
      subroutine box(x1,z1,x2,z2)
c
c     plot a box whose opposite corners are (x1,z1) and (x2,z2)
c
      call plot(x1,z1,3)
      call plot(x2,z1,2)
      call plot(x2,z2,2)
      call plot(x1,z2,2)
      call plot(x1,z1,2)
c
      return
      end
c
c     ----------------------------------------------------------------
c
      subroutine ssymbl(x,y,ht,isymbl)
c
c     plot special symbols centred at (x,y) of height ht
c
      ht2=ht/2.
c
      go to (100,200,300,400,500) isymbl
c
c     plot a "+"
c
100   call plot(x,y-ht2,3)
      call plot(x,y+ht2,2)
      call plot(x-ht2,y,3)
      call plot(x+ht2,y,2)
      return
c
c     plot a "x"
c
200   call plot(x-ht2,y-ht2,3)
      call plot(x+ht2,y+ht2,2)
      call plot(x-ht2,y+ht2,3)
      call plot(x+ht2,y-ht2,2)
      return
c
c     plot a "*"
c
300   call plot(x,y-ht2,3)
      call plot(x,y+ht2,2)
      call plot(x-ht2,y,3)
      call plot(x+ht2,y,2)
      call plot(x-ht2,y-ht2,3)
      call plot(x+ht2,y+ht2,2)
      call plot(x-ht2,y+ht2,3)
      call plot(x+ht2,y-ht2,2)
      return
c
c     plot a square
c
400   call plot(x-ht2,y-ht2,3)
      call plot(x+ht2,y-ht2,2)
      call plot(x+ht2,y+ht2,2)
      call plot(x-ht2,y+ht2,2)
      call plot(x-ht2,y-ht2,2)
      return
c
c     plot a diamond
c
500   call plot(x,y-ht2,3)
      call plot(x+ht2,y,2)
      call plot(x,y+ht2,2)
      call plot(x-ht2,y,2)
      call plot(x,y-ht2,2)
c
      return
      end
c
c     ----------------------------------------------------------------
c
      subroutine axtick(amin,amax,amint,amaxt,ntick,ndeci)
c
c     determine appropriate values for the minimum and maximum position
c     of tick marks, the number of tick marks, and the number of
c     digits after the decimal given the minimum and maximum axis
c     values
c
      parameter(ndiv=18)
      integer tcndec(ndiv)
      real tcmax(ndiv),tcinc(ndiv)
c
      data tcmax/.01,.02,.05,.1,.2,.5,1.,2.,5.,10.,20.,50.,
     +           100.,200.,500.,1000.,2000.,5000./,
     +     tcinc/.001,.002,.005,.01,.02,.05,.1,.2,.5,1.,2.,5.,
     +           10.,20.,50.,100.,200.,500./,
     +     tcndec/3,3,3,2,2,2,1,1,1,-1,-1,-1,-1,-1,-1,-1,-1,-1/
c
      alen=amax-amin
      do 10 i=1,ndiv
         if(alen.le.tcmax(i)) then
           ipos=i
           go to 20
         end if
10    continue
      ipos=ndiv
c
20    continue
      if(ndeci.lt.-1) ndeci=tcndec(ipos)
      if(amint.lt.-999998.) then
        amint=float(nint(amin/tcinc(ipos)))*tcinc(ipos)
        if(abs(amint-amin).lt..00001) amint=amin
        if(amint.lt.amin) amint=amint+tcinc(ipos)
      end if
      if(amaxt.lt.-999998.) then
        amaxt=float(nint(amax/tcinc(ipos)))*tcinc(ipos)
        if(abs(amaxt-amax).lt..00001) amaxt=amax
        if(amaxt.gt.amax) amaxt=amaxt-tcinc(ipos)
      end if
      if(ntick.le.0) ntick=nint((amaxt-amint)/tcinc(ipos))
      if(abs(amaxt-amint).lt..001) then
        amaxt=amax
        amint=amin
        ntick=1
        ndeci=0
      end if
c
      return
      end


************************************************************************
*
*
*     MATCAL includes the following subroutines
*
*     S   CALQ            Solving X from linear equation A*X=Y.
*     S   COPY            Copying of vector.
*     S   COPY2           Copying of two vectors.
*     S   CWMAXV          Multiplication of a columnwise stored dense
*                           rectangular matrix by a vector.
*     S   LINEQ           Solver for linear equation.
*     S   MXDPGF          Gill-Murray decomposition of a dense symmetric
*                           matrix. Coded by L. Luksan.
*     S   RWAXV2          Multiplication of two rowwise stored dense
*                           rectangular matrices A and B by vectors X
*                           and Y.
*     S   SCALEX          Scaling a vector.
*     S   SCDIFF          Difference of the scaled vector and a vector.
*     S   SCSUM           Sum of a vector and the scaled vector.
*     S   SYMAX           Multiplication of a dense symmetric matrix
*                           by a vector.
*     S   TRLIEQ          Solving X from linear equation L*X=Y or
*                           L'*X=Y.
*     S   VNEG            Change the signs of vector elements.
*     S   VXDIAG          Multiplication of a vector and a diagonal
*                           matrix.
*     S   XDIFFY          Difference of two vectors.
*     S   XSUMY           Sum of two vectors.
*     RF  EPS0            The smallest positive number such that
*                           1.0 + EPS0 > 1.0.
*     RF  VDOT            Dot product of two vectors.
*
*
************************************************************************
*
*     * SUBROUTINE SYMAX *
*
*
*     * Purpose *
*
*     Multiplication of a dense symmetric matrix A by a vector X.
*
*
*     * Calling sequence *
*
*     CALL SYMAX(N,M,IOLD,A,X,Y)
*
*
*     * Parameters *
*
*     II  N               Order of matrix A.
*     RI  A(N*(N+1)/2)    Dense symmetric matrix stored in the packed
*                           form.
*     II  M               Length of vector X, M >= N, note that only N
*                           components from vector X are used.
*     RI  X(M)            Input vector stored in a circular order.
*     II  IOLD            Index, which controlls the circular order of
*                           the vector X.
*     RO  Y(M)            Output vector equal to A*X. The vector Y has
*                           the same circular order than X.
*
*
*     Napsu Haarala (2002).
*

      SUBROUTINE SYMAX(N,M,IOLD,A,X,Y)

*     Scalar Arguments
      INTEGER N,M,IOLD

*     Array Arguments
      DOUBLE PRECISION A(*),X(*),Y(*)

*     Local Scalars
      INTEGER I,J,K,L

      DO 20 J=1,N
         L=J+IOLD-1
         IF (L .GT. M) L=L-M
         Y(L)=0.0D+00
         K=L
         DO 10 I=J,N
            Y(L) = A((I-1)*I/2+J)*X(K)+Y(L)
            K=K+1
            IF (K .GT. M) K=K-M
 10      CONTINUE
 20   CONTINUE

      DO 40 J=2,N
         L=J+IOLD-1
         IF (L .GT. M) L=L-M
         K=IOLD
         DO 30 I=1,J-1
            IF (K .GT. M) K=K-M
            Y(L) = A((J-1)*J/2+I)*X(K)+Y(L)
            K=K+1
 30      CONTINUE
 40   CONTINUE

      RETURN
      END

************************************************************************
*
*     * SUBROUTINE CWMAXV *
*
*
*     * Purpose *
*
*     Multiplication of a columnwise stored dense rectangular matrix A
*     by a vector X with a possibility of scaling.
*
*
*     * Calling sequence *
*
*     CALL CWMAXV(N,M,A,X,Y,S)
*
*
*     * Parameters *
*
*     II  N             Number of rows of the matrix A.
*     II  M             Number of columns of the matrix A.
*     RI  A(N*M)        Rectangular matrix stored columnwise in the
*                       one-dimensional array.
*     RI  X(M)          Input vector.
*     RI  S             Scaling parameter.
*     RO  Y(N)          Output vector equal to S*A*X. If M = 0 Y is
*                         a zero vector.
*
*
*     * Subprograms used *
*
*     S   SCSUM         Sum of a vector and the scaled vector.
*
*
*     * Napsu Haarala, 2006
*

      SUBROUTINE CWMAXV(N,M,A,X,Y,S)

*     Scalar Arguments
      INTEGER M,N
      DOUBLE PRECISION S

*     Array Arguments
      DOUBLE PRECISION A(*),X(*),Y(*)

*     Local Scalars
      INTEGER I,J,K

*     External Subroutines
      EXTERNAL SCSUM

      DO 10 I = 1,N
         Y(I) = 0.0D+00
 10   CONTINUE

      K = 0
      DO 20 J = 1,M
         CALL SCSUM(N,S*X(J),A(K+1),Y,Y)
         K = K + N
 20   CONTINUE

      RETURN
      END

************************************************************************
*
*     * SUBROUTINE RWAXV2 *
*
*
*     * Purpose *
*
*     Multiplication of two rowwise stored dense rectangular matrices A
*     and B by vectors X and Y.
*
*
*     * Calling sequence *
*
*     CALL RWAXV2(N,M,A,B,X,Y,V,W)
*
*
*     * Parameters *
*
*     II  N             Number of columns of the matrices A and B.
*     II  M             Number of rows of the matrices A and B.
*     RI  A(N*M)        Rectangular matrix stored rowwise in the
*                       one-dimensional array.
*     RI  B(N*M)        Rectangular matrix stored rowwise in the
*                       one-dimensional array.
*     RI  X(N)          Input vector.
*     RI  Y(N)          Input vector.
*     RO  V(M)          Output vector equal to A*X.
*     RO  W(M)          Output vector equal to B*Y.
*
*
*     Napsu Haarala, 2006
*
*
      SUBROUTINE RWAXV2(N,M,A,B,X,Y,V,W)

*     Scalar Arguments
      INTEGER N,M

*     Array Arguments
      DOUBLE PRECISION A(*),B(*),X(*),Y(*),V(*),W(*)

*     Local Scalars
      INTEGER I,J,K
      DOUBLE PRECISION TMP1,TMP2

      K = 0
      DO 10 I = 1,M
         TMP1 = 0.0D+00
         TMP2 = 0.0D+00
         DO 20 J = 1,N
            TMP1 = TMP1 + A(K+J)*X(J)
            TMP2 = TMP2 + B(K+J)*Y(J)
 20      CONTINUE
         V(I) = TMP1
         W(I) = TMP2
         K = K + N
 10   CONTINUE

      RETURN
      END

************************************************************************
*
*     * SUBROUTINE MXDPGF *
*
*
*     * Purpose *
*
*     Factorization A+E=L*D*trans(L) of a dense symmetric positive
*     definite matrix A+E, where D and E are diagonal positive definite
*     matrices and L is a lower triangular matrix. If A is sufficiently
*     positive definite then E=0.
*
*
*     * CALLING SEQUENCE *
*
*     CALL MXDPGF(N,A,INF,ALF,TAU)
*
*
*     * PARAMETERS *
*
*     II  N             Order of the matrix A.
*     RU  A(N*(N+1)/2)  On input a given dense symmetric (usually
*                       positive definite) matrix A stored in the packed
*                       form. On output the computed factorization
*                       A+E=L*D*trans(L).
*     IO  INF           An information obtained in the factorization
*                       process:
*                         INF=0  - A is sufficiently positive definite
*                                  and E=0.
*                         INF<0  - A is not sufficiently positive
*                                  definite and E>0.
*                         INF>0  - A is indefinite and INF is an index
*                                  of the most negative diagonal element
*                                  used in the factorization process.
*     RU  ALF           On input a desired tolerance for positive
*                       definiteness. On output the most negative
*                       diagonal element used in the factorization
*                       process (if INF>0).
*     RO  TAU           Maximum diagonal element of the matrix E.
*
*
*     * Method *
*
*     P.E.Gill, W.Murray : Newton type methods for unconstrained and
*     linearly constrained optimization, Math. Programming 28 (1974)
*     pp. 311-350.
*
*
*     * Original version *
*
*     L.Luksan
*
*

      SUBROUTINE MXDPGF(N,A,INF,ALF,TAU)

*     Scalar Arguments
      INTEGER INF,N
      DOUBLE PRECISION ALF,TAU

*     Array Arguments
      DOUBLE PRECISION A(*)

*     Local Scalars
      INTEGER I,IJ,IK,J,K,KJ,KK,L
      DOUBLE PRECISION BET,DEL,GAM,RHO,SIG,TOL

*     Intrinsic Functions
      INTRINSIC ABS,MAX

      L = 0
      INF = 0
      TOL = ALF

*
*     Estimation of the matrix norm
*
      ALF = 0.0D0
      BET = 0.0D0
      GAM = 0.0D0
      TAU = 0.0D0
      KK = 0

      DO 20 K = 1,N
         KK = KK + K
         BET = MAX(BET,ABS(A(KK)))
         KJ = KK
         DO 10 J = K + 1,N
            KJ = KJ + J - 1
            GAM = MAX(GAM,ABS(A(KJ)))
 10      CONTINUE
 20   CONTINUE
      BET = MAX(TOL,BET,GAM/N)

      DEL = TOL*MAX(BET,1.0D0)
      KK = 0
      DO 60 K = 1,N
         KK = KK + K

*
*     Determination of a diagonal correction
*
         SIG = A(KK)
         IF (ALF.GT.SIG) THEN
            ALF = SIG
            L = K
         END IF

         GAM = 0.0D0
         KJ = KK
         DO 30 J = K + 1,N
            KJ = KJ + J - 1
            GAM = MAX(GAM,ABS(A(KJ)))
 30      CONTINUE
         GAM = GAM*GAM
         RHO = MAX(ABS(SIG),GAM/BET,DEL)
         IF (TAU.LT.RHO-SIG) THEN
            TAU = RHO - SIG
            INF = -1
         END IF

*
*     Gaussian elimination
*
         A(KK) = RHO
         KJ = KK
         DO 50 J = K + 1,N
            KJ = KJ + J - 1
            GAM = A(KJ)
            A(KJ) = GAM/RHO
            IK = KK
            IJ = KJ
            DO 40 I = K + 1,J
               IK = IK + I - 1
               IJ = IJ + 1
               A(IJ) = A(IJ) - A(IK)*GAM
 40         CONTINUE
 50      CONTINUE
 60   CONTINUE
      IF (L.GT.0 .AND. ABS(ALF).GT.DEL) INF = L

      RETURN
      END

************************************************************************
*
*     * SUBROUTINE CALQ *
*
*
*     * Purpose *
*
*     Solving X from linear equation A*X=Y.
*
*
*     * Calling sequence *
*
*     CALL CALQ(N,M,IOLD,A,X,Y,SMALL,IPRINT)
*
*
*     * Parameters *
*
*     II  N               Order of matrix A.
*     RU  A(N*(N+1)/2)    On input: Dense symmetric matrix stored in
*                           the packed form. On output: factorization
*                           A+E=L*D*TRANS(L).
*     II  M               Length of vector Y, M >= N, note that only N
*                           components from vector Y are used
*     RI  Y(M)            Input vector stored in a circular order.
*     II  IOLD            Index, which controlls the circular order of
*                           the vector Y.
*     RO  X(M)            Output vector equal to the solution of A*X=Y.
*                           The vector X has the same circular order
*                           than Y. Note that X may be equal to Y in
*                           calling sequence.
*     RI  SMALL           Small positive value.
*     II  IPRINT          Printout specification.
*
*
*     * Local variables *
*
*     I   INF
*     R   ETA
*     R   BET
*     I   IERR            Error indicador:
*                             0  - Everything is ok.
*                            -2  - Error in LINEQ.
*
*
*     * Subprograms used *
*
*     S   MXDPGF          Gill-Murray decomposition of a dense symmetric
*                           matrix.
*     S   LINEQ           Solver for linear equation.
*
*
*     Napsu Haarala (2003)
*

      SUBROUTINE CALQ(N,M,IOLD,A,X,Y,SMALL,IPRINT)

*     Scalar Arguments
      INTEGER N,M,IOLD,IPRINT
      DOUBLE PRECISION SMALL

*     Array Arguments
      DOUBLE PRECISION A(*),X(*),Y(*)

*     Local Variables
      INTEGER INF,IERR
      DOUBLE PRECISION ETA,BET

*     External Subroutines
      EXTERNAL MXDPGF,LINEQ

      ETA = SMALL

      CALL MXDPGF(N,A,INF,ETA,BET)

      IF (INF .LT. 0) THEN
         IF (IPRINT .EQ. 2) THEN
            WRITE (6,FMT='(1X,''Warning: Insufficiently positive''
     &           '' definite matrix detected. '')')
            WRITE (6,FMT='(1X,''Correction added.'')')
         END IF

      ELSE IF (INF .GT. 0) THEN
         IF (IPRINT .EQ. 2) WRITE (6,FMT='(1X,''Warning: Indefinite''
     &        '' matrix detected. ''
     &        ''Correction added.'')')
      END IF

      CALL LINEQ(N,M,IOLD,A,X,Y,IERR)
      IF (IERR .NE. 0) THEN
         IF (IPRINT .EQ. 2) THEN
            WRITE (6,FMT='(1X,''Warning: ''
     &           '' Indefinite matrix detected. '')')
         END IF
      END IF

      RETURN
      END

************************************************************************
*
*     * SUBROUTINE LINEQ *
*
*
*     * Purpose *
*
*     Solving X from linear equation A*X=Y. Positive definite matrix A+E
*     is given using the factorization A+E=L*D*L' obtained by the
*     subroutine MXDPGF.
*
*
*     * Calling sequence *
*
*     CALL LINEQ(N,M,IOLD,A,X,Y,IERR)
*
*
*     * Parameters *
*
*     II  N               Order of matrix A.
*     RI  A(N*(N+1)/2)    Factorization A+E=L*D*L' obtained by the
*                           subroutine MXDPGF.
*     II  M               Length of vector Y, M >= N. Note that only N
*                           components from vector Y are used
*     RI  Y(M)            Input vector stored in a circular order.
*     II  IOLD            Index, which controlls the circular order of
*                           the vector Y.
*     RO  X(M)            Output vector equal to the solution of A*X=Y.
*                           The vector X has the same circular order
*                           than Y. Note that X may be equal to Y in
*                           calling sequence.
*     IO  IERR            Error indicador:
*                             0  - Everything is ok.
*                            -2  - Error; 0 at diagonal.
*
*
*     * Method *
*
*     Forward and backward substitution
*
*
*     Napsu Haarala (2003)
*

      SUBROUTINE LINEQ(N,M,IOLD,A,X,Y,IERR)

*     Scalar Arguments
      INTEGER N,M,IOLD,IERR

*     Array Arguments
      DOUBLE PRECISION A(*),X(*),Y(*)

*     Local Variables
      INTEGER I,II,IJ,J,K,L

      IERR = -2

*
*     Phase 1: X=L**(-1)*X
*
      IJ = 0
      DO 10 I = 1,N
         L=I+IOLD-1
         IF (L .GT. M) L=L-M
         X(L) = Y(L)
c        II = II + I

         DO 20 J = 1,I - 1
            IJ = IJ + 1
            K=J+IOLD-1
            IF (K .GT. M) K=K-M
            X(L) = X(L) - A(IJ)*X(K)
 20      CONTINUE
         IJ = IJ + 1
 10   CONTINUE

*
*     Phase 2 : X:=D**(-1)*X
*
      II = 0
      DO 30 I = 1,N
         II = II + I
         IF (A(II) .EQ. 0.0D+00) GOTO 999
         L=I+IOLD-1
         IF (L .GT. M) L=L-M
         X(L) = X(L)/A(II)
 30   CONTINUE

*
*     Phase 3 : X:=TRANS(L)**(-1)*X
*
      II = N* (N-1)/2
      DO 50 I = N - 1,1,-1
         IJ = II
         L=I+IOLD-1
         IF (L .GT. M) L=L-M
         DO 40 J = I + 1,N
            K=J+IOLD-1
            IF (K .GT. M) K=K-M
            IJ = IJ + J - 1
            X(L) = X(L) - A(IJ)*X(K)
 40      CONTINUE
         II = II - I
 50   CONTINUE
c     Phase 2 and 3
c      II = N * (N+1)/2
c      DO 30 I = N,1,-1
c         L=I+IOLD-1
c         IF (L .GT. M) L=L-M
c         X(L) = X(L)/A(II)
c         IJ = II
c         DO 40 J = I + 1,N
c            K=J+IOLD-1
c            IF (K .GT. M) K=K-M
c            IJ = IJ + J - 1
c            X(L) = X(L) - A(IJ)*X(K)
c 40      CONTINUE
c         II = II - I
c 30   CONTINUE

      IERR = 0

 999  CONTINUE

      RETURN
      END

************************************************************************
*
*     * SUBROUTINE TRLIEQ *
*
*
*     * Purpose *
*
*     Solving X from linear equation U*X=Y or U'*X=Y, where U is
*     an upper triangular matrix.
*
*
*     * Calling sequence *
*
*     CALL TRLIEQ(N,M,IOLD,U,X,Y,JOB,SMALL,IERR)
*
*
*     * Parameters *
*
*     II  N               Order of matrix U.
*     RI  U(N*(N+1)/2)    Triangular matrix.
*     II  M               Length of vector Y, M >= N. Note that only N
*                           components from vector Y are used
*     RI  Y(M)            Input vector stored in a circular order.
*     II  IOLD            Index, which controlls the circular order of
*                           the vector Y.
*     RO  X(M)            Output vector equal to the solution of U*X=Y
*                           or U'*X=Y. The vector X has the same
*                           circular order than Y. Note that X may be
*                           equal to Y in calling sequence.
*     II  JOB             Option:
*                             0  - X:=(U')**(-1)*Y, U upper
*                                  triangular.
*                             1  - X:=U**(-1)*Y, U upper triangular.
*     RI  SMALL           Small positive value.
*     IO  IERR            Error indicador:
*                             0  - Everything is ok.
*                            -3  - Error; 0 at diagonal.
*
*
*
*     * Method *
*
*     Forward and backward substitution
*
*
*     Napsu Haarala (2003)
*

      SUBROUTINE TRLIEQ(N,M,IOLD,U,X,Y,JOB,IERR)

*     Scalar Arguments
      INTEGER N,M,IOLD,JOB,IERR

*     Array Arguments
      DOUBLE PRECISION U(*),X(*),Y(*)

*     Local Variables
      INTEGER I,II,IJ,J,K,L,JI

*     Intrinsic Functions
      INTRINSIC ABS

      IERR = -3

      DO I=1,M
         X(I)=Y(I)
      ENDDO

      IF (JOB .EQ. 0) THEN
*
*     X=U'**(-1)*Y, U' = [u1         ] is lower triangular.
*                        [u2 u3      ]
*                        [u4 u5 u6   ]
*                        [.  .  .  . ]
*
         II = 0
         DO 10 I = 1,N
            II=II+I
            L=I+IOLD-1
            IF (L .GT. M) L=L-M
            IF (U(II) .EQ. 0.0D+00) GO TO 999
            X(L) = X(L)/U(II)
            DO 20 J = I+1,N
               JI = (J-1)*J/2+I
               K=J+IOLD-1
               IF (K .GT. M) K=K-M
               X(K) = X(K) - U(JI)*X(L)
 20         CONTINUE
 10      CONTINUE

      ELSE IF (JOB .EQ. 1) THEN
*
*     X=U**(-1)*Y, U = [u1 u2 u4 . ] is upper triangular.
*                      [   u3 u5 . ]
*                      [      u6 . ]
*                      [         . ]
*

         II = N* (N+1)/2
         DO 50 I = N,1,-1
            L=I+IOLD-1
            IF (L .GT. M) L=L-M
            IF (U(II) .EQ. 0.0D+00) GO TO 999
            IJ = II
            DO 60 J = I + 1,N
               K=J+IOLD-1
               IF (K .GT. M) K=K-M
               IJ = IJ + J - 1
               X(L) = X(L) - U(IJ)*X(K)
 60         CONTINUE
            X(L)=X(L)/U(II)
            II = II - I
 50      CONTINUE

      ELSE

         GO TO 999
      END IF

      IERR = 0

 999  CONTINUE

      RETURN
      END

************************************************************************
*
*     * SUBROUTINE SCALEX *
*
*
*     * Purpose *
*
*     Scaling a vector.
*
*
*     * Calling sequence *
*
*     CALL SCALEX(N,A,X,Y)
*
*
*     * Parameters *
*
*     II  N             Vector dimension.
*     RI  X(N)          Input vector.
*     RI  A             Scaling parameter.
*     RO  Y(N)          Output vector, where Y:= A*X.
*
*
*     Napsu Haarala (2006)
*

      SUBROUTINE SCALEX(N,A,X,Y)

*     Scalar Arguments
      INTEGER N
      DOUBLE PRECISION A

*     Array Arguments
      DOUBLE PRECISION X(*),Y(*)

*     Local Scalars
      INTEGER I

      DO 10 I = 1,N
         Y(I) = A*X(I)
 10   CONTINUE

      RETURN
      END

************************************************************************
*
*     * SUBROUTINE SCDIFF *
*
*
*     * Purpose *
*
*     Difference of the scaled vector and a vector.
*
*
*     * Calling sequence *
*
*     CALL SCDIFF(N,A,X,Y,Z)
*
*
*     * Parameters *
*
*     II  N             Vector dimension.
*     RI  A             Scaling factor.
*     RI  X(N)          Input vector.
*     RI  Y(N)          Input vector.
*     RO  Z(N)          Output vector, where Z:= A*X - Y.
*
*
*     Napsu Haarala (2004)
*

      SUBROUTINE SCDIFF(N,A,X,Y,Z)

*     Scalar Arguments
      INTEGER N
      DOUBLE PRECISION A

*     Array Arguments
      DOUBLE PRECISION X(*),Y(*),Z(*)

*     Local Scalars
      INTEGER I

      DO 10 I = 1,N
         Z(I) = A*X(I) - Y(I)
 10   CONTINUE

      RETURN
      END

************************************************************************
*
*     * SUBROUTINE SCSUM *
*
*
*     * Purpose *
*
*     Sum of a vector and the scaled vector.
*
*
*     * Calling sequence *
*
*     CALL SCSUM(N,A,X,Y,Z)
*
*
*     * Parameters *
*
*     II  N             Vector dimension.
*     RI  A             Scaling factor.
*     RI  X(N)          Input vector.
*     RI  Y(N)          Input vector.
*     RO  Z(N)          Output vector, where Z:= Y + A*X.
*
*
*     Napsu Haarala (2004)
*

      SUBROUTINE SCSUM(N,A,X,Y,Z)

*     Scalar Arguments
      INTEGER N
      DOUBLE PRECISION A

*     Array Arguments
      DOUBLE PRECISION X(*),Y(*),Z(*)

*     Local Scalars
      INTEGER I

      DO 10 I = 1,N
         Z(I) = Y(I) + A*X(I)
 10   CONTINUE

      RETURN
      END

************************************************************************
*
*     * SUBROUTINE COPY *
*
*
*     * Purpose *
*
*     Copying of vector.
*
*
*     * Calling sequence *
*
*     CALL COPY(N,X,Y)
*
*
*     * Parameters *
*
*     II  N               Vectors dimension.
*     RI  X(N)            Input vector.
*     RO  Y(N)            Output vector where Y:= X.
*
*
*     Napsu Haarala (2004)
*
*

      SUBROUTINE COPY(N,X,Y)

*     Scalar Arguments
      INTEGER N

*     Array Arguments
      DOUBLE PRECISION X(*),Y(*)

*     Local Scalars
      INTEGER I

      DO 10 I = 1,N
         Y(I) = X(I)
 10   CONTINUE

      RETURN
      END

************************************************************************
*
*     * SUBROUTINE COPY2 *
*
*
*     * Purpose *
*
*     Copying of two vectors.
*
*
*     * Calling sequence *
*
*     CALL COPY2(N,X,Y,Z,V)
*
*
*     * Parameters *
*
*     II  N             Vectors dimension.
*     RI  X(N)          Input vector.
*     RO  Y(N)          Output vector where Y:= X.
*     RI  Z(N)          Input vector.
*     RO  V(N)          Output vector where V:= Z.
*
*
*     Napsu Haarala (2004)
*
*

      SUBROUTINE COPY2(N,X,Y,Z,V)

*     Scalar Arguments
      INTEGER N

*     Array Arguments
      DOUBLE PRECISION X(*),Y(*),Z(*),V(*)

*     Local Scalars
      INTEGER I

      DO 10 I = 1,N
         Y(I) = X(I)
         V(I) = Z(I)
 10   CONTINUE

      RETURN
      END

************************************************************************
*
*     * SUBROUTINE VNEG *
*
*
*     * Purpose *
*
*     Change the signs of vector elements.
*
*
*     * Calling sequence *
*
*     CALL VNEG(N,X,Y)
*
*
*     * Parameters *
*
*     II  N               Vector dimension.
*     RI  X(N)            Input vector.
*     RO  Y(N)            Output vector, where Y:= -X.
*
*
*     Napsu Haarala (2006)
*

      SUBROUTINE VNEG(N,X,Y)

*     Scalar Arguments
      INTEGER N

*     Array Arguments
      DOUBLE PRECISION X(*),Y(*)

*     Local Scalars
      INTEGER I

      DO 10 I = 1,N
         Y(I) = -X(I)
 10   CONTINUE

      RETURN
      END

************************************************************************
*
*     * SUBROUTINE VXDIAG *
*
*
*     * Purpose *
*
*     Vector is multiplied by a diagonal matrix.
*
*
*     * Calling sequence *
*
*     CALL VXDIAG(N,D,X,Y)
*
*
*     * Parameters *
*
*     II  N               Vector dimension.
*     RI  D(N)            Diagonal matrix stored as a vector with N elements.
*     RI  X(N)            Input vector.
*     RO  Y(N)            Output vector where Y:=D*X.
*
*
*     Napsu Haarala (2005)
*

      SUBROUTINE VXDIAG(N,D,X,Y)

*     Scalar Arguments
      INTEGER N

*     Array Arguments
      DOUBLE PRECISION D(*),X(*),Y(*)

*     Local Scalars
      INTEGER I

      DO 10 I = 1,N
         Y(I) = X(I)*D(I)
 10   CONTINUE

      RETURN
      END

************************************************************************
*
*     * SUBROUTINE XDIFFY *
*
*
*     * Purpose *
*
*     Difference of two vectors.
*
*
*     * Calling sequence *
*
*     CALL XDIFFY(N,X,Y,Z)
*
*
*     * Parameters *
*
*     II  N               Vector dimension.
*     RI  X(N)            Input vector.
*     RI  Y(N)            Input vector.
*     RO  Z(N)            Output vector, where Z:= X - Y.
*
*
*     Napsu Haarala (2006)
*

      SUBROUTINE XDIFFY(N,X,Y,Z)

*     Scalar Arguments
      INTEGER N

*     Array Arguments
      DOUBLE PRECISION X(*),Y(*),Z(*)

*     Local Scalars
      INTEGER I

      DO 10 I = 1,N
         Z(I) = X(I) - Y(I)
 10   CONTINUE

      RETURN
      END

************************************************************************
*
*     * SUBROUTINE XSUMY *
*
*
*     * Purpose *
*
*     Sum of two vectors.
*
*
*     * Calling sequence *
*
*     CALL XSUMY(N,X,Y,Z)
*
*
*     * Parameters *
*
*     II  N               Vector dimension.
*     RI  X(N)            Input vector.
*     RI  Y(N)            Input vector.
*     RO  Z(N)            Output vector, where Z:= Y + X.
*
*
*     Napsu Haarala (2006)
*

      SUBROUTINE XSUMY(N,X,Y,Z)

*     Scalar Arguments
      INTEGER N

*     Array Arguments
      DOUBLE PRECISION X(*),Y(*),Z(*)

*     Local Scalars
      INTEGER I

      DO 10 I = 1,N
         Z(I) = Y(I) + X(I)
 10   CONTINUE

      RETURN
      END

************************************************************************
*
*     * DOUBLE PRECISION FUNCTION VDOT *
*
*
*     * Purpose *
*
*     Dot product of two vectors.
*
*
*     * Calling sequence *
*
*     XTY = VDOT(N,X,Y)
*
*
*     * Parameters *
*
*     II  N               Vectors dimension.
*     RI  X(N)            Input vector.
*     RI  Y(N)            Input vector.
*     RO  VDOT            Value of dot product VDOT=trans(X)*Y.
*
*
*     Napsu Haarala (2006)
*
*

      DOUBLE PRECISION FUNCTION VDOT(N,X,Y)

*     Scalar Arguments
      INTEGER N

*     Array Arguments
      DOUBLE PRECISION X(*),Y(*)

*     Local Scalars
      INTEGER I
      DOUBLE PRECISION TMP

      TMP = 0.0D0

      DO 10 I = 1,N
         TMP = TMP + X(I)*Y(I)
 10   CONTINUE

      VDOT = TMP

      RETURN
      END

************************************************************************
*
*     * DOUBLE PRECISION FUNCTION EPS0 *
*
*
*     * Purpose *
*
*     Computation of the smallest positive number such that
*     1.0 + EPS0 > 1.0.
*
*
*     * Calling sequence *
*
*     SMALL = EPS0()
*
*
*     Napsu Haarala (2003)
*
*

      DOUBLE PRECISION FUNCTION EPS0()

*     Local scalars
      DOUBLE PRECISION EPSNEW

      EPS0=1.0D+00

 100  EPSNEW=EPS0/2.0D+00

      IF(1.0D+00+EPSNEW .EQ. 1.0D+00) RETURN

      EPS0=EPSNEW
      GO TO 100

      END

************************************************************************


!
! Copyright (c) 2000, NVIDIA CORPORATION.  All rights reserved.
!
! Licensed under the Apache License, Version 2.0 (the "License");
! you may not use this file except in compliance with the License.
! You may obtain a copy of the License at
!
!     http://www.apache.org/licenses/LICENSE-2.0
!
! Unless required by applicable law or agreed to in writing, software
! distributed under the License is distributed on an "AS IS" BASIS,
! WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
! See the License for the specific language governing permissions and
! limitations under the License.
!
! test f2008 bessel_yn intrinsic

program p
 use ISO_C_BINDING
 use check_mod

  interface
    subroutine get_expected_f( src1, expct, order, n ) bind(C)
     use ISO_C_BINDING
      type(C_PTR), value :: src1
      type(C_PTR), value :: expct
      integer(C_INT), value :: order
      integer(C_INT), value :: n
    end subroutine

    subroutine get_expected_d( src1, expct, order, n ) bind(C)
     use ISO_C_BINDING
      type(C_PTR), value :: src1
      type(C_PTR), value :: expct
      integer(C_INT), value :: order
      integer(C_INT), value :: n
    end subroutine
  end interface

  integer, parameter :: N=22
  real*4, target,  dimension(N) :: r_src1
  real*4, target,  dimension(N) :: r_rslt
  real*4, target,  dimension(N) :: r_expct
  real*8 :: valuer

  real*8, target,  dimension(N) :: d_src1
  real*8, target,  dimension(N) :: d_rslt
  real*8, target,  dimension(N) :: d_expct
  real*8 :: value8
  integer :: order = 3

  valuer = -.2
  valued = -.2_8
  do i =  0,N-1
    r_src1(i+1) = valuer + i
    d_src1(i+1) = valued + i
  enddo

  r_rslt = bessel_yn(order, r_src1)
  d_rslt = bessel_yn(order, d_src1)

  call get_expected_f(C_LOC(r_src1), C_LOC(r_expct), order, N)
  call get_expected_d(C_LOC(d_src1), C_LOC(d_expct), order, N)

  call checkr4( r_rslt, r_expct, N, rtoler=0.0000003)
  call checkr8( d_rslt, d_expct, N, rtoler=0.0000003_8)

!   print *, "r_expct:"
!   print *, r_expct
!   print *, "r_rslt:"
!   print *, r_rslt
!
!   print *, "d_expct:"
!   print *, d_expct
!   print *, "d_rslt:"
!   print *, d_rslt
end program