module SSRFPACKRemeshModule

use NumberKindsModule
use STDIntVectorModule
use OutputWriterModule
use LoggerModule
use ParticlesModule
use FieldModule
use EdgesModule
use FacesModule
use PlaneGeomModule
use SphereGeomModule
use PolyMesh2dModule
use SphereBVEModule
use RefinementModule
use SSRFPACKInterfaceModule

implicit none

private
public BVERemeshSource, New, Delete

!----------------
! types and module variables
!----------------
!
type BVERemeshSource
	type(DelaunayTriangulation) :: delTri
	type(SSRFPACKInterface) :: relVortSource
	type(SSRFPACKInterface) :: absVortSource
	type(SSRFPACKInterface) :: lagParamSource
	type(SSRFPACKInterface), dimension(:), pointer :: tracerSource => null()

	contains
		final :: deleteBVE
end type

!
!----------------
! interfaces
!----------------
!
interface New
	module procedure newBVE
end interface

interface Delete
	module procedure deleteBVE
end interface

!
!----------------
! Logging
!----------------
!
logical(klog), save :: logInit = .FALSE.
type(Logger) :: log
character(len=28), save :: logKey = 'SSRFRemesh'
character(len=MAX_STRING_LENGTH) :: logString
integer(kint), parameter :: logLevel = DEBUG_LOGGING_LEVEL

contains
!
!----------------
! public methods
!----------------
!
subroutine newBVE( self, oldSphere )
	type(BVERemeshSource), intent(out) :: self
	type(BVEMesh), intent(inout) :: oldSphere
	!
	integer(kint) :: i

	call New(self%delTri, oldsphere%mesh)

	call New(self%lagParamSource, oldSphere%mesh, 3)
	call SetSourceLagrangianParameter(self%lagParamSource, oldSphere%mesh, self%delTri)

	call New(self%relVortSource, oldsphere%mesh, 1)
	call SetScalarSourceData(self%relVortSource, oldSphere%mesh, self%delTri, oldSphere%relVort)

	call New(self%absVortSource, oldsphere%mesh, 1)
	call SetScalarSourceData(self%absVortSource, oldSphere%mesh, self%delTri, oldSphere%absVort)

	if ( associated(oldSphere%tracers)) then
		allocate(self%tracerSource(size(oldSphere%tracers)))
		do i = 1, size(oldSphere%tracers)
			call New(self%tracerSource(i), oldsphere%mesh, oldSphere%tracers(i)%nDim)
			if ( oldSphere%tracers(i)%nDim == 1 ) then
				call SetScalarSourceData(self%tracerSource(i), oldSphere%mesh, self%delTri, oldSphere%tracers(i))
			else
				call SetVectorSourceData(self%tracerSource(i), oldSphere%mesh, self%delTri, oldSphere%tracers(i))
			endif
		enddo
	endif
end subroutine

subroutine deleteBVE( self )
	type(BVERemeshSource), intent(inout) :: self
	!
	integer(kint) :: i

	call Delete(self%delTri)
	call Delete(self%lagParamSource)
	call Delete(self%relVortSource)
	call Delete(self%absVortSource)
	if ( associated(self%tracerSource) ) then
		do i = 1, size(self%tracerSource)
			call Delete(self%tracerSource(i))
		enddo
		deallocate(self%tracerSource)
	endif
end subroutine

subroutine DirectRemeshBVE(self, oldSphere, newSphere, AMR, vortFlagFn1, tol1, desc1, flagFn2, tol2, desc2, field2 )
	type(BVERemeshSource), intent(in) :: self
	type(BVEMesh), intent(in) :: oldSphere
	type(BVEMesh), intent(inout) :: newSphere
	logical(klog), intent(in) :: AMR
	procedure(FlagFunction), optional :: vortFlagFn1
	real(kreal), intent(in), optional :: tol1
	character(len=*), intent(in), optional :: desc1
	procedure(FlagFunction), optional :: flagFn2
	real(kreal), intent(in), optional :: tol2
	character(len=*), intent(in), optional :: desc2
	type(Field), intent(inout), optional :: field2
	!
	integer(kint) :: i, j, k
	real(kreal) :: lon, lat
	real(kreal), dimension(3) :: x0, vecT
	type(RefineSetup) :: refine
	integer(kint) :: refineVariableCount
	integer(kint) :: nParticlesBefore, nParticlesAfter

	!
	!	Remesh to new uniform mesh
	!
	newSphere%relVort%N = newSphere%mesh%particles%N
	newSphere%absVort%N = newSphere%mesh%particles%N
	do i = 1, newSphere%mesh%particles%N
		lon = Longitude( newSphere%mesh%particles%x(i), newSphere%mesh%particles%y(i), newSphere%mesh%particles%z(i))
		lat = Latitude( newSphere%mesh%particles%x(i), newSphere%mesh%particles%y(i), newSphere%mesh%particles%z(i))
		newSphere%relVort%scalar(i)	= InterpolateScalar( lon, lat, self%relVortSource, oldSphere%mesh, &
														 self%delTri, oldSphere%relVort)
		newSphere%absVort%scalar(i)	= InterpolateScalar( lon, lat, self%absVortSource, oldSphere%mesh, &
														 self%delTri, oldSphere%absVort)
		x0 = InterpolateLagParam( lon, lat, self%lagParamSource, oldSphere%mesh, self%delTri)
		newSphere%mesh%particles%x0(i) = x0(1)
		newSphere%mesh%particles%y0(i) = x0(2)
		newSphere%mesh%particles%z0(i) = x0(3)
	enddo

	if (associated(newSphere%tracers)) then
		do i = 1, size(newSphere%tracers)
			newSphere%tracers(i)%N = newSphere%mesh%particles%N
		enddo
		do j = 1, newSphere%mesh%particles%N
			lon = Longitude( newSphere%mesh%particles%x(j), newSphere%mesh%particles%y(j), newSphere%mesh%particles%z(j))
			lat = Latitude( newSphere%mesh%particles%x(j), newSphere%mesh%particles%y(j), newSphere%mesh%particles%z(j))
			do i = 1, size(newSphere%tracers)
				 if ( newSphere%tracers(i)%nDim == 1 ) then
				 	newSphere%tracers(i)%scalar(j) = InterpolateScalar(lon, lat, self%tracerSource(i), oldSphere%mesh, &
				 													   self%delTri, oldSphere%tracers(i))
				 else
				 	vecT = InterpolateVector(lon, lat, self%tracerSource(i), oldSphere%mesh, self%delTri, oldSphere%tracers(i))
				 	newSphere%tracers(i)%xComp(j) = vecT(1)
				 	newSphere%tracers(i)%yComp(j) = vecT(2)
				 	newSphere%tracers(i)%zComp(j) = vecT(3)
				 endif
			enddo
		enddo
	endif

	!
	!  Perform adaptive refinement, interpolate Field data to new Particles
	!
	if ( AMR ) then
		refineVariableCount = 0
		if ( present(vortFlagFn1) .AND. (present(tol1) .AND. present(desc1)) ) then
			refineVariableCount = 1
			if ( present(flagFn2) .AND. ( present(tol2) .AND. present(desc2) ) ) then
				refineVariableCount = 2
			endif
		endif

		if (refineVariableCount > 0 ) then
			call New(refine, newSphere%mesh%faces%N_Max)

			do i = 1, newSphere%mesh%amrLimit
				nParticlesBefore = newSphere%mesh%particles%N
				if ( refineVariableCount == 1 ) then
					call IterateMeshRefinementOneVariable( refine, newSphere%mesh, newSphere%relVort, &
											vortFlagFn1, tol1, desc1, nParticlesBefore, nParticlesAfter)
				elseif ( refineVariableCount == 2 ) then
					if ( present(field2) ) then
						call IterateMeshRefinementTwoVariables( refine, newSphere%mesh, newSphere%relVort, vortFlagFn1, &
								tol1, desc1, field2, flagFn2, tol2, desc2, nParticlesBefore, nParticlesAfter)
					else
						call IterateMeshRefinementTwoVariables( refine, newSphere%mesh, newSphere%relVort, vortFlagFn1, &
								tol1, desc1, newSphere%relVort, flagFn2, tol2, desc2, nParticlesBefore, nParticlesAfter)
					endif
				endif

				do j = nParticlesBefore + 1, nParticlesAfter
					lon = Longitude( newSphere%mesh%particles%x(j), newSphere%mesh%particles%y(j), &
									 newSphere%mesh%particles%z(j))
					lat = Latitude( newSphere%mesh%particles%x(j), newSphere%mesh%particles%y(j), &
									newSphere%mesh%particles%z(j))
					newSphere%relVort%scalar(j) = InterpolateScalar( lon, lat, self%relVortSource, oldSphere%mesh, &
																	 self%delTri, oldSphere%relVort)
					newSphere%absVort%scalar(j) = InterpolateScalar( lon, lat, self%absVortSource, oldSphere%mesh, &
																	 self%delTri, oldSphere%absVort)
					if (associated(newSphere%tracers)) then
						do k = 1, size(newSphere%tracers)
							if ( newSphere%tracers(k)%nDim == 1 ) then
								newSphere%tracers(k)%scalar(j) = InterpolateScalar( lon, lat, self%tracerSource(k), &
													oldSphere%mesh, self%delTri, oldSphere%tracers(k) )
							else
								vecT = InterpolateVector(lon, lat, self%tracerSource(k), oldSphere%mesh, self%delTri, &
													oldSphere%tracers(k))
								newSphere%tracers(k)%xComp(j) = vecT(1)
								newSphere%tracers(k)%yComp(j) = vecT(2)
								newSphere%tracers(k)%zComp(j) = vecT(3)
							endif
						enddo
					endif
				enddo
			enddo
			newSphere%relVort%N = newSphere%mesh%particles%N
			newSphere%absVort%N = newSphere%mesh%particles%N
			if ( associated(newSphere%tracers) ) then
				do k = 1, size(newSphere%tracers)
					newSphere%tracers(k)%N = newSphere%mesh%particles%N
				enddo
			endif
			call LoadBalance(newSphere%mpiParticles, newSphere%mesh%particles%N, numProcs)
			call Delete(refine)
		endif
	endif
end subroutine

subroutine LagrangianRemeshVorticityWithFunction( self, oldSphere, newSphere, AMR, relVortFn, flagFn1, tol1, desc1, &
								flagFn2, tol2, desc2, RefineFlowMapYN, flowMapVarTol, nLagTracers, tracerFn1, tracerFn2 )
	type(BVERemeshSource), intent(in) :: self
	type(BVEMesh), intent(in) :: oldSphere
	type(BVEMesh), intent(inout) :: newSphere
	logical(klog), intent(in) :: AMR
	procedure(scalarFnOf3DSpace) :: relVortFn
	procedure(FlagFunction) :: flagFn1
	real(kreal), intent(in) :: tol1
	character(len=*), intent(in) :: desc1
	procedure(FlagFunction), optional :: flagFn2
	real(kreal), intent(in), optional :: tol2
	character(len=*), intent(in), optional :: desc2
	logical(klog), intent(in), optional :: RefineFlowMapYN
	real(kreal), intent(in), optional :: flowMapVarTol
	integer(kint), intent(in), optional :: nLagTracers
	procedure(scalarFnOf3DSpace), optional :: tracerFn1
	procedure(scalarFnOf3DSpace), optional :: tracerFn2
	!
	integer(kint) :: refinementType, nTracers
	logical(klog) :: refineVorticityTwice, refineFlowMap
	integer(kint) :: i, j, k
	real(kreal) :: lon, lat
	real(kreal), dimension(3) :: x0
	type(RefineSetup) :: refine
	integer(kint) :: nParticlesBefore, nParticlesAfter
	real(kreal), dimension(3) :: vecT

	nTracers = 0
	if ( present(tracerFn1) .AND. ( nLagTracers >= 1 .AND. newSphere%tracers(1)%nDim == 1) ) then
		nTracers = 1
		if ( present(tracerFn2) .AND. ( nLagTracers == 2 .AND. newSphere%tracers(2)%nDim == 1) ) nTracers = 2
	endif

	newSphere%relVort%N = newSphere%mesh%particles%N
	newSphere%absVort%N = newSphere%mesh%particles%N
	if ( associated(newSphere%tracers) ) then
		do i = 1, size(newSphere%tracers)
			newSphere%tracers(i)%N = newSphere%mesh%particles%N
		enddo
	endif

	do i = 1, newSphere%mesh%particles%N
		lon = Longitude( newSphere%mesh%particles%x(i), newSphere%mesh%particles%y(i), newSphere%mesh%particles%z(i))
		lat = Latitude( newSphere%mesh%particles%x(i), newSphere%mesh%particles%y(i), newSphere%mesh%particles%z(i))
		x0 = InterpolateLagParam( lon, lat, self%lagParamSource, oldSphere%mesh, self%delTri)
		newSphere%mesh%particles%x0(i) = x0(1)
		newSphere%mesh%particles%y0(i) = x0(2)
		newSphere%mesh%particles%z0(i) = x0(3)

		newSphere%absVort%scalar(i) = relVortFn( x0(1), x0(2), x0(3)) + &
				2.0_kreal * newSphere%rotationRate * x0(3) / newSphere%radius

		newSphere%relVort%scalar(i) = newSphere%absVort%scalar(i) - 2.0_kreal * &
			newSphere%rotationRate * newSphere%mesh%particles%z(i) / newSphere%radius

		if ( associated(newSphere%tracers) ) then
			if ( nTracers == 1 ) then
				newSphere%tracers(1)%scalar(i) = tracerFn1( x0(1), x0(2), x0(3) )
			elseif ( nTracers == 2 ) then
				newSphere%tracers(1)%scalar(i) = tracerFn1( x0(1), x0(2), x0(3) )
				newSphere%tracers(2)%scalar(i) = tracerFn2( x0(1), x0(2), x0(3) )
			endif
			do j = nTracers+1, size(newSphere%tracers)
				if ( newSphere%tracers(j)%nDim == 1 ) then
					newSphere%tracers(j)%scalar(i) = InterpolateScalar(lon, lat, self%tracerSource(j), oldSphere%mesh, &
																	   self%delTri, oldSphere%tracers(j) )
				else
					vecT = InterpolateVector(lon, lat, self%tracerSource(j), oldSphere%mesh, &
											 self%delTri, oldSphere%tracers(j) )
					newSphere%tracers(j)%xComp(i) = vecT(1)
					newSphere%tracers(j)%yComp(i) = vecT(2)
					newSphere%tracers(j)%zComp(i) = vecT(3)
				endif
			enddo
		endif
	enddo

	!
	!	AMR
	!
	if ( AMR ) then
		refineVorticityTwice = ( present(flagFn2) .AND. ( present(tol2) .AND. present(desc2) ) )
		refineFlowMap = ( RefineFlowMapYN .AND. present(flowMapVarTol))

		call New(refine, newSphere%mesh%faces%N_Max)

		do i = 1, newSphere%mesh%amrLimit
			nParticlesBefore = newSphere%mesh%particles%N

			if ( refineVorticityTwice ) then
				if ( refineFlowMap ) then
					call IterateMeshRefinementTwoVariablesAndFlowMap(refine, newSphere%mesh, newSphere%relVort, &
							flagFn1, tol1, desc1, newSphere%relVort, flagFn2, tol2, desc2, &
							flowMapVarTol, nParticlesBefore, nParticlesAfter)
				else
					call IterateMeshRefinementTwoVariables(refine, newSphere%mesh, newSphere%relVort, &
						flagFn1, tol1, desc1, newSphere%relVort, flagFn2, tol2, desc2, nParticlesBefore, nParticlesAfter)
				endif
			else
				if ( refineFlowMap ) then
					call IterateMeshRefinementOneVariableAndFlowMap(refine, newSphere%mesh, newSphere%relVort, flagFn1, &
										tol1, desc1, flowMapVarTol, nParticlesBefore, nParticlesAfter)
				else
					call IterateMeshRefinementOneVariable(refine, newSphere%mesh, newSphere%relVort, flagFn1, tol1, desc1, &
							nParticlesBefore, nParticlesAfter)
				endif
			endif

			do j = nParticlesBefore + 1, nParticlesAfter
				lon = Longitude( newSphere%mesh%particles%x(j), newSphere%mesh%particles%y(j), &
									 newSphere%mesh%particles%z(j))
				lat = Latitude( newSphere%mesh%particles%x(j), newSphere%mesh%particles%y(j), &
									newSphere%mesh%particles%z(j))
				x0 = InterpolateLagParam(lon, lat, self%lagParamSource, oldSphere%mesh, self%delTri )
				newSphere%mesh%particles%x0(j) = x0(1)
				newSphere%mesh%particles%y0(j) = x0(2)
				newSphere%mesh%particles%z0(j) = x0(3)

				newSphere%absVort%scalar(j) = relVortFn( x0(1), x0(2), x0(3) ) + &
					2.0_kreal * newSphere%rotationRate * x0(3) / newSphere%radius

				newSphere%relVort%scalar(j) = newSphere%absVort%scalar(j) - 2.0_kreal * &
					newSphere%rotationRate * newSphere%mesh%particles%z(j) / newSphere%radius

				if ( associated(newSphere%tracers) ) then
					if ( nTracers == 1 ) then
						newSphere%tracers(1)%scalar(j) = tracerFn1( x0(1), x0(2), x0(3) )
					elseif ( nTracers == 2 ) then
						newSphere%tracers(1)%scalar(j) = tracerFn1( x0(1), x0(2), x0(3) )
						newSphere%tracers(2)%scalar(j) = tracerFn2( x0(1), x0(2), x0(3) )
					endif
					do k = nTracers+1, size(newSphere%tracers)
						if ( newSphere%tracers(k)%nDIM == 1 ) then
							newSphere%tracers(k)%scalar(j) = InterpolateScalar(lon, lat, self%tracerSource(k), &
																oldSphere%mesh, self%delTri, oldSphere%tracers(k) )
						else
							vecT = InterpolateVector( lon, lat, self%tracerSource(k), oldSphere%mesh, self%delTri, &
													   oldSphere%tracers(k) )
							newSphere%tracers(k)%xComp(j) = vecT(1)
							newSphere%tracers(k)%yComp(j) = vecT(2)
							newSphere%tracers(k)%zComp(j) = vecT(3)
						endif
					enddo
				endif
			enddo
		enddo
		newSphere%relVort%N = newSphere%mesh%particles%N
		newSphere%absVort%N = newSphere%mesh%particles%N
		if ( associated(newSphere%tracers) ) then
			do k = 1, size(newSphere%tracers)
				newSphere%tracers(k)%N = newSphere%mesh%particles%N
			enddo
		endif
	endif
end subroutine

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

end module


! a simple code to check the analytic Jacobian via numerical
! differencing

program testjacobian

  use amrex_constants_module
  use amrex_error_module
  use amrex_fort_module, only : rt => amrex_real
  use network
  use eos_module
  use burner_module
  use burner_aux_module

  implicit none

  real(rt) :: dens, temp
  real(rt), dimension(nspec) :: Xin
  real(rt), dimension(nspec_advance+1) :: y, ydot
  real(rt), dimension(nspec_advance+1) :: yp, ym
  real(rt), dimension(nspec_advance+1) :: ydotp, ydotm
  real(rt), dimension(nspec_advance+1,nspec_advance+1) :: pd
  real(rt) :: enucdot

  real(rt) :: rpar
  integer :: ipar

  integer :: ic12, io16, img24
  integer :: i, j, n

  real(rt), parameter :: delta = 0.001e0_rt
  real(rt) :: num_jac

  call network_init()
  call eos_init()

  ic12 = network_species_index("carbon-12")
  io16 = network_species_index("oxygen-16")
  img24 = network_species_index("magnesium-24")

  if (ic12 < 0 .or. io16 < 0 .or. img24 < 0) then
     call amrex_error("ERROR: species index not defined")
  endif

  dens = 2.6e9_rt
  temp = 7.e8_rt

  Xin(ic12) = 0.5_rt
  Xin(io16) = 0.5_rt
  Xin(img24) = 0.0_rt

  den_eos(1) = dens
  temp_eos(1) = temp
  xn_eos(1,:) = Xin(:)

  call eos(eos_input_rt, den_eos, temp_eos, &
           npts, &
           xn_eos, &
           p_eos, h_eos, e_eos, &
           cv_eos, cp_eos, xne_eos, eta_eos, pele_eos, &
           dpdt_eos, dpdr_eos, dedt_eos, dedr_eos, &
           dpdX_eos, dhdX_eos, &
           gam1_eos, cs_eos, s_eos, &
           dsdt_eos, dsdr_eos, &
           .false.)

  print *, 'evaluating the RHS...'

  ! load the state
  y(1) = Xin(ic12)
  y(nspec_advance+1) = temp

  ! set the burner_aux variables
  dens_pass = dens
  c_p_pass = cp_eos(1)
  dhdx_pass(:) = dhdX_eos(1,:)
  X_O16_pass = Xin(io16)

  call f_rhs(nspec_advance+1, ZERO, y, ydot, rpar, ipar)

  call jac(nspec_advance+1, ZERO, y, 0, 0, pd, nspec_advance+1, rpar, ipar)

999 format(1x, "df(",i1,")/dy(",i1,")", g20.10, g20.10)

  do j = 1, nspec_advance+1

     yp(:) = y(:)
     ym(:) = y(:)

     yp(j) = (1.e0_rt + delta)*y(j)
     call f_rhs(nspec_advance+1, ZERO, yp, ydotp, rpar, ipar)

     ym(j) = (1.e0_rt - delta)*y(j)
     call f_rhs(nspec_advance+1, ZERO, ym, ydotm, rpar, ipar)

     do i = 1, nspec_advance+1

        num_jac = (ydotp(i) - ydotm(i))/(yp(j) - ym(j))

        write (*,999) i, j, num_jac, pd(i,j)

     enddo
  enddo

end program testjacobian


C Copyright (C) 2002, Carnegie Mellon University and others.
C All Rights Reserved.
C This code is published under the Common Public License.

C $Id: eval_f.f,v 1.1 2002/05/02 18:52:13 andreasw Exp $
      subroutine EVAL_F(N, X, F)
C
C     Objective function for IPOPT
C     Linear terms that we defined in DYNOPC.INC
C
C     Authors:  Yidong Lang, Andreas Waechter     09-29-01
C
      implicit none
      integer N
      double precision F, X(N)

      include 'DYNAUX.INC'
      include 'DYNOPC.INC'
!DEC$ ATTRIBUTES DLLEXPORT :: /DYNAUX/, /DYNOPC/

      integer i, iex, j

      F = 0.d0
C
C     Linear terms (see DYNOPC.INC)
C
      do i = 1, NE_IN_OBJ
         iex = (E_INDEX(i)-1)*(NCOL*(NZ+NY) + NZ)
         do j = 1, NZ_IN_OBJ
            F = F + AIJZ(j,i)*X(iex + Z_INDEX(j))
         end do
CTODO: NEED TO WORK ON THIS what for E_INDEX = 1????
         iex = iex - NY
         do j = 1, NY_IN_OBJ
            F = F + BIJY(j,i)*X(iex+Y_INDEX(j))
         end do
      end do
      iex = NZ + NELE*(NCOL*(NZ+NY)+NZ)+NELE*NCOL*NU
      do i = 1, NP_IN_OBJ
         F = F + CIP(i)*X(iex+P_INDEX(i))
      end do

      return
      end


C
C @(#)startv.f	1.10 (BNP) 10/30/90
C
      DOUBLE PRECISION FUNCTION STARTV(N,Astore,J,R,WRK,NQ,EPS,MSGLVL)
      INTEGER N,J,NQ(4),MSGLVL
      DOUBLE PRECISION R(5*N),WRK(N),EPS
C
C.... This routine delivers a starting vector in R and returns |R|;
C.... it returns ZERO if range is spanned or if no starting vector
C.... within range of operator can be found.
C
C.... N      dimension of the eigenproblem
C.... J      starting index for a Lanczos run
C.... R      an array containing [r(j),q(j),q(j-1),p(j),p(j-1)/Mr(j)]
C.... NQ(4)  location pointers for the array R
C
C.... BLAS routines:    DAXPY,DDOT
C.... subroutines:      RANDOM
C.... user-supplied:    OP,OPM,STORE
C
      INTEGER RETRQ
      PARAMETER (RETRQ = 2)
C
      INTEGER IRAND,I,ID,LOOP
      DOUBLE PRECISION RNM2,T,RANDOM,DDOT
C
      DOUBLE PRECISION ZERO
      DATA ZERO/0.0D0/
      DOUBLE PRECISION Astore(*)
C
C.... get initial vector, default is random
C
      RNM2 = DDOT(N,R,1,R,1)
      IRAND = 918272+J
      DO 60 ID = 1,3
         IF (ID.GT.1.OR.J.GT.1.OR.RNM2.EQ.ZERO) THEN
            DO 20 I = 1,N
               R(I) = RANDOM(IRAND)-0.5D0
20          CONTINUE
         ENDIF
CKW     make sure R is in the range of OPM
         CALL OPM(N,R,R(NQ(3)))
         CALL OPM(N,R(NQ(3)),R)
         CALL OPM(N,R,R(NQ(3)))
         RNM2 = DDOT(N,R,1,R(NQ(3)),1)
         IF (RNM2.EQ.ZERO) THEN
            GOTO 60
         ELSE IF (J.GT.1) THEN
            DO 50 LOOP = 1,2
               DO 40 I = 1,J-1
                  CALL STORE(N,astore,RETRQ,I,WRK)
                  T = -DDOT(N,R(NQ(3)),1,WRK,1)
                  CALL DAXPY(N,T,WRK,1,R,1)
40             CONTINUE
               CALL OPM(N,R,R(NQ(3)))
               T = DDOT(N,R(NQ(3)),1,R,1)
               IF (T.LE.EPS*RNM2) THEN
                  T = ZERO
                  GOTO 55
               ENDIF
50          CONTINUE
55          RNM2 = T
         ENDIF
         IF (RNM2.GT.ZERO) GOTO 80
60    CONTINUE
80    STARTV = SQRT(RNM2)
      RETURN
      END


************************************************************************
*
*     Function DCSEVL                                   Called by: ERFC
*
*     Evaluate the N-term Chebyshev series CS at X.  Adapted from a
*     method presented in the paper by Broucke referenced below.
*
*     Routine is a modified version of the DCSEVL code retrieved from
*     NETLIB (www.netlib.org).
*
*     Original author: W. Fullerton of Los Alamos National Lab
*
*
C       Input Arguments --
C  X    value at which the series is to be evaluated.
C  CS   array of N terms of a Chebyshev series.  In evaluating
C       CS, only half the first coefficient is summed.
C  N    number of terms in array CS.
C
C***REFERENCES  R. Broucke, Ten subroutines for the manipulation of
C                 Chebyshev series, Algorithm 446, Communications of
C                 the A.C.M. 16, (1973) pp. 254-256.
C               L. Fox and I. B. Parker, Chebyshev Polynomials in
C                 Numerical Analysis, Oxford University Press, 1968,
C                 page 56.
*
************************************************************************
      DOUBLE PRECISION FUNCTION DCSEVL(X,CS,N)
*
*     function arguments
*
      INTEGER*4 N
      DOUBLE PRECISION X,CS(*)
*
*     local vars
*
      INTEGER*4 I,NI
      DOUBLE PRECISION B0,B1,B2,TWOX
*
*     function declaration
*
      DOUBLE PRECISION D1MACH
*
*     error tests
*
      IF (N .LT. 1) CALL ERROR7(1)
      IF (N .GT. 1000) CALL ERROR7(2)
      IF (ABS(X) .GT. 1.D0 + D1MACH(4)) CALL ERROR7(3)

      B1 = 0.D0
      B0 = 0.D0
      TWOX = 2.D0*X
      DO 10 I = 1,N
         B2 = B1
         B1 = B0
         NI = N + 1 - I
         B0 = TWOX*B1 - B2 + CS(NI)
   10 CONTINUE

      DCSEVL = 0.5D0*(B0-B2)

      RETURN
      END


c     prog1
c     c.l.lawson and r.j.hanson, jet propulsion laboratory, 1973 jun 12
c     to appear in 'solving least squares problems', prentice-hall, 1974
c	 demonstrate algorithms hft and hs1 for solving least squares
c     problems and algorithm cov for omputing the associated covariance
c     matrices.
c
      dimension a(8,8),h(8),b(8)
      real gen,anoise
      double precision sm
      data mda/8/
c
	   do 180 noise=1,2
	   anoise=0.
	   if (noise.eq.2) anoise=1.e-4
	   write (6,230)
	   write (6,240) anoise
c     initialize the data generation function
c    ..
	   dummy=gen(-1.)
		do 180 mn1=1,6,5
		mn2=mn1+2
		     do 180 m=mn1,mn2
		     do 180 n=mn1,mn2
		     np1=n+1
		     write (6,250) m,n
c     generate data
c    ..
			  do 10 i=1,m
			       do 10 j=1,n
   10			       a(i,j)=gen(anoise)
			  do 20 i=1,m
   20			  b(i)=gen(anoise)
		     if(m .lt. n) go to 180
c
c     ******  begin algorithm hft  ******
c    ..
			  do 30 j=1,n
   30		   call h12 (1,j,j+1,m,a(1,j),1,h(j),a(1,j+1),1,mda,n-j)
c    ..
c     the algorithm 'hft' is completed.
c
c     ******  begin algorithm hs1  ******
c     apply the transformations  q(n)...q(1)=q to b
c     replacing the previous contents of the array, b .
c    ..
			  do 40 j=1,n
   40			      call h12 (2,j,j+1,m,a(1,j),1,h(j),b,1,1,1)
c     solve the triangular system for the solution x.
c     store x in the array, b .
c    ..
			  do 80 k=1,n
			  i=np1-k
			  sm=0.d0
			  if (i.eq.n) go to 60
			  ip1=i+1
			       do 50 j=ip1,n
   50			       sm=sm+a(i,j)*dble(b(j))
   60			  if (a(i,i)) 80,70,80
   70			  write (6,260)
			  go to 180
   80			  b(i)=(b(i)-sm)/a(i,i)
c      compute length of residual vector.
c     ..
		     srsmsq=0.
		     if (n.eq.m) go to 100
		     mmn=m-n
			  do 90 j=1,mmn
			  npj=n+j
   90			  srsmsq=srsmsq+b(npj)**2
		     srsmsq=sqrt(srsmsq)
c     ******  begin algorithm  cov  ******
c     compute unscaled covariance matrix   ((a**t)*a)**(-1)
c    ..
  100			  do 110 j=1,n
  110			  a(j,j)=1./a(j,j)
		     if (n.eq.1) go to 140
		     nm1=n-1
			  do 130 i=1,nm1
			  ip1=i+1
			       do 130 j=ip1,n
			       jm1=j-1
			       sm=0.d0
				    do 120 l=i,jm1
  120				    sm=sm+a(i,l)*dble(a(l,j))
  130			       a(i,j)=-sm*a(j,j)
c    ..
c     the upper triangle of a has been inverted
c     upon itself.
  140			  do 160 i=1,n
			       do 160 j=i,n
			       sm=0.d0
				    do 150 l=j,n
  150				    sm=sm+a(i,l)*dble(a(j,l))
  160			       a(i,j)=sm
c    ..
c     the upper triangular part of the
c     symmetric matrix (a**t*a)**(-1) has
c     replaced the upper triangular part of
c     the a array.
		     write (6,200) (i,b(i),i=1,n)
		     write (6,190) srsmsq
		     write (6,210)
			  do 170 i=1,n
  170			  write (6,220) (i,j,a(i,j),j=i,n)
  180		     continue
      stop
  190 format (1h0,8x,17hresidual length =,e12.4)
  200 format (1h0,8x,34hestimated parameters,  x=a**(+)*b,,22h computed
     1by 'hft,hs1'//(9x,i6,e16.8,i6,e16.8,i6,e16.8,i6,e16.8,i6,e16.8))
  210 format (1h0,8x,31hcovariance matrix (unscaled) of,22h estimated pa
     1rameters.,19h computed by 'cov'./1x)
  220 format (9x,2i3,e16.8,2i3,e16.8,2i3,e16.8,2i3,e16.8,2i3,e16.8)
  230 format (52h1 prog1.    this program demonstrates the algorithms,19
     1h hft, hs1, and cov.//40h caution.. 'prog1' does no checking for ,
     252hnear rank deficient matrices.  results in such cases,20h may be
     3 meaningless.,/34h such cases are handled by 'prog2',11h or 'pro
     4')
  240 format (1h0,54hthe relative noise level of the generated data will
     1 be,e16.4)
  250 format (1h0////9h0   m   n/1x,2i4)
  260 format (1h0,8x,36h******  terminating this case due to,37h a divis
     1or being exactly zero. ******)
      end


!*****************************************************************************************
!>
!  Comparison of the JPL ephemeris with the simple analytic version.

    program ephemeris_comparison

    use fortran_astrodynamics_toolkit

    implicit none

    real(wp)              :: jd
    real(wp)              :: jd0
    real(wp),dimension(6) :: rv
    real(wp),dimension(3) :: r_s,v_s
    real(wp)              :: max_err_s,err_s
    integer               :: ntarg,nctr
    type(jpl_ephemeris)   :: eph405
    logical               :: status_ok
    integer               :: i
    integer               :: jd_start, jd_end

    character(len=*),parameter :: ephemeris_file_405 = '../eph/JPLEPH.405' !! JPL DE405 ephemeris file

    write(*,*) ''
    write(*,*) '---------------'
    write(*,*) ' ephemeris_comparison'
    write(*,*) '---------------'
    write(*,*) ''

    !initialize:
    call eph405%initialize(filename=ephemeris_file_405,status_ok=status_ok)

    if (status_ok) then

        ntarg = 10     ! moon
        nctr  = 3      ! earth

        max_err_s = zero
        jd_start  = julian_day(2016,1,1)
        jd_end    = julian_day(2050,1,1)

        do i = jd_start, jd_end

            jd = real(i,wp)

            call eph405%get_state(jd, ntarg, nctr, rv, status_ok)
            if (.not.status_ok) error stop 'error computing state.'

            call simpson_lunar_ephemeris(jd, r_s, v_s)

            if (i==jd_end) then
                write(*,'(A,1X,F15.2)') 'Position of Moon wrt Earth at jd=',jd
                write(*,'(A,1X,*(F25.16,1X))') 'DE405', rv(1:3), rv(4:6)
                write(*,'(A,1X,*(F25.16,1X))') 'SIMPS', r_s, v_s
                write(*,'(A,1X,*(F25.16,1X))') 'DE405-SIMPS ', &
                            norm2(rv(1:3) - r_s), norm2(rv(4:6) - v_s)
            end if

            err_s = norm2(rv(1:3) - r_s)

            if (err_s > max_err_s) max_err_s = err_s

        end do
        call eph405%close()

        write(*,*) 'max errors:'
        write(*,'(A,1X,*(F25.16,1X))') 'DE405-SIMPS ', max_err_s

    else
        write(*,*) 'Error opening DE405 ephemeris file'
    end if

!*****************************************************************************************
    end program ephemeris_comparison
!*****************************************************************************************


      SUBROUTINE CLAGGE_F95( A, KL, KU, D, ISEED, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!     .. "Use Statements" ..
      USE LA_PRECISION, ONLY: WP => SP
      USE LA_AUXMOD, ONLY: ERINFO
      USE F77_LAPACK, ONLY: LAGGE_F77 => LA_LAGGE
!     .. "Implicit Statement" ..
      IMPLICIT NONE
!     .. "Scalar Arguments" ..
      INTEGER, INTENT(IN), OPTIONAL :: KL, KU
      INTEGER, INTENT(OUT), OPTIONAL :: INFO
!     .. "Array Arguments" ..
      INTEGER, INTENT(INOUT), OPTIONAL, TARGET :: ISEED(4)
      REAL(WP), INTENT(IN), OPTIONAL, TARGET :: D(:)
      COMPLEX(WP), INTENT(OUT) :: A(:,:)
!-----------------------------------------------------------------
!
!  Purpose
!  =======
!
!  LA_LAGGE generates a real general m by n matrix A, by pre- and post-
!  multiplying a real diagonal matrix D with random orthogonal matrices:
!  A = U*D*V. The lower and upper bandwidths may then be reduced to
!  kl and ku by additional orthogonal transformations.
!
!  Arguments
!  =========
!
!  SUBROUTINE LA_LAGGE( A, KL, KU, D, ISEED, INFO )
!     <type>(<wp>), INTENT(OUT) :: A(:,:)
!     INTEGER, INTENT(IN), OPTIONAL :: KL, KU
!     REAL(<wp>), INTENT(IN), OPTIONAL, TARGET :: D(:)
!     INTEGER, INTENT(INOUT), OPTIONAL :: ISEED(4)
!     INTEGER, INTENT(OUT), OPTIONAL :: INFO
!     <type> ::= REAL | COMPLEX
!     <wp>   ::= KIND(1.0) | KIND(1.0D0)
!
!  =====================
!
!  A       (output) REAL array, shape (:,:), SIZE(A,1) == m,
!          SIZE(A,2) == n.
!          The generated m by n matrix A.
!
!  KL      (input) INTEGER
!          The number of nonzero subdiagonals within the band of A.
!          0 <= KL <= M-1.
!
!  KU      (input) INTEGER
!          The number of nonzero superdiagonals within the band of A.
!          0 <= KU <= N-1.
!
!  D       (input) REAL array, dimension (min(M,N))
!          The diagonal elements of the diagonal matrix D.
!
!  ISEED   Optional (input/output) INTEGER array, shape (:),
!          SIZE(ISEED) == 4.
!          On entry, the seed of the random number generator; the array
!          elements must be between 0 and 4095, and ISEED(4) must be
!          odd.
!          On exit, the seed is updated.
!
!  INFO    (output) INTEGER
!          = 0: successful exit
!          < 0: if INFO = -i, the i-th argument had an illegal value
!      If INFO is not present and an error occurs, then the program is
!         terminated with an error message.
!
!  ---------------------------------------------------------------------
!     .. "Parameters" ..
      CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_LAGGE'
!     .. "LOCAL Scalars" ..
      INTEGER :: ISTAT, ISTAT1, LDA, LINFO, LKL, LKU, M, MN, N, SD, SISEED
!     .. "Local Arrays" ..
      INTEGER :: LISEED(4)
!     .. "Local Pointers" ..
      REAL(WP), POINTER :: LD(:)
      COMPLEX(WP), POINTER :: WORK(:)
!     .. "Intrinsic Functions" ..
      INTRINSIC SIZE, PRESENT, MAX, MIN
!     .. "Executable Statements" ..
      LINFO = 0; M = SIZE(A,1); N = SIZE(A,2); LDA = MAX(1,M)
      MN = MIN(M,N); ISTAT = 0
      IF( PRESENT(KL) )THEN; LKL = KL; ELSE; LKL = M-1; ENDIF
      IF( PRESENT(KU) )THEN; LKU = KU; ELSE; LKU = M-1; ENDIF
      IF( PRESENT(D) )THEN; SD = SIZE(D); ELSE; SD = MN; ENDIF
      IF( PRESENT(ISEED) )THEN; SISEED = SIZE(ISEED); LISEED = ISEED
      ELSE; SISEED = 4
            LISEED(1) = 15; LISEED(2) = 1926
            LISEED(3) = 16; LISEED(4) = 1931; ENDIF
!     .. "Test the arguments" ..
      IF( M < 0 .OR. N < 0 )THEN; LINFO = -1
      ELSE IF( LKL < 0 .OR. LKL > M-1 )THEN; LINFO = -2
      ELSE IF( LKU < 0 .OR. LKU > N-1 )THEN; LINFO = -3
      ELSE IF( SD /= MN )THEN; LINFO = -4
      ELSE IF( SISEED /= 4 .OR. PRESENT(ISEED) .AND. (                  &
     &   ( LISEED(1) < 0 .OR. LISEED(1) > 4095 ) .OR.                   &
     &   ( LISEED(2) < 0 .OR. LISEED(2) > 4095 ) .OR.                   &
     &   ( LISEED(3) < 0 .OR. LISEED(3) > 4095 ) .OR.                   &
     &   ( LISEED(4) < 0 .OR. LISEED(4) > 4095 ) .OR.                   &
     &   ( MOD( LISEED(4), 2 ) == 0 ) ) )THEN; LINFO = -5
      ELSE
         IF( PRESENT(D) )THEN; LD => D
         ELSE; ALLOCATE( LD( MN ), STAT=ISTAT); ENDIF
         IF( ISTAT == 0 )THEN
            ALLOCATE( WORK( M + N ), STAT=ISTAT )
            IF( ISTAT == 0 )THEN
               IF( .NOT. PRESENT(D) )THEN
                  LD(1:MN-1) = 1.0_WP; LD(MN) = 0.5_WP; ENDIF
               CALL LAGGE_F77( M, N, LKL, LKU, LD, A, LDA, LISEED, WORK, LINFO )
               IF( PRESENT(ISEED) )ISEED = LISEED
            ELSE; LINFO = -100; END IF
            DEALLOCATE( WORK, STAT=ISTAT1 )
         ENDIF
         IF( .NOT. PRESENT(D) )DEALLOCATE( LD, STAT=ISTAT1)
      ENDIF
      CALL ERINFO( LINFO, SRNAME, INFO, ISTAT )
      END SUBROUTINE CLAGGE_F95


! Simplified calling sequence for lapack solver using existing LU decomposing (DGETRF)
function ZLUS(A,P,f) result(x)
    implicit none
    complex(kind=8), intent(in)    :: A(:,:)
    complex(kind=8), intent(in)    :: f(size(A,1))
    complex(kind=8), allocatable   :: x(:)
    integer, intent(in)         :: P(size(A,1))
    integer                     :: info,n

    n = size(A,1)
    allocate(x(n))
    x = f;
    call ZGETRS('N',n,1,A,n,P,x,n,INFO)  !http://www.netlib.no/netlib/lapack/complex16/zgetrs.f
end function ZLUS


      SUBROUTINE BCKMLT(A,U,N,NA,NU)
C
C   PURPOSE:
C      Compute the orthogonal matrix that reduces the output matrix A
C      from subroutine HSHLDR, to upper Hessenberg form.
C
C   REFERENCES:
C      Bartels, R.H.; and Stewart, G.W.: Algorithm 432 - Solution of
C        the Matrix Equation AX + XB = C.  Commun. ACM, vol. 15, no. 9,
C        Sept. 1972, pp. 820-826.
C
C   Subroutines employed by BCKMLT: None
C   Subroutines employing BCKMLT: ATXPXA, AXPXB
C
      IMPLICIT REAL*8 (A-H,O-Z)
      REAL*8
     1A(NA,1),U(NU,1),SUM,P
      INTEGER
     1N,NA,N1,NM1,NM2,LL,L,L1,I,J
      N1 = N+1
      NM1 = N-1
      NM2 = N-2
      U(N,N) = 1.
      IF(NM1 .EQ. 0) RETURN
      U(NM1,N) = 0.
      U(N,NM1) = 0.
      U(NM1,NM1) = 1.
      IF(NM2 .EQ. 0) RETURN
      DO 40 LL=1,NM2
        L = NM2-LL+1
        L1 = L+1
        IF(A(N1,L) .EQ. 0.) GO TO 25
        DO 20 J=L1,N
          SUM = 0.
          DO 10 I=L1,N
            SUM = SUM + A(I,L)*U(I,J)
   10     CONTINUE
          P = SUM/A(N1,L)
          DO 20 I=L1,N
            U(I,J) = U(I,J) - A(I,L)*P
   20   CONTINUE
   25   DO 30 I=L1,N
          U(I,L) = 0.
          U(L,I) = 0.
   30   CONTINUE
        U(L,L) = 1.
   40 CONTINUE
      RETURN
      END


!-----------------------------------------------------------------------
! Fortran Library GPU Tutorial
! written by Viktor K. Decyk, UCLA
      module transpose
      implicit none
!
      contains
!
      subroutine transpose0(a,b)
! simple 2d transpose of length nx, ny
! a = transpose(b)
      implicit none
      real, dimension(:,:) :: a, b
! local data
      integer :: j, k, nx, ny
! nx/ny = size of arrays in x/y
      nx = min(size(a,2),size(b,1)); ny = min(size(a,1),size(b,2))
!
      do k = 1, ny
         do j = 1, nx
            a(k,j) = b(j,k)
         enddo
      enddo
!
      end subroutine
!
      subroutine transpose2(a,b,mx,my)
! segmented 2d transpose of length nx, ny, with block size mx, my
! a = transpose(b)
      implicit none
      integer :: mx, my
      real, dimension(:,:) :: a, b
! local data
      integer :: j, k, nx, ny, idx, idy, joff, koff, nbx, nby
! scratch fast, local array
      real, dimension(mx+1,my) :: s
! nx/ny = size of arrays in x/y
      nx = min(size(a,2),size(b,1)); ny = min(size(a,1),size(b,2))
! nbx/nby = number of blocks in x/y
      nbx = (nx - 1)/mx + 1; nby = (ny - 1)/my + 1
!
      do idy = 0, nby-1
         koff = my*idy
         do idx = 0, nbx-1
            joff = mx*idx
!
! copy in from slow memory with stride 1 into block of fast memory
            do k = 1, min(my,ny-koff)
               do j = 1, min(mx,nx-joff)
                  s(j,k) = b(j+joff,k+koff)
               enddo
            enddo
!
! copy out to slow memory with stride 1 from block of fast memory
            do j = 1, min(mx,nx-joff)
               do k = 1, min(my,ny-koff)
                  a(k+koff,j+joff) = s(j,k)
               enddo
            enddo
!
         enddo
      enddo
!
      end subroutine
!
      end module


C     LAST UPDATE 16/03/89
C+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C
      SUBROUTINE WINDO
      IMPLICIT NONE
C
C PURPOSE: Create a contrast transfer function in 2D from 1D file
C
      INCLUDE 'COMMON.FOR'
C
C Calls   9: WFRAME , GETHDR , IMSIZE , OUTFIL , FILL
C            IMDISP , RFRAME , OPNNEW , OPNFIL
C Called by: BSL
C
C-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-+-
C LOCAL VARIABLES:
C
      REAL         VALUE(10),X,Y,RADIUS
      INTEGER      IRC,IFRAME,IHFMAX,IFRMAX,NPIX,NRAST,NFRAME,IMEM
      INTEGER      KPIC,ISPEC,LSPEC,MEM,IFFR,ILFR,INCR,IFINC,NVAL
      INTEGER      I,J,K,L,M,NCHAN,ICENTX,ICENTY
      CHARACTER*80 HEAD1,HEAD2
      CHARACTER*13 HFNAM,OFNAM,MFNAM
C
C IRC    : Return code
C IFRAME : Total nos. of frames
C IFRMAX : Nos. of frames in sequence
C IHFMAX : Nos. of header file in sequence
C ISPEC  : First header file of sequence
C LSPEC  : Last header file in sequence
C MEM    : Positional or calibration data indicator
C IFFR   : First frame in sequence
C ILFR   : Last frame in sequence
C INCR   : Header file increment
C IFINC  : Frame increment
C HFNAM  : Header filename
C OFNAM  : Output header filename
C HEAD1  : Output header record 1
C HEAD2  : Output header record 2
C IMEM   : Output memory dataset
C NPIX   : Nos. of pixels in image
C NRAST  : Nos. of rasters in image
C NFRAME : Nos. of frames in dataset
C KPIC   : Current image nos.
C NVAL   : Nos. of values entered at terminal
C
      DATA  IMEM/1/
C
C-----------------------------------------------------------------------
10    KPIC=0
C
      WRITE (IPRINT,*) '1D Tukey window'
      CALL GETHDR (ITERM,IPRINT,IUNIT,HFNAM,ISPEC,LSPEC,INCR,MEM,IFFR,
     &             ILFR,IFINC,IHFMAX,IFRMAX,NCHAN,NRAST,IRC)
      IF (IRC.NE.0) GOTO 999
C
      CALL OPNFIL (JUNIT,HFNAM,ISPEC,MEM,IFFR,ILFR,NCHAN,NRAST,
     &             NFRAME,IRC)
      IF (IRC.NE.0) GOTO 80
      CALL RFRAME (JUNIT,IFFR,NCHAN,NRAST,SP1,IRC)
      IF (IRC.NE.0) GOTO 80
      CALL FCLOSE (JUNIT)
C
C========GET HEADER & BINARY FILE ATTRIBUTES
C
      CALL GETHDR (ITERM,IPRINT,IUNIT,HFNAM,ISPEC,LSPEC,INCR,MEM,IFFR,
     &             ILFR,IFINC,IHFMAX,IFRMAX,NPIX,NRAST,IRC)
      IF (IRC.NE.0) GOTO 999
      IFRAME=IHFMAX+IFRMAX-1
C
C========FIND X,Y COORDINATES FOR CENTRE OF POLAR COORDINATES
C
      ICENTX=NPIX/2
      ICENTY=NRAST/2
20    WRITE (IPRINT,1000) ICENTX,ICENTY
      CALL GETVAL (ITERM,VALUE,NVAL,IRC)
      IF (IRC.EQ.1) GOTO 10
      IF (IRC.EQ.2) GOTO 20
      IF (NVAL.GT.0) ICENTX=VALUE(1)
      IF (NVAL.GT.1) ICENTY=VALUE(2)
C
      DO 70 I=1,IHFMAX
         CALL OPNFIL (JUNIT,HFNAM,ISPEC,MEM,IFFR,ILFR,NPIX,NRAST,
     &                NFRAME,IRC)
         IF (IRC.EQ.0) THEN
C
            ISPEC=ISPEC+INCR
            DO 60 J=1,IFRMAX
               CALL RFRAME (JUNIT,IFFR,NPIX,NRAST,SP2,IRC)
               IF (IRC.NE.0) GOTO 80
               IFFR=IFFR+IFINC
               KPIC=KPIC+1
               CALL FILL (SP3,NPIX*NRAST,0.0)
               DO 40 K=1,NRAST
                  M=(K-1)*NPIX
                  DO 30 L=1,NPIX
                     Y=L-ICENTY-0.5
                     X=K-ICENTX-0.5

                     RADIUS=SQRT(X*X+Y*Y)
                     IF (INT(RADIUS).GT.NCHAN) THEN
                        SP3(M+L)=0.0
                     ELSE
                        SP3(M+L)=SP1(INT(RADIUS)+1)
                     ENDIF
30                CONTINUE
40             CONTINUE
               DO 50 K=1,NRAST*NPIX
                  SP2(K)=SP2(K)*SP3(K)
50             CONTINUE
C
               IF (IFRAME.EQ.1) CALL IMDISP(ITERM,IPRINT,SP2,NPIX,NRAST)
               IF (KPIC.EQ.1) THEN
                  WRITE (IPRINT,*) 'Windowed data'
                  CALL OUTFIL (ITERM,IPRINT,OFNAM,HEAD1,HEAD2,IRC)
                  IF (IRC.NE.0) GOTO 80
                  CALL OPNNEW (KUNIT,NPIX,NRAST,IFRAME,OFNAM,IMEM,HEAD1,
     &                         HEAD2,IRC)
                  IF (IRC.NE.0) GOTO 80
               ENDIF
               CALL WFRAME (KUNIT,KPIC,NPIX,NRAST,SP2,IRC)
               IF (IRC.NE.0) GOTO 80
C
               IF (KPIC.EQ.1) THEN
                  WRITE (IPRINT,*) 'Window mask'
                  CALL OUTFIL (ITERM,IPRINT,MFNAM,HEAD1,HEAD2,IRC)
                  IF (IRC.NE.0) GOTO 80
                  CALL OPNNEW (LUNIT,NPIX,NRAST,IFRAME,MFNAM,IMEM,HEAD1,
     &                         HEAD2,IRC)
                  IF (IRC.NE.0) GOTO 80
               ENDIF
               CALL WFRAME (LUNIT,KPIC,NPIX,NRAST,SP3,IRC)
               IF (IRC.NE.0) GOTO 80
60          CONTINUE
            CALL FCLOSE (JUNIT)
         ENDIF
70    CONTINUE
80    CALL FCLOSE (KUNIT)
      CALL FCLOSE (LUNIT)
      CALL FCLOSE (JUNIT)
      GOTO 10
999   RETURN
C
1000  FORMAT (' Enter x,y coordinate for rotation centre of 1D window',
     &        ' [',I4,',',I4,'] : ',$)
      END


           program demo_min
           implicit none
           write(*,*)min(10.0,11.0,30.0,-100.0)
           end program demo_min


! THIS VERSION: GALAHAD 2.1 - 22/03/2007 AT 09:00 GMT.

!-*-*-*-*-*-*-*-*-*-  G A L A H A D _ L S Q P    M O D U L E  -*-*-*-*-*-*-*-*-

!  Copyright reserved, Gould/Orban/Toint, for GALAHAD productions
!  Principal author: Nick Gould

!  History -
!   started life (quadratic roots) in GALAHAD_LSQP ~ 2000
!   released with GALAHAD Version 2.0. April 27th 2005

!  For full documentation, see
!   http://galahad.rl.ac.uk/galahad-www/specs.html

   MODULE GALAHAD_ROOTS_double

!     ---------------------------------------------------
!     |                                                 |
!     |  Find all the real roots of quadratic, cubic    |
!     |  and quartic polynomials with real coefficients |
!     |                                                 |
!     ---------------------------------------------------

      IMPLICIT NONE

      PRIVATE
      PUBLIC :: ROOTS_solve, ROOTS_quadratic, ROOTS_cubic, ROOTS_quartic

!--------------------
!   P r e c i s i o n
!--------------------

      INTEGER, PARAMETER :: wp = KIND( 1.0D+0 )

!------------------------------------
!   G e n e r i c   I n t e r f a c e
!------------------------------------

!     INTERFACE ROOTS_solve
!       MODULE PROCEDURE ROOTS_quadratic, ROOTS_cubic, ROOTS_quartic
!     END INTERFACE ROOTS_solve

!----------------------
!   P a r a m e t e r s
!----------------------

      REAL ( KIND = wp ), PARAMETER :: zero = 0.0_wp
      REAL ( KIND = wp ), PARAMETER :: one = 1.0_wp
      REAL ( KIND = wp ), PARAMETER :: two = 2.0_wp
      REAL ( KIND = wp ), PARAMETER :: three = 3.0_wp
      REAL ( KIND = wp ), PARAMETER :: four = 4.0_wp
      REAL ( KIND = wp ), PARAMETER :: point1 = 0.1_wp
      REAL ( KIND = wp ), PARAMETER :: quarter = 0.25_wp
      REAL ( KIND = wp ), PARAMETER :: onethird = one / three
      REAL ( KIND = wp ), PARAMETER :: half = 0.5_wp
      REAL ( KIND = wp ), PARAMETER :: twothirds = two / three
!     REAL ( KIND = wp ), PARAMETER :: pi = four * ATAN( 1.0_wp )
!     REAL ( KIND = wp ), PARAMETER :: magic = twothirds * pi
      REAL ( KIND = wp ), PARAMETER :: magic = 2.0943951023931953_wp  !! 2 pi / 3
      REAL ( KIND = wp ), PARAMETER :: infinity = HUGE( one ) * point1

      INTEGER, PARAMETER :: out = 6
      LOGICAL, PARAMETER :: debug = .FALSE.
!     LOGICAL, PARAMETER :: debug = .TRUE.

   CONTAINS

!-*-*-*-*-*-*-*-   R O O T S _ s o l v e   S U B R O U T I N E   -*-*-*-*-*-*-*-

      SUBROUTINE ROOTS_solve( A, tol, nroots, ROOTS, status )

! =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

!  Find all the real roots of a real polynomial sum_i>=0 a(i) x^i of degree <= 4

! =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

!  Dummy arguments

      INTEGER, INTENT( OUT ) :: nroots, status
      REAL ( KIND = wp ), INTENT( IN ) :: tol
      REAL ( KIND = wp ), INTENT( IN ), DIMENSION( 0 : ) :: A
      REAL ( KIND = wp ), INTENT( OUT ), DIMENSION( : ) :: ROOTS

!  Local variables

      INTEGER :: degree

!  Check input details for errors and consistency

      degree = UBOUND( A, 1 )
      IF ( degree < 0 .OR. degree > 4 ) THEN
        status = - 3 ; RETURN
      ELSE IF ( UBOUND( ROOTS, 1 ) < degree ) THEN
        status = - 4 ; RETURN
      END IF

!  The data appears to be correct

      SELECT CASE( degree )

      CASE ( 0 )

!  polynomials of degree 0

        nroots = 0

      CASE ( 1 )

!  polynomials of degree 1

        IF ( A( 1 ) == zero ) THEN
          IF ( A( 1 ) == zero ) THEN
            nroots = 1
            ROOTS( 1 ) = zero
          ELSE
            nroots = 0
          END IF
        ELSE
          nroots = 1
          ROOTS( 1 ) = - A( 0 ) / A( 1 )
        END IF

      CASE ( 2 )

!  polynomials of degree 2

        CALL ROOTS_quadratic( A( 0 ), A( 1 ), A( 2 ), tol,                     &
          nroots, ROOTS( 1 ), ROOTS( 2 ) )
      CASE ( 3 )

!  polynomials of degree 3

        CALL ROOTS_cubic( A( 0 ), A( 1 ), A( 2 ), A( 3 ), tol,                 &
          nroots, ROOTS( 1 ), ROOTS( 2 ), ROOTS( 3 ) )
      CASE ( 4 )

!  polynomials of degree 4

        CALL ROOTS_quartic( A( 0 ), A( 1 ), A( 2 ), A( 3 ), A( 4 ), tol,       &
          nroots, ROOTS( 1 ), ROOTS( 2 ), ROOTS( 3 ), ROOTS( 4 ) )
      END SELECT

      status = 0
      RETURN

!  End of subroutine ROOTS_solve

      END SUBROUTINE ROOTS_solve

!-*-*-*-*-*-   R O O T S _ q u a d r a t i c  S U B R O U T I N E   -*-*-*-*-*-

      SUBROUTINE ROOTS_quadratic( a0, a1, a2, tol, nroots, root1, root2 )

! =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
!
!  Find the number and values of real roots of the quadratic equation
!
!                   a2 * x**2 + a1 * x + a0 = 0
!
!  where a0, a1 and a2 are real
!
! =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

!  Dummy arguments

      INTEGER, INTENT( OUT ) :: nroots
      REAL ( KIND = wp ), INTENT( IN ) :: a2, a1, a0, tol
      REAL ( KIND = wp ), INTENT( OUT ) :: root1, root2

!  Local variables

      REAL ( KIND = wp ) :: rhs, d

      rhs = tol * a1 * a1
      IF ( ABS( a0 * a2 ) > rhs ) THEN
        root2 = a1 * a1 - four * a2 * a0
        IF ( root2 < zero ) THEN
          nroots = 0 ; root1 = zero ; root2 = zero
        ELSE
          d = - half * ( a1 + SIGN( SQRT( root2 ), a1 ) )
          nroots = 2 ; root1 = d / a2 ; root2 = a0 / d
          IF ( root1 > root2 ) THEN
            d = root1 ; root1 = root2 ; root2 = d
          END IF
        END IF
      ELSE IF ( a2 * a2 > rhs ) THEN
        nroots = 2
        IF ( - a1 / a2 > zero ) THEN
          root1 = zero ; root2 = - a1 / a2
        ELSE
          root1 = - a1 / a2 ; root2 = zero
        END IF
      ELSE IF ( a2 == zero .AND. a1 == zero ) THEN
        IF ( a0 == zero ) THEN
          nroots = 1 ; root1 = zero ; root2 = zero
        ELSE
          nroots = 0 ; root1 = zero ; root2 = zero
        END IF
      ELSE IF ( a0 * a0 > rhs ) THEN
        nroots = 1 ; root1 = - a0 / a1 ; root2 = zero
      ELSE
        nroots = 1 ; root1 = zero ; root2 = zero
      END IF
      RETURN

!  End of subroutine ROOTS_quadratic

      END SUBROUTINE ROOTS_quadratic

!-*-*-*-*-*-*-*-   R O O T S _ c u b i c  S U B R O U T I N E   -*-*-*-*-*-*-*-

      SUBROUTINE ROOTS_cubic( a0, a1, a2, a3, tol, nroots, root1, root2, root3 )

! =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
!
!  Find the number and values of real roots of the cubicc equation
!
!                a3 * x**3 + a2 * x**2 + a1 * x + a0 = 0
!
!  where a0, a1, a2 and a3 are real
!
! =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

!  Dummy arguments

      INTEGER, INTENT( OUT ) :: nroots
      REAL ( KIND = wp ), INTENT( IN ) :: a3, a2, a1, a0, tol
      REAL ( KIND = wp ), INTENT( OUT ) :: root1, root2, root3

!  Local variables

      REAL ( KIND = wp ) :: a, b, c, e, f, x, y, z
      REAL ( KIND = wp ) :: c0, c1, c2, b0, b1, p, pprime

!  Check to see if the quartic is actually a cubic

      IF ( a3 == zero ) THEN
        CALL ROOTS_quadratic( a0, a1, a2, tol, nroots, root1, root2 )
        root3 = infinity
        RETURN
      END IF

!  Deflate the polnomial if the trailing coefficient is zero

      IF ( a0 == zero ) THEN
        root1 = zero
        CALL ROOTS_quadratic( a1, a2, a3, tol, nroots, root2, root3 )
        nroots = nroots + 1
        RETURN
      END IF

!  Use Littlewood's method

!  The cubic is general

      c2 = a2 / ( three * a3 )
      c1 = a1 / ( three * a3 )
      c0 = a0 / a3
      x = c1 - c2 * c2
      y = c0 - c2 * ( x + x + c1 )
      z = four * x ** 3 + y ** 2
      IF ( z < zero ) THEN
        root1 = - two * SQRT( - x )
        y = y / ( root1 * x )
        x = root1
        y = ATAN2( SQRT( one - y ), SQRT( one + y  ) ) * twothirds
        IF ( c2 < zero ) y = y + magic
        root1 = x * COS( y ) - c2
      ELSE
        a = SQRT( z )
        b = half * ( ABS( y ) + a )
        c = b ** onethird

        IF ( c <= zero ) THEN
          root1 = - c2
          root2 = - c2
          root3 = - c2
          nroots = 3
          GO TO 900
        END IF

        c = c - ( c ** 3 - b ) / ( three * c * c )
        e = c * c + ABS( x )
        f = one/ ( ( x / c ) ** 2 + e )

        IF ( x >= zero ) THEN
          x = e / c
          z = y * f
        ELSE
          x = a * f
          z = SIGN( one, y ) * e / c
        END IF

!   There is one real root

        IF ( z * c2 < zero ) THEN
          nroots = 1
          root2 = half * z - c2
          root3 = half * SQRT( three ) * ABS( x )
          root1 = - c0 / ( root2 * root2 + root3 * root3 )
          GO TO 900
        END IF
        root1 = - z - c2
      END IF

!  Deflate cubic from optimal end

      b0 = - c0 / root1
      IF ( ABS( root1 ** 3 ) <= ABS( c0 ) ) THEN
        b1 = root1 + three * c2
      ELSE
        b1 = ( b0 - three * c1 ) / root1
      END IF

      x = b1 * b1 - four * b0

!  There are three real roots.

      IF ( x >= zero ) THEN
        root3 = - SIGN( half, b1 ) * ( SQRT( x ) + ABS( b1 ) )
        IF ( root3 /= zero ) THEN
          root2 = b0 / root3
        ELSE
          root2 = zero
        END IF

!  Reorder the roots

        IF ( root1 > root2 ) THEN
          a = root2
          root2 = root1
          root1 = a
        END IF

        IF ( root2 > root3 ) THEN
          a = root3
          IF ( root1 > root3 ) THEN
            a = root1
            root1 = root3
          END IF
          root3 = root2
          root2 = a
        END IF
        nroots = 3

!   There is one real root

      ELSE
        root2 = - half * b1
        root3 = half * SQRT( - x )
        nroots = 1
      END IF

  900 CONTINUE

!  Perfom a Newton iteration to ensure that the roots are accurate

      IF ( debug ) THEN
        IF ( nroots == 1 ) THEN
          WRITE( out, "( ' 1 real root ' )" )
        ELSE
          WRITE( out, "( ' 3 real roots ' )" )
        END IF
      END IF

      p = ( ( a3 * root1 + a2 ) * root1 + a1 ) * root1 + a0
      pprime = ( three * a3 * root1 + two * a2 ) * root1 + a1
      IF ( pprime /= zero ) THEN
        IF ( debug ) WRITE( out, 2000 ) 1, root1, p, - p / pprime
        root1 = root1 - p / pprime
        p = ( ( a3 * root1 + a2 ) * root1 + a1 ) * root1 + a0
      END IF
      IF ( debug ) WRITE( out, 2010 ) 1, root1, p

      IF ( nroots == 3 ) THEN
        p = ( ( a3 * root2 + a2 ) * root2 + a1 ) * root2 + a0
        pprime = ( three * a3 * root2 + two * a2 ) * root2 + a1
        IF ( pprime /= zero ) THEN
          IF ( debug ) WRITE( out, 2000 ) 2, root2, p, - p / pprime
          root2 = root2 - p / pprime
          p = ( ( a3 * root2 + a2 ) * root2 + a1 ) * root2 + a0
        END IF
        IF ( debug ) WRITE( out, 2010 ) 2, root2, p

        p = ( ( a3 * root3 + a2 ) * root3 + a1 ) * root3 + a0
        pprime = ( three * a3 * root3 + two * a2 ) * root3 + a1
        IF ( pprime /= zero ) THEN
          IF ( debug ) WRITE( out, 2000 ) 3, root3, p, - p / pprime
          root3 = root3 - p / pprime
          p = ( ( a3 * root3 + a2 ) * root3 + a1 ) * root3 + a0
        END IF
        IF ( debug ) WRITE( out, 2010 ) 3, root3, p
      END IF

      RETURN

!  Non-executable statements

 2000 FORMAT( ' root ', I1, ': value = ', ES12.4, ' cubic = ', ES12.4,         &
              ' delta = ', ES12.4 )
 2010 FORMAT( ' root ', I1, ': value = ', ES12.4, ' cubic = ', ES12.4 )

!  End of subroutine ROOTS_cubic

      END SUBROUTINE ROOTS_cubic

!-*-*-*-*-*-*-   R O O T S _ q u a r t i c   S U B R O U T I N E   -*-*-*-*-*-*-

      SUBROUTINE ROOTS_quartic( a0, a1, a2, a3, a4, tol, nroots, root1, root2, &
                                root3, root4 )

! =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-
!
!  Find the number and values of real roots of the quartic equation
!
!        a4 * x**4 + a3 * x**3 + a2 * x**2 + a1 * x + a0 = 0
!
!  where a0, a1, a2, a3 and a4 are real
!
! =-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-=-

!  Dummy arguments

      INTEGER, INTENT( OUT ) :: nroots
      REAL ( KIND = wp ), INTENT( IN ) :: a4, a3, a2, a1, a0, tol
      REAL ( KIND = wp ), INTENT( OUT ) :: root1, root2, root3, root4

!  Local variables

      INTEGER :: type_roots, nrootsc
      REAL ( KIND = wp ) :: a, alpha, b, beta, c, d, delta, gamma, r
      REAL ( KIND = wp ) :: x1, xm, xmd, xn, xnd
      REAL ( KIND = wp ) :: d3, d2, d1, d0, b4, b3, b2, b1
      REAL ( KIND = wp ) :: rootc1, rootc2, rootc3, p, pprime

!  Check to see if the quartic is actually a cubic

      IF ( a4 == zero ) THEN
        CALL ROOTS_cubic( a0, a1, a2, a3, tol, nroots, root1, root2, root3 )
        root4 = infinity
        RETURN
      END IF

!  Use Ferrari's algorithm

!  Initialize

      nroots = 0
      b1 = a3 / a4
      b2 = a2 / a4
      b3 = a1 / a4
      b4 = a0 / a4
      d3 = one
      d2 =  - b2
      d1 = b1 * b3 - four * b4
      d0 = b4 * ( four * b2 - b1 * b1 ) - b3 * b3

!  Compute the roots of the auxiliary cubic

      CALL ROOTS_cubic( d0, d1, d2, d3, tol, nrootsc, rootc1, rootc2, rootc3 )
      IF ( nrootsc > 1 ) rootc1 = rootc3
      x1 = b1 * b1 * quarter - b2 + rootc1
      IF ( x1 < zero ) THEN
        xmd = SQRT( - x1 )
        xnd = quarter * ( two * b3 - b1 * rootc1 ) / xmd
        alpha = half * b1 * b1 - rootc1 - b2
        beta = four * xnd - b1 * xmd
        r = SQRT( alpha * alpha + beta * beta )
        gamma = SQRT( half * ( alpha + r ) )
        IF ( gamma == zero ) THEN
          delta = SQRT( - alpha )
        ELSE
          delta = beta * half / gamma
        END IF
        root1 = half * ( - half * b1 + gamma )
        root2 = half * ( xmd + delta )
        root3 = half * ( - half * b1 - gamma )
        root4 = half * ( xmd - delta )
        GO TO 900
      END IF
      IF ( x1 /= zero ) THEN
        xm = SQRT( x1 )
        xn = quarter * ( b1 * rootc1 - two * b3 ) / xm
      ELSE
        xm = zero
        xn = SQRT( quarter * rootc1 * rootc1 - b4 )
      END IF
      alpha = half * b1 * b1 - rootc1 - b2
      beta = four * xn - b1 * xm
      gamma = alpha + beta
      delta = alpha - beta
      a = - half * b1

!  Compute how many real roots there are

      type_roots = 1
      IF ( gamma >= zero ) THEN
        nroots = nroots + 2
        type_roots = 0
        gamma = SQRT( gamma )
      ELSE
        gamma = SQRT( - gamma )
      END IF
      IF ( delta >= zero ) THEN
        nroots = nroots + 2
        delta = SQRT( delta )
      ELSE
        delta = SQRT( - delta )
      END IF
      type_roots = nroots + type_roots

!  Two real roots

      IF ( type_roots == 3 ) THEN
        root1 = half * ( a - xm - delta )
        root2 = half * ( a - xm + delta )
        root3 = half * ( a + xm )
        root4 = half * gamma
        GO TO 900
      ELSE IF ( type_roots /= 4 ) THEN
        IF ( type_roots == 2 ) THEN
          root1 = half * ( a + xm - gamma )
          root2 = half * ( a + xm + gamma )
        ELSE

!  No real roots

          root1 = half * ( a + xm )
          root2 = half * gamma
        END IF
        root3 = half * ( a - xm ) * half
        root4 = half * delta
        GO TO 900
      END IF

!  Four real roots

      b = half * ( a + xm + gamma )
      d = half * ( a - xm + delta )
      c = half * ( a - xm - delta )
      a = half * ( a + xm - gamma )

!  Sort the roots

      root1 = MIN( a, b, c, d )
      root4 = MAX( a, b, c, d )

      IF ( a == root1 ) THEN
        root2 = MIN( b, c, d )
      ELSE IF ( b == root1 ) THEN
        root2 = MIN( a, c, d )
      ELSE IF ( c == root1 ) THEN
        root2 = MIN( a, b, d )
      ELSE
        root2 = MIN( a, b, c )
      END IF

      IF ( a == root4 ) THEN
        root3 = MAX( b, c, d )
      ELSE IF ( b == root4 ) THEN
        root3 = MAX( a, c, d )
      ELSE IF ( c == root4 ) THEN
        root3 = MAX( a, b, d )
      ELSE
        root3 = MAX( a, b, c )
      END IF

  900 CONTINUE

!  Perfom a Newton iteration to ensure that the roots are accurate

      IF ( debug ) THEN
        IF ( nroots == 0 ) THEN
          WRITE( out, "( ' no real roots ' )" )
        ELSE IF ( nroots == 2 ) THEN
          WRITE( out, "( ' 2 real roots ' )" )
        ELSE IF ( nroots == 4 ) THEN
          WRITE( out, "( ' 4 real roots ' )" )
        END IF
      END IF
      IF ( nroots == 0 ) RETURN

      p = ( ( ( a4 * root1 + a3 ) * root1 + a2 ) * root1 + a1 ) * root1 + a0
      pprime = ( ( four * a4 * root1 + three * a3 ) * root1 + two * a2 )       &
                 * root1 + a1
      IF ( pprime /= zero ) THEN
        IF ( debug ) WRITE( out, 2000 ) 1, root1, p, - p / pprime
        root1 = root1 - p / pprime
        p = ( ( ( a4 * root1 + a3 ) * root1 + a2 ) * root1 + a1 ) * root1 + a0
      END IF
      IF ( debug ) WRITE( out, 2010 ) 1, root1, p

      p = ( ( ( a4 * root2 + a3 ) * root2 + a2 ) * root2 + a1 ) * root2 + a0
      pprime = ( ( four * a4 * root2 + three * a3 ) * root2 + two * a2 )       &
                 * root2 + a1
      IF ( pprime /= zero ) THEN
        IF ( debug ) WRITE( out, 2000 ) 2, root2, p, - p / pprime
        root2 = root2 - p / pprime
        p = ( ( ( a4 * root2 + a3 ) * root2 + a2 ) * root2 + a1 ) * root2 + a0
      END IF
      IF ( debug ) WRITE( out, 2010 ) 2, root2, p

      IF ( nroots == 4 ) THEN
        p = ( ( ( a4 * root3 + a3 ) * root3 + a2 ) * root3 + a1 ) * root3 + a0
        pprime = ( ( four * a4 * root3 + three * a3 ) * root3 + two * a2 )     &
                   * root3 + a1
        IF ( pprime /= zero ) THEN
          IF ( debug ) WRITE( out, 2000 ) 3, root3, p, - p / pprime
          root3 = root3 - p / pprime
          p = ( ( ( a4 * root3 + a3 ) * root3 + a2 ) * root3 + a1 ) * root3 + a0
        END IF
        IF ( debug ) WRITE( out, 2010 ) 3, root3, p

        p = ( ( ( a4 * root4 + a3 ) * root4 + a2 ) * root4 + a1 ) * root4 + a0
        pprime = ( ( four * a4 * root4 + three * a3 ) * root4 + two * a2 )     &
                   * root4 + a1
        IF ( pprime /= zero ) THEN
          IF ( debug ) WRITE( out, 2000 ) 4, root4, p, - p / pprime
          root4 = root4 - p / pprime
          p = ( ( ( a4 * root4 + a3 ) * root4 + a2 ) * root4 + a1 ) * root4 + a0
        END IF
        IF ( debug ) WRITE( out, 2010 ) 4, root4, p
      END IF

      RETURN

!  Non-executable statements

 2000 FORMAT( ' root ', I1, ': value = ', ES12.4, ' quartic = ', ES12.4,       &
              ' delta = ', ES12.4 )
 2010 FORMAT( ' root ', I1, ': value = ', ES12.4, ' quartic = ', ES12.4 )

!  End of subroutine ROOTS_quartic

      END SUBROUTINE ROOTS_quartic

!  End of module ROOTS

   END MODULE GALAHAD_ROOTS_double


! { dg-do run )
! PR39304 write of  0.0 with F0.3 gives  **
! Test case developed from case provided by reporter.
 REAL :: x
 CHARACTER(80) :: str
 x = 0.0
 write (str,'(f0.0)') x
 if (str.ne."0.") call abort
 write (str,'(f0.1)') x
 if (str.ne."0.0") call abort
 write (str,'(f0.2)') x
 if (str.ne."0.00") call abort
 write (str,'(f0.3)') x
 if (str.ne."0.000") call abort
 write (str,'(f0.4)') x
 if (str.ne."0.0000") call abort
 END


subroutine sub3(x)
real :: x
print *, x**3
end


      double complex function A1slcqqppmp(e1,p2,p3,e4,za,zb,zab,zba)
      implicit none
C-----Authors: John Campbell and Keith Ellis, November 2011
C---- taken from arXiv:1101.5947 [hep-ph], Eq. (56)
      include 'constants.f'
      include 'masses.f'
      include 'zprods_decl.f'
      include 'sprods_com.f'
      include 'zabprods_decl.f'
      include 'epinv.f'
      include 'scale.f'
      double precision mt2,beta,xlog
      double complex BSYA0qqppmp,BSYA1slcqqppmp,Vslc,lnrat
      integer e1,p2,p3,e4
      mt2=mt**2
      beta=sqrt(1d0-4d0*mt2/s(p2,p3))
      xlog=log((1d0-beta)/(1d0+beta))/beta
c--- NB: added a minus sign in front of the double pole compared to Eq. (56)
      Vslc=-dcmplx(epinv**2)-dcmplx(epinv)*(1d0
     & +lnrat(musq,-s(p2,p3))+(1d0-2d0*mt2/s(p2,p3))*xlog)
      A1slcqqppmp=Vslc*BSYA0qqppmp(e1,p2,p3,e4,za,zb,zab,zba)
     &                +BSYA1slcqqppmp(e1,p2,p3,e4,za,zb,zab,zba)

      return
      end


  function initializeGammaData(desiredGammaFile) result(errorFlag)

! ======================================================================
!    Main routine to extract ds/do for channel 1-4 (single pion
!    production):
!
!    Written by K. K. Gudima, Fall 2003?
!    Modified by AJS, May, 2004.
!    Modified by KKG, Sep., 2004
!    Edited by AJS, January, 2005.
!    Modified by AJS, February, 2005.
!    Edited by AJS, LANL T-2, December, 2011.
!    Edited by LMK, XCP-3, July 2013 (included error protection).
!
! ======================================================================

    use, intrinsic:: iso_fortran_env, only: int32, real64, output_unit
    use photonEventGeneratorClass, only: newPhotonEventGenerator
    use standardDCMParams, only: zro, one, two, pi, radianToDegree, emnucg

    implicit none
    character(LEN=*), intent(in   ) :: desiredGammaFile
    integer(int32)                  :: errorFlag

    integer(int32) :: i, inth, inw, ith, jch
    real(real64)   :: temp

    ! Set default file name and unit
    integer(int32)    :: gammaUnit
    character(LEN=64) :: gammaFile = defaultGammaFile

    ! Assume desired file unit is used and that the file does NOT exist
    logical        :: fileExists   = .false.

    ! (for when an error occurs during reading of the file)
    integer(int32), dimension(3) :: readError = 0_int32

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

    ! Data variables (transformed based on the angle bins established)
    ! Note: The below require ~31 kB of memory when allocated

    ! Cross section for gamma + d channel
    real(real64), dimension(:, :, :), allocatable :: xsectd

    ! Energy in CM system for channel?
    real(real64), dimension(:, :), allocatable :: ecm

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

    ! Assume no error occurs
    errorFlag = sDCMDataSetup

    ! Establish angle bins
    ! (Course angle bins)
    do j = 1,19
       theta(j) = dble(j-1) * dtheta
       ctheta(j) = cos( theta(j) * radianToDegree )
       if (j > 1) domo2(j) = pi * ( ctheta(j-1) - ctheta(j) )
    enddo

    ! (Fine angle bins)
    do j = 1,181
       thetai(j) = dble(j-1) * dthetai
       cthetai(j) = cos( thetai(j) * radianToDegree )
       if (j > 1) domo2i(j) = pi * ( cthetai(j-1) - cthetai(j) )
    enddo

    ! Establish photon event generator data (based on course angle mesh)
    photonEG = newPhotonEventGenerator( theta, 19, dataIO )
    if ( .not.photonEG%properlyConstructed() ) then
       write(message, 2400)
       call dataIO(0, 2, message)
       write(message, 2500)
       call dataIO(0, 2, message)
       errorFlag = errorFlag + 1
    end if

    ! Verify file exists and can be opened with the desired file unit
    gammaFile = desiredGammaFile
100 continue

    ! File is NOT open; verify file exists.
    inquire(file = gammaFile, exist = fileExists )
    if ( fileExists ) then
       ! The file exists and an available unit exists (file can be opened)
    else
       ! File doesn't exist; look for the default (if not being used)
       write(message, 2000) gammaFile   ! Warn client that file doesn't exist; try default if not used
       call dataIO(0, 2, message)
       if ( gammaFile /= defaultGammaFile ) then
          gammaFile = defaultGammaFile
          write(message, 2100) gammaFile
          call dataIO(0, 3, message)
          go to 100
       else
          ! Could not find the file (client defined or default); return with error code
          errorFlag = sDCMGammaError
       end if
    end if
    if ( errorFlag == sDCMGammaError ) return

    ! Create photon cross section data arrays
    if (.not.allocated(gppipn)) allocate(gppipn(50, 20))
    if (.not.allocated(gppi0p)) allocate(gppi0p(50, 20))
    if (.not.allocated(elg))    allocate(   elg( 4, 50))

    ! Allocate temporary data now (deallocate later)
    if (.not.allocated(xsectd)) allocate(xsectd(4, 50, 0:18))
    if (.not.allocated(ecm)) allocate(ecm(4, 50))

    ! Read differential cross section data file:
    ! NOTE: ONLY THE FIRST 2 CHANNELS (OF 50) ARE UTILIZED HERE (see "jch" values below)
    open( newunit = gammaUnit, file = gammaFile, status = "old", action = "read" )
    do jch = 1, 2
       readError(1) = 0
       read (gammaUnit, 10, iostat = readError(1) )
       do inw = 1,50
          readError(2:3) = 0

          ! Reading data
          read (gammaUnit, 20, iostat = readError(2) ) &
               & ecm(jch,inw), (xsectd(jch,inw,inth), inth=0,4)
          read (gammaUnit, 30, iostat = readError(3) ) &
               & (xsectd(jch,inw,inth), inth=5,18)

          ! Verify no errors or End Of File (EOF) reached during read
          do i = 1, 3
             if ( readError(i) /= 0 ) then
                if ( readError(i) > 0 ) then
                   ! Unknown error during read (not all variables initialized)
                   errorFlag = sDCMGammaError
                   write(message, 2300) trim(gammaFile)
                   call dataIO(0, 2, message)
                else if ( readError(i) < 0 ) then
                   ! EOF encountered (not all variables initialized)
                   errorFlag = sDCMGammaError
                   write(message, 2350) trim(gammaFile)
                   call dataIO(0, 2, message)
                end if

                write(message, 2500)
                call dataIO(0, 2, message)
                go to 200

             end if
          end do

          ! Manipulating data and storing result
          temp = two*emnucg
          elg(jch,inw) = (ecm(jch,inw)**2 - emnucg**2)/(temp)

          ! Store channel data for the reaction:
          do ith = 1,19
             if (jch == 1) then
                !  gamma + p --> pi+ + n
                gppipn(inw,ith) = xsectd(jch,inw,ith-1)
             elseif (jch == 2) then
                !  gamma + p --> pi0 + p
                gppi0p(inw,ith) = xsectd(jch,inw,ith-1)
             endif
          end do

       end do
    end do
200 continue

    close (gammaUnit)
    return

! ======================================================================
! (for reading data file)
10  format (1x)
20  format (7x,f5.2,8x,5e10.3)
30  format (7e10.3)
! (for messages to client)
2000 format("File '", A, "' could not be found for reading in photon ", &
          & "cross section data from.")
2100 format("Attempting to use file '", A, "' for photon cross section data.")
2300 format("An unkown error was encountered when reading the photon ", &
          & "cross section data file '", A, "'.")
2350 format("Unexpected end of file reached when reading the photon ", &
          & "cross section data file '", A, "'.")
2400 format("The data for the photon event generator failed to setup.")
2500 format("   Be wary of simulation results.")
! ======================================================================
  end function initializeGammaData


      SUBROUTINE DIIS(XP, XPARAM, GP, GRAD, HP, HEAT, HS, NVAR, FRST)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      DIMENSION XP(NVAR), XPARAM(NVAR), GP(NVAR),
     1GRAD(NVAR), HS(NVAR*NVAR)
      LOGICAL FRST
************************************************************************
*                                                                      *
*     DIIS PERFORMS DIRECT INVERSION IN THE ITERATIVE SUBSPACE         *
*                                                                      *
*     THIS INVOLVES SOLVING FOR C IN XPARAM(NEW) = XPARAM' - HG'       *
*                                                                      *
*  WHERE XPARAM' = SUM(C(I)XPARAM(I), THE C COEFFICIENTES COMING FROM  *
*                                                                      *
*                   | B   1 | . | C | = | 0 |                          *
*                   | 1   0 |   |-L |   | 1 |                          *
*                                                                      *
* WHERE B(I,J) =GRAD(I)H(T)HGRAD(J)  GRAD(I) = GRADIENT ON CYCLE I     *
*                              H    = INVERSE HESSIAN                  *
*                                                                      *
*                          REFERENCE                                   *
*                                                                      *
*  P. CSASZAR, P. PULAY, J. MOL. STRUCT. (THEOCHEM), 114, 31 (1984)    *
*                                                                      *
************************************************************************
************************************************************************
*                                                                      *
*     GEOMETRY OPTIMIZATION USING THE METHOD OF DIRECT INVERSION IN    *
*     THE ITERATIVE SUBSPACE (GDIIS), COMBINED WITH THE BFGS OPTIMIZER *
*     (A VARIABLE METRIC METHOD)                                       *
*                                                                      *
*     WRITTEN BY PETER L. CUMMINS, UNIVERSITY OF SYDNEY, AUSTRALIA     *
*                                                                      *
*                              REFERENCE                               *
*                                                                      *
*      "COMPUTATIONAL STRATEGIES FOR THE OPTIMIZATION OF EQUILIBRIUM   *
*     GEOMETRIES AND TRANSITION-STATE STRUCTURES AT THE SEMIEMPIRICAL  *
*     LEVEL", PETER L. CUMMINS, JILL E. GREADY, J. COMP. CHEM., 10,    *
*     939-950 (1989).                                                  *
*                                                                      *
*     MODIFIED BY JJPS TO CONFORM TO EXISTING MOPAC CONVENTIONS        *
*                                                                      *
************************************************************************
      COMMON /KEYWRD/ KEYWRD
      PARAMETER (MRESET=15, M2=(MRESET+1)*(MRESET+1))
      DIMENSION  XSET(MRESET*MAXPAR),GSET(MRESET*MAXPAR), ESET(MRESET)
      DIMENSION DX(MAXPAR),GSAVE(MAXPAR),
     1 ERR(MRESET*MAXPAR),B(M2),BS(M2),BST(M2)
      LOGICAL DEBUG, PRINT
      CHARACTER*241 KEYWRD
      DEBUG=.FALSE.
      PRINT=(INDEX(KEYWRD,' DIIS').NE.0)
      IF (PRINT) DEBUG=(INDEX(KEYWRD,'DEBUG').NE.0)
      IF (PRINT)  WRITE(6,'(/,''      ***** BEGIN GDIIS ***** '')')
C
C  SPACE SIMPLY LOADS THE CURRENT VALUES OF XPARAM AND GNORM INTO
C  THE ARRAYS XSET AND GSET
C
      CALL SPACE(MRESET,MSET,XPARAM, GRAD, HEAT, NVAR, XSET, GSET, ESET
     1, FRST)
C
C     INITIALIZE SOME VARIABLES AND CONSTANTS
C
      NDIIS = MSET
      MPLUS = MSET + 1
      MM = MPLUS * MPLUS
C
C     COMPUTE THE APPROXIMATE ERROR VECTORS
C
      INV=-NVAR
      DO 30 I=1,MSET
         INV = INV + NVAR
         DO 30 J=1,NVAR
            S = 0.D0
            KJ=(J*(J-1))/2
            DO 10 K=1,J
               KJ = KJ+1
   10       S = S - HS(KJ) * GSET(INV+K)
            DO 20 K=J+1,NVAR
               KJ = (K*(K-1))/2+J
   20       S = S - HS(KJ) * GSET(INV+K)
   30 ERR(INV+J) = S
C
C     CONSTRUCT THE GDIIS MATRIX
C
      DO 40 I=1,MM
   40 B(I) = 1.D0
      JJ=0
      INV=-NVAR
      DO 50 I=1,MSET
         INV=INV+NVAR
         JNV=-NVAR
         DO 50 J=1,MSET
            JNV=JNV+NVAR
            JJ = JJ + 1
            B(JJ)=0.D0
            DO 50 K=1,NVAR
   50 B(JJ) = B(JJ) + ERR(INV+K) * ERR(JNV+K)
C
      DO 60 I=MSET-1,1,-1
         DO 60 J=MSET,1,-1
   60 B(I*MSET+J+I) = B(I*MSET+J)
      DO 70 I=1,MPLUS
         B(MPLUS*I) = 1.D0
   70 B(MPLUS*MSET+I) = 1.D0
      B(MM) = 0.D0
C
C     ELIMINATE ERROR VECTORS WITH THE LARGEST NORM
C
   80 CONTINUE
      DO 90 I=1,MM
   90 BS(I) = B(I)
      IF (NDIIS .EQ. MSET) GO TO 140
      DO 130 II=1,MSET-NDIIS
         XMAX = -1.D10
         ITERA = 0
         DO 110 I=1,MSET
            XNORM = 0.D0
            INV = (I-1) * MPLUS
            DO 100 J=1,MSET
  100       XNORM = XNORM + ABS(B(INV + J))
            IF (XMAX.LT.XNORM .AND. XNORM.NE.1.0D0) THEN
               XMAX = XNORM
               ITERA = I
               IONE = INV + I
            ENDIF
  110    CONTINUE
         DO 120 I=1,MPLUS
            INV = (I-1) * MPLUS
            DO 120 J=1,MPLUS
               JNV = (J-1) * MPLUS
               IF (J.EQ.ITERA) B(INV + J) = 0.D0
               B(JNV + I) = B(INV + J)
  120    CONTINUE
         B(IONE) = 1.0D0
  130 CONTINUE
  140 CONTINUE
C
      IF (DEBUG) THEN
C
C     OUTPUT THE GDIIS MATRIX
C
         WRITE(*,'(/5X,'' GDIIS MATRIX'')')
         IJ = 0
         DO 150 I=1,MPLUS
            DO 150 J=1,I
               IJ = IJ + 1
  150    BST(IJ) = B( MPLUS * (J-1) + I)
         CALL VECPRT(BST,MPLUS)
      ENDIF
C
C     SCALE DIIS MATRIX BEFORE INVERSION
C
      DO 160 I=1,MPLUS
         II = MPLUS * (I-1) + I
  160 GSAVE(I) = 1.D0 / DSQRT(1.D-20+DABS(B(II)))
      GSAVE(MPLUS) = 1.D0
      DO 170 I=1,MPLUS
         DO 170 J=1,MPLUS
            IJ = MPLUS * (I-1) + J
  170 B(IJ) = B(IJ) * GSAVE(I) * GSAVE(J)
C
      IF (DEBUG) THEN
C
C     OUTPUT SCALED GDIIS MATRIX
C
         WRITE(*,'(/5X,'' GDIIS MATRIX (SCALED)'')')
         IJ = 0
         DO 180 I=1,MPLUS
            DO 180 J=1,I
               IJ = IJ + 1
  180    BST(IJ) = B( MPLUS * (J-1) + I)
         CALL VECPRT(BST,MPLUS)
      ENDIF
C
C     INVERT THE GDIIS MATRIX
C
      CALL MINV(B,MPLUS,DET)
C
      DO 190 I=1,MPLUS
         DO 190 J=1,MPLUS
            IJ = MPLUS * (I-1) + J
  190 B(IJ) = B(IJ) * GSAVE(I) * GSAVE(J)
C
C     COMPUTE THE INTERMEDIATE INTERPOLATED PARAMETER AND GRADIENT
C     VECTORS
C
      DO 200 K=1,NVAR
         XP(K) = 0.D0
         GP(K) = 0.D0
         DO 200 I=1,MSET
            INK = (I-1) * NVAR + K
            XP(K) = XP(K) + B(MPLUS*MSET+I) * XSET(INK)
  200 GP(K) = GP(K) + B(MPLUS*MSET+I) * GSET(INK)
      HP=0.D0
      DO 210 I=1,MSET
  210 HP=HP+B(MPLUS*MSET+I)*ESET(I)
C
      DO 220 K=1,NVAR
  220 DX(K) = XPARAM(K) - XP(K)
      XNORM = SQRT(DOT(DX,DX,NVAR))
      IF (PRINT) THEN
         WRITE (6,'(/10X,''DEVIATION IN X '',F7.4,8X,''DETERMINANT '',
     1 G9.3)') XNORM,DET
         WRITE(6,'(10X,''GDIIS COEFFICIENTS'')')
         WRITE(6,'(10X,5F12.5)') (B(MPLUS*MSET+I),I=1,MSET)
      ENDIF
C
C     THE FOLLOWING TOLERENCES FOR XNORM AND DET ARE SOMEWHAT ARBITRARY!
C
      THRES = MAX(10.D0**(-NVAR), 1.D-25)
      IF (XNORM.GT.2.D0 .OR. DABS(DET).LT. THRES) THEN
         IF (PRINT) WRITE(6,'(10X,''THE DIIS MATRIX IS ILL CONDITIONED''
     1, /10X,'' - PROBABLY, VECTORS ARE LINEARLY DEPENDENT - '',
     2 /10X,''THE DIIS STEP WILL BE REPEATED WITH A SMALLER SPACE'')')
         DO 230 K=1,MM
  230    B(K) = BS(K)
         NDIIS = NDIIS - 1
         IF (NDIIS .GT. 0) GO TO 80
         IF (PRINT) WRITE(*,'(10X,''NEWTON-RAPHSON STEP TAKEN'')')
         DO 240 K=1,NVAR
            XP(K) = XPARAM(K)
  240    GP(K) = GRAD(K)
C
      ENDIF
      IF (PRINT)  WRITE(6,'(/,''      ***** END GDIIS ***** '',/)')
C
      RETURN
      END
      SUBROUTINE SPACE(MRESET, MSET, XPARAM, GRAD, HEAT, NVAR,
     1XSET, GSET, ESET, FRST)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      DIMENSION XPARAM(NVAR), GRAD(NVAR)
      DIMENSION XSET(MRESET*NVAR),GSET(MRESET*NVAR), ESET(MRESET)
      LOGICAL FRST
C
C     UPDATE PARAMETER AND GRADIENT SUBSPACE
C
      IF(FRST)THEN
         NRESET=MIN(NVAR/2,MRESET)
         FRST=.FALSE.
         MSET=0
      ENDIF
C
      IF (MSET .EQ. NRESET) THEN
         DO 10 I=1,MSET-1
            MI = NVAR*(I-1)
            NI = NVAR*I
            ESET(I)=ESET(I+1)
            DO 10 K=1,NVAR
               XSET(MI+K) = XSET(NI+K)
   10    GSET(MI+K) = GSET(NI+K)
         MSET=NRESET-1
      ENDIF
C
C     STORE THE CURRENT POINT
C
      DO 20 K=1,NVAR
         NMK = NVAR*MSET+K
         XSET(NMK) = XPARAM(K)
   20 GSET(NMK) = GRAD(K)
      MSET=MSET+1
      ESET(MSET)=HEAT
C
      RETURN
      END
      SUBROUTINE MINV(A,N,D)
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      INCLUDE 'SIZES'
      DIMENSION A(*)
**********************************************************************
*
*     INVERT A MATRIX USING GAUSS-JORDAN METHOD.  PART OF DIIS
*     A - INPUT MATRIX (MUST BE A GENERAL MATRIX), DESTROYED IN
*        COMPUTATION AND REPLACED BY RESULTANT INVERSE.
*     N - ORDER OF MATRIX A
*     D - RESULTANT DETERMINANT
*
**********************************************************************
      DIMENSION M(MAXPAR), L(MAXPAR)
C
C     SEARCH FOR LARGEST ELEMENT
C
      D=1.0D0
      NK=-N
      DO 180 K=1,N
         NK=NK+N
         L(K)=K
         M(K)=K
         KK=NK+K
         BIGA=A(KK)
         DO 20 J=K,N
            IZ=N*(J-1)
            DO 20 I=K,N
               IJ=IZ+I
   10          IF (ABS(BIGA).LT.ABS(A(IJ)))THEN
                  BIGA=A(IJ)
                  L(K)=I
                  M(K)=J
               ENDIF
   20    CONTINUE
C
C     INTERCHANGE ROWS
C
         J=L(K)
         IF (J-K) 50,50,30
   30    KI=K-N
         DO 40 I=1,N
            KI=KI+N
            HOLD=-A(KI)
            JI=KI-K+J
            A(KI)=A(JI)
   40    A(JI)=HOLD
C
C     INTERCHANGE COLUMNS
C
   50    I=M(K)
         IF (I-K) 80,80,60
   60    JP=N*(I-1)
         DO 70 J=1,N
            JK=NK+J
            JI=JP+J
            HOLD=-A(JK)
            A(JK)=A(JI)
   70    A(JI)=HOLD
C
C     DIVIDE COLUMN BY MINUS PIVOT (VALUE OF PIVOT ELEMENT IS
C     CONTAINED IN BIGA)
C
   80    IF (BIGA) 100,90,100
   90    D=0.0
         RETURN
  100    DO 120 I=1,N
            IF (I-K) 110,120,110
  110       IK=NK+I
            A(IK)=A(IK)/(-BIGA)
  120    CONTINUE
C  REDUCE MATRIX
         DO 150 I=1,N
            IK=NK+I
            HOLD=A(IK)
            IJ=I-N
            DO 150 J=1,N
               IJ=IJ+N
               IF (I-K) 130,150,130
  130          IF (J-K) 140,150,140
  140          KJ=IJ-I+K
               A(IJ)=HOLD*A(KJ)+A(IJ)
  150    CONTINUE
C
C     DIVIDE ROW BY PIVOT
C
         KJ=K-N
         DO 170 J=1,N
            KJ=KJ+N
            IF (J-K) 160,170,160
  160       A(KJ)=A(KJ)/BIGA
  170    CONTINUE
C
C     PRODUCT OF PIVOTS
C
         D=MAX(-1.D25,MIN(1.D25,D))
         D=D*BIGA
C
C     REPLACE PIVOT BY RECIPROCAL
C
         A(KK)=1.0/BIGA
  180 CONTINUE
C
C     FINAL ROW AND COLUMN INTERCHANGE
C
      K=N
  190 K=(K-1)
      IF (K) 260,260,200
  200 I=L(K)
      IF (I-K) 230,230,210
  210 JQ=N*(K-1)
      JR=N*(I-1)
      DO 220 J=1,N
         JK=JQ+J
         HOLD=A(JK)
         JI=JR+J
         A(JK)=-A(JI)
  220 A(JI)=HOLD
  230 J=M(K)
      IF (J-K) 190,190,240
  240 KI=K-N
      DO 250 I=1,N
         KI=KI+N
         HOLD=A(KI)
         JI=KI-K+J
         A(KI)=-A(JI)
  250 A(JI) =HOLD
      GO TO 190
  260 RETURN
      END


program main
    use plantFEM
    implicit none

    type(FEMDomain_) :: space
    type(Random_) :: random
    real(real64) :: center(3),dist,coord(3),direction(3)
    !　走性係数（走性/ランダム比）
    real(real64),parameter :: a=0.010d0
    integer(int32) :: i,j

    call space%create(meshtype="Cube")
    ! cm!
    call space%resize(x=5.0d0,y=5.0d0,z=3.0d0)

    call space%msh("space")

    call space%addLayer(name="nematode",attribute="Nodal",datastyle="Vector")

    !中心
    do i=1, 10

        center(1) = 2.50d0
        center(2) = 2.50d0
        center(3) = 3.00d0 - 3.0d0*dble(i-1)/10.0d0
        call random%fill(space%physicalfield(1)%Vector)
        space%physicalfield(1)%Vector(:,:) = space%physicalfield(1)%Vector(:,:) - 0.50d0

        ! ランダムに動く＋中心に向けて動く
        do j=1,space%nn()
            coord(:) = space%mesh%nodcoord(j,:)
            direction(:) = center(:) - coord(:)
            direction(:) = 1.0d0/sqrt(dot_product(direction,direction))*direction(:)*a

            space%physicalfield(1)%Vector(j,:) = space%physicalfield(1)%Vector(j,:)+direction(:)
        enddo

        ! びっくりしてうごくだけ

        !do j=1,space%nn()
        !    coord(:) = space%mesh%nodcoord(j,:)
        !    dist = sqrt(dot_product(coord-center,coord-center))
        !    if(dist==0.0d0)then
        !        space%physicalfield(1)%Vector(j,:) = 0.0d0*space%physicalfield(1)%Vector(j,:)
        !    else
        !        space%physicalfield(1)%Vector(j,:) = 1.0d0/dist*space%physicalfield(1)%Vector(j,:)
        !    endif
        !
        !enddo

        call space%msh(name="nematode",Vector=space%physicalfield(1)%Vector,step=i)
    enddo

end program main