! pde.f90
! author: sunder

!-----------------------------------------------------------------------
! Routines related to the given PDE
!-----------------------------------------------------------------------

subroutine PDECons2Prim(Q, V)
    use ader_dg, only : nVar, EQN
    implicit none
    ! Argument list
    real, intent(in)     :: Q(nVar)     ! vector of conserved quantities
    real, intent(out)    :: V(nVar)     ! primitive variables

    ! Local variables
    real                 :: p

    p = (EQN%gamma-1.0)*( Q(4) - 0.5*SUM(Q(2:3)**2)/Q(1) )    ! fluid pressure
    V(1) = Q(1)             ! fluid density
    V(2:3) = Q(2:3)/Q(1)    ! fluid velocity
    V(4)   = p              ! fluid pressure

end subroutine PDECons2Prim

!-----------------------------------------------------------------------
! Convert primitive vector to conserved vector
!-----------------------------------------------------------------------

subroutine PDEPrim2Cons(V, Q)
    use ader_dg, ONLY : nVar, EQN
    implicit none
    ! Argument list
    real, intent(in)      :: V(nVar)     ! primitive variables
    real, intent(out)     :: Q(nVar)     ! vector of conserved quantities

    Q(1)   = V(1)           ! fluid density
    Q(2:3) = V(1)*V(2:3)    ! momentum
    Q(4)   = V(4)/(EQN%GAMMA-1) + 0.5*V(1)*SUM(V(2:3)**2)   ! total energy = internal energy + kinetic energy

END subroutine PDEPrim2Cons

!-----------------------------------------------------------------------
! PDE flux tensor F(Q)
!-----------------------------------------------------------------------

subroutine PDEFlux(Q, F)
    use ader_dg, ONLY : nVar, nDim, EQN
    implicit none
    ! Argument list
    real, intent(in)  :: Q(nVar)
    real, intent(out) :: F(nVar,nDim)

    ! Local variables
    real :: p, irho

    irho = 1.0/Q(1)
    p = (EQN%GAMMA-1.0)*( Q(4) - 0.5*SUM(Q(2:3)**2)*irho )

    F(1,1) = Q(2)
    F(2,1) = irho*Q(2)*Q(2) + p
    F(3,1) = irho*Q(2)*Q(3)
    F(4,1) = irho*Q(2)*(Q(4) + p)

    F(1,2) = Q(3)
    F(2,2) = irho*Q(3)*Q(2)
    F(3,2) = irho*Q(3)*Q(3) + p
    F(4,2) = irho*Q(3)*(Q(4) + p)

end subroutine PDEFlux

!-----------------------------------------------------------------------
! Eigenvalues of the PDE in the normal direction nv
!-----------------------------------------------------------------------

subroutine PDEEigenvalues(Q, nv, Lambda)
    use ader_dg, ONLY : nVar, nDim, EQN
    implicit none
    ! Argument list
    real, intent(in)  :: Q(nVar), nv(nDim)
    real, intent(out) :: Lambda(nVar)

    ! Local variables
    real :: p, u, c

    u = ( Q(2)*nv(1) + Q(3)*nv(2) )/Q(1)                      ! normal velocity
    p = (EQN%gamma-1.0)*( Q(4) - 0.5*SUM(Q(2:3)**2)/Q(1) )    ! fluid pressure
    c = SQRT(EQN%gamma*p/Q(1))                                ! sound speed

    Lambda = (/ u-c, u, u, u+c /)                          ! The eigenvalues of the Euler equations

end subroutine PDEEigenvalues

!-----------------------------------------------------------------------
! LLF (Rusanov) Riemann solver
!-----------------------------------------------------------------------

subroutine RusanovFlux(QL, FL, QR, FR, nv, Flux)
    use ader_dg
    implicit none
    ! Argument list
    real, intent(in)  :: QL(nVar), FL(nVar), QR(nVar), FR(nVar), nv(nDim)
    real, intent(out) :: Flux(nVar)

    ! Local variables
    real :: smax, LL(nVar), LR(nVar)

    call PDEEigenvalues(QL,nv,LL)
    call PDEEigenvalues(QR,nv,LR)

    smax = max( maxval(abs(LL)), maxval(abs(LR)) )

    Flux = 0.5*(FL + FR) - 0.5*smax*(QR - QL)

end subroutine

!-----------------------------------------------------------------------
! Make sure the input state is physically valid
!-----------------------------------------------------------------------

subroutine PDEAssurePositivity(iErr,Q, Qout)
    use ader_dg, only : nVar, EQN
    implicit none
    ! Argument list
    real, intent(IN)     :: Q(nVar)
    real, intent(OUT)    :: Qout(nVar)
    integer, intent(OUT) :: iErr
    ! Local variables
    real :: p, irho

    iErr = 0
    Qout = Q ! we do not apply dirty tricks here at this point
    irho = 1.0/Q(1)

    ! 2D compressible Euler equations

    p = (EQN%GAMMA-1)*( Q(4) - 0.5*SUM(Q(2:3)**2)*irho )

    if ( Q(1) .le. 1.0e-12) then
        iErr = -1
    end if

    if (p .le. 1.0e-12) then
        iErr = -2
    end if
end subroutine PDEAssurePositivity


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Calculate mean and sigma from input histogram
C
      SUBROUTINE STATI(HIST,mean,sigma,npts)
      IMPLICIT NONE
      INTEGER*4 HIST(-32768:32767)
      REAL*4 MEAN,SIGMA		!Mean and sigma (returned)
      INTEGER*4 NPTS		!Number of pixels in histogram (returned)

      COMMON/C3/INMIN,INMAX,DNMIN,DNMAX
      INTEGER*4 INMIN,INMAX,DNMIN,DNMAX

      INTEGER*4 IDN,NPIX
      REAL*8 SUM,SUMSQ,DMEAN,DN

      SUMSQ=0.0D0
      SUM=0.0D0
      NPTS=0

      DO IDN=INMIN,INMAX
         NPIX = HIST(IDN)
	 DN = IDN
         SUM = SUM + NPIX*DN
         SUMSQ = SUMSQ + NPIX*DN*DN
         NPTS = NPTS + NPIX
      END DO

      IF (NPTS.GT.0) THEN
         DMEAN = SUM/NPTS
         MEAN = DMEAN
         SIGMA=DSQRT(DABS(SUMSQ/NPTS-DMEAN*DMEAN))
      ENDIF
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Calculate mean and sigma for byte histogram
C
      SUBROUTINE STATIB(HIST,mean,sigma,npts)
      IMPLICIT NONE
      INTEGER*4 HIST(0:255)
      REAL*4 MEAN,SIGMA		!Mean and sigma (returned)
      INTEGER*4 NPTS		!Number of pixels in histogram (returned)

      INTEGER*4 IDN,NPIX
      REAL*8 SUM,SUMSQ,DMEAN,DN

      SUMSQ=0.0D0
      SUM=0.0D0
      NPTS=0

      DO IDN=0,255
         NPIX = HIST(IDN)
	 DN = IDN
         SUM = SUM + NPIX*DN
         SUMSQ = SUMSQ + NPIX*DN*DN
         NPTS = NPTS + NPIX
      END DO

      IF (NPTS.GT.0) THEN
         DMEAN = SUM/NPTS
         MEAN = DMEAN
         SIGMA=DSQRT(DABS(SUMSQ/NPTS-DMEAN*DMEAN))
      ENDIF
      RETURN
      END

CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C Print the stretch table
C
      SUBROUTINE PTABLE(LUT,DNMIN,DNMAX)
      INTEGER*4 DNMIN,DNMAX
      INTEGER*2 LUT(-32768:32767)
      CHARACTER*132 PRT, PRTOUT
  180 FORMAT('IN  ',15I8)
  190 FORMAT('OUT ',15I8)

      CALL XVMESSAGE(' ', ' ')
      CALL XVMESSAGE(' T R A N S F O R M A T I O N', ' ')

      DO I=DNMIN,DNMAX,15
         J = MIN0(I+14,DNMAX)
         WRITE (PRT, 180) (K,K=I,J)
         WRITE (PRTOUT, 190) (LUT(K),K=I,J)
         CALL XVMESSAGE(PRT,' ')
         CALL XVMESSAGE(PRTOUT,' ')
      ENDDO
      RETURN
      END


subroutine PlmSchmidt(p, lmax, z, csphase, cnorm)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
!	This function evalutates all of the normalized associated Legendre
!	functions up to degree lmax. The functions are initially scaled by
!	10^280 sin^m in order to minimize the effects of underflow at large m
!	near the poles (see Holmes and Featherstone 2002, J. Geodesy, 76, 279-299).
!	On a Mac OSX system with a maximum allowable double precision value of
!	2.225073858507203E-308 the scaled portion of the algorithm will not overflow
!	for degrees less than or equal to 2800.
!
!	For each value of m, the rescaling factor is computed as rescalem=rescalem*sin(theta),
!	with the intial value of rescalem being equal to 1/scalef (which is here equal
!	to 10^280). This will gradually reduce this huge number to a tiny number, and will
!	ultimately underflow. In order to prevent this underflow, when rescalem becomes less than
!	10^(-280), the subsequent rescaling factors of sin(theta) will be directly applied to Plm, and then this
!	number will be multipled by the old value of rescalem.
!
!	Temporary variables in saved in an allocated array. In order to explicitly deallocate this
!	memory, call this routine with a spherical harmonic degree of -1.
!
!	Calling Parameters:
!		IN
!			lmax:		Maximum spherical harmonic degree to compute.
!			z:		cos(colatitude) or sin(latitude).
!		OPTIONAL (IN)
!			csphase:	1: Do not include the phase factor of (-1)^m
!					-1: Apply the phase factor of (-1)^m.
!			cnorm:		0: Use real normalization.
!					1: Use complex normalization.
!		OUT
!			p:		A vector of all associated Legendgre polynomials evaluated at
!					z up to lmax. The lenght must by greater or equal to (lmax+1)*(lmax+2)/2.
!
!	Notes:
!
!	1.	The employed normalization is the "geophysical convention." The integral of
!		(plm*cos(m theta))**2 or (plm*sin (m theta))**2 over all space is 4 pi.
!	2.	The integral of plm**2 over (-1,1) is 2 * (2 - delta(0,m)) / (2l+1). If CNORM=1, then
!		this is equal to 2/(2l+1).
!	3.	The index of the array p corresponds to l*(l+1)/2 + m + 1. As such
!		the array p should be dimensioned as (lmax+1)*(lmax+2)/2 in the
!		calling routine.
!	4.	The default is to exlude the Condon-Shortley phase of (-1)^m.
!
!
!	Dependencies:	CSPHASE_DEFAULT
!
!	Written by Mark Wieczorek September 25, 2005.
!
!	April 19, 2008: Added CNORM optional parameter compute complex normalized functions.
!
!	Copyright (c) 2008, Mark A. Wieczorek
!	All rights reserved.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	use SHTOOLS, only: CSPHASE_DEFAULT

	implicit none
	integer, intent(in) ::	lmax
	real*8, intent(out) ::	p(:)
       	real*8, intent(in) ::	z
       	integer, intent(in), optional :: csphase, cnorm
       	real*8 ::	pm2, pm1, pmm, plm, rescalem, phase, u, scalef
      	real*8, save, allocatable ::	f1(:), f2(:), sqr(:)
      	integer ::	k, kstart, m, l, astat(3)
      	integer, save ::	lmax_old = 0

	if (lmax == -1) then
		if (allocated(sqr)) deallocate(sqr)
		if (allocated(f1)) deallocate(f1)
		if (allocated(f2)) deallocate(f2)
		lmax_old = 0
		return
	endif

	if (size(p) < (lmax+1)*(lmax+2)/2) then
		print*, "Error ---PlmSchmidt"
     		print*, "P must be dimensioned as (LMAX+1)*(LMAX+2)/2 where LMAX is ", lmax
     		print*, "Input array is dimensioned ", size(p)
     		stop
     	elseif (lmax < 0) then
     		print*, "Error --- PlmSchmidt"
     		print*, "LMAX must be greater than or equal to 0."
     		print*, "Input value is ", lmax
     		stop
     	elseif(abs(z) > 1.0d0) then
     		print*, "Error --- PlmSchmidt"
     		print*, "ABS(Z) must be less than or equal to 1."
     		print*, "Input value is ", z
     		stop
     	endif

     	if (present(csphase)) then
     		if (csphase == -1) then
     			phase = -1.0d0
     		elseif (csphase == 1) then
     			phase = 1.0d0
     		else
     			print*, "Error --- PlmSchmidt"
     			print*, "CSPHASE must be 1 (exclude) or -1 (include)."
     			print*, "Input value is ", csphase
     			stop
     		endif
     	else
     		phase = dble(CSPHASE_DEFAULT)
     	endif

	scalef = 1.0d-280

	if (lmax /= lmax_old) then

		if (allocated(sqr)) deallocate(sqr)
		if (allocated(f1)) deallocate(f1)
		if (allocated(f2)) deallocate(f2)

		allocate(sqr(2*lmax+1), stat=astat(1))
		allocate(f1((lmax+1)*(lmax+2)/2), stat=astat(2))
		allocate(f2((lmax+1)*(lmax+2)/2), stat=astat(3))

		if (astat(1) /= 0 .or. astat(2) /= 0 .or. astat(3) /= 0) then
			print*, "PlmSchmidt --- Error"
			print*, "Problem allocating arrays SQR, F1 and F2", astat(1), astat(2), astat(3)
			stop
		endif

		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!
		!	Precompute square roots of integers that are used several times.
		!
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

		do l=1, 2*lmax+1
			sqr(l) = sqrt(dble(l))
		enddo

		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
		!
		! 	Precompute multiplicative factors used in recursion relationships
		! 		PlmSchmidt(l,m) = x*f1(l,m)*PlmSchmidt(l-1,m) - PlmSchmidt(l-2,m)*f2(l,m)
		!		k = l*(l+1)/2 + m + 1
		!	Note that prefactors are not used for the case when m=l and m=l-1,
		!	as a different recursion is used for these two values.
		!
		!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

		k = 3

		do l=2, lmax, 1
			k = k + 1
			f1(k) = dble(2*l-1) /dble(l)
			f2(k) = dble(l-1) /dble(l)
			do m=1, l-2
				k = k+1
				f1(k) = dble(2*l-1) / sqr(l+m) / sqr(l-m)
                  		f2(k) = sqr(l-m-1) * sqr(l+m-1) / sqr(l+m) / sqr(l-m)
			enddo
			k = k + 2
		enddo

		lmax_old = lmax

	endif

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate P(l,0). These are not scaled.
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

	u = sqrt((1.0d0-z)*(1.0d0+z)) ! sin(theta)

      	pm2  = 1.0d0
      	p(1) = 1.0d0

      	if (lmax == 0) return

      	pm1  = z
      	p(2) = pm1

	k = 2

      	do l = 2, lmax, 1
         	k = k+l
         	plm = f1(k)*z*pm1-f2(k)*pm2
         	p(k) = plm
         	pm2  = pm1
         	pm1  = plm
      	enddo

	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
	!
	!	Calculate P(m,m), P(m+1,m), and P(l,m)
	!
	!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!

 	if (present(cnorm)) then
		if (cnorm == 1) then
			pmm = scalef
		else
			pmm = sqr(2)*scalef
		endif
	else
      		pmm = sqr(2)*scalef
      	endif

      	rescalem = 1.0d0/scalef
      	kstart = 1

      	do m = 1, lmax - 1, 1

      		rescalem = rescalem*u

		! Calculate P(m,m)
        	kstart = kstart+m+1

         	pmm = phase * pmm * sqr(2*m+1) / sqr(2*m)
        	p(kstart) = pmm*rescalem / sqr(2*m+1)
        	pm2 = pmm/sqr(2*m+1)

		! Calculate P(m+1,m)
		k = kstart+m+1
	   	pm1 = z * sqr(2*m+1) * pm2
	    	p(k) = pm1*rescalem

		! Calculate P(l,m)
               	do l = m+2, lmax, 1
               		k = k+l
                  	plm  = z*f1(k)*pm1-f2(k)*pm2
                  	p(k) = plm*rescalem
                  	pm2  = pm1
                  	pm1  = plm
               	enddo

      	enddo

      	! Calculate P(lmax,lmax)

      	rescalem = rescalem*u

        kstart = kstart+m+1
        pmm = phase * pmm  / sqr(2*lmax)
        p(kstart) = pmm*rescalem

end subroutine PlmSchmidt


FUNCTION gammp(a,x)
REAL*8 a,gammp,x
!    USES gcf,gser
REAL*8 gammcf,gamser,gln
if(x.lt.0..or.a.le.0.)pause 'bad arguments in gammp'
if(x.lt.a+1.)then
	call gser(gamser,a,x,gln)
	gammp=gamser
else
	call gcf(gammcf,a,x,gln)
	gammp=1.-gammcf
endif
return
END


c
c   Example 5
c
c   Interface:    Linear-Algebraic (IJ), Babel-based version in Fortran
c
c   Compile with: make ex5b
c
c   Sample run:   mpirun -np 4 ex5b
c
c   Description:  This example solves the 2-D
c                 Laplacian problem with zero boundary conditions
c                 on an nxn grid.  The number of unknowns is N=n^2.
c                 The standard 5-point stencil is used, and we solve
c                 for the interior nodes only.
c
c                 This example solves the same problem as Example 3.
c                 Available solvers are AMG, PCG, and PCG with AMG or
c                 Parasails preconditioners.

      program ex5b77

      implicit none

      include 'mpif.h'

      integer    MAX_LOCAL_SIZE
      parameter  (MAX_LOCAL_SIZE=123000)

      integer    ierr, ierrtmp
      integer    num_procs, myid
      integer    local_size, extra
      integer    n, solver_id, print_solution, ng
      integer    nnz, ilower, iupper, i
      double precision h, h2
      double precision rhs_values(MAX_LOCAL_SIZE)
      double precision x_values(MAX_LOCAL_SIZE)
      integer    rows(MAX_LOCAL_SIZE)
      integer    cols(5)
      double precision values(5)
      integer    num_iterations
      double precision final_res_norm, tol

      integer*8  bHYPRE_mpicomm
      integer*8  mpi_comm
      integer*8  parcsr_A
      integer*8  op_A
      integer*8  par_b
      integer*8  par_x
      integer*8  vec_b
      integer*8  vec_x
      integer*8  amg_solver
      integer*8  except
c     ... except is for Babel exceptions, which we shall ignore

c-----------------------------------------------------------------------
c     Initialize MPI
c-----------------------------------------------------------------------

      call MPI_INIT(ierr)
      call MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
      call MPI_COMM_SIZE(MPI_COMM_WORLD, num_procs, ierr)
      mpi_comm = MPI_COMM_WORLD
      call bHYPRE_MPICommunicator_CreateF_f( mpi_comm, bHYPRE_mpicomm,
     1      except )

c   Default problem parameters
      n = 33
      solver_id = 0
      print_solution  = 0
      tol = 1.0d-7

c   The input section not implemented yet.

c   Preliminaries: want at least one processor per row
      if ( n*n .lt. num_procs) then
         n = int(sqrt(real(num_procs))) + 1
      endif
c     ng = global no. rows, h = mesh size
      ng = n*n
      h = 1.0d0/(n+1)
      h2 = h*h

c     Each processor knows only of its own rows - the range is denoted by ilower
c     and upper.  Here we partition the rows. We account for the fact that
c     N may not divide evenly by the number of processors.
      local_size = ng/num_procs
      extra = ng - local_size*num_procs

      ilower = local_size*myid
      ilower = ilower + min(myid, extra)

      iupper = local_size*(myid+1)
      iupper = iupper + min(myid+1, extra)
      iupper = iupper - 1

c     How many rows do I have?
      local_size = iupper - ilower + 1

c     Create the matrix.
c     Note that this is a square matrix, so we indicate the row partition
c     size twice (since number of rows = number of cols)
      call bHYPRE_IJParCSRMatrix_Create_f( bHYPRE_mpicomm, ilower,
     1     iupper, ilower, iupper, parcsr_A, except )

c     op_A will be needed later as a function argument
      call bHYPRE_Operator__cast_f( parcsr_A, op_A, except )

c     Choose a parallel csr format storage (see the User's Manual)
c     Note: Here the HYPRE interface requires a SetObjectType call.
c     I am using the bHYPRE interface in a way which does not because
c     the object type is already specified through the class name.

c     Initialize before setting coefficients
      call bHYPRE_IJParCSRMatrix_Initialize_f( parcsr_A, ierrtmp,
     1     except )

c     Now go through my local rows and set the matrix entries.
c     Each row has at most 5 entries. For example, if n=3:
c
c      A = [M -I 0; -I M -I; 0 -I M]
c      M = [4 -1 0; -1 4 -1; 0 -1 4]
c
c     Note that here we are setting one row at a time, though
c     one could set all the rows together (see the User's Manual).

      do i = ilower, iupper
         nnz = 1

c        The left identity block:position i-n
         if ( (i-n) .ge. 0 ) then
	    cols(nnz) = i-n
	    values(nnz) = -1.0d0
	    nnz = nnz + 1
         endif

c         The left -1: position i-1
         if ( mod(i,n).ne.0 ) then
            cols(nnz) = i-1
            values(nnz) = -1.0d0
            nnz = nnz + 1
         endif

c        Set the diagonal: position i
         cols(nnz) = i
         values(nnz) = 4.0d0
         nnz = nnz + 1

c        The right -1: position i+1
         if ( mod((i+1),n) .ne. 0 ) then
            cols(nnz) = i+1
            values(nnz) = -1.0d0
            nnz = nnz + 1
         endif

c        The right identity block:position i+n
         if ((i+n) .lt. ng ) then
            cols(nnz) = i+n
            values(nnz) = -1.0d0
            nnz = nnz + 1
         endif

c        Set the values for row i
         call bHYPRE_IJParCSRMatrix_SetValues_f(
     1        parcsr_A, 1, nnz-1, i, cols, values, 5, ierrtmp, except )

      enddo

c     Assemble after setting the coefficients
      call bHYPRE_IJParCSRMatrix_Assemble_f( parcsr_A, ierrtmp, except )

c     Create the rhs and solution
      call bHYPRE_IJParCSRVector_Create_f( bHYPRE_mpicomm,
     1     ilower, iupper, par_b, except )
c     vec_b will be needed later for function arguments
      call bHYPRE_Vector__cast_f( par_b, vec_b, except )

      call bHYPRE_IJParCSRVector_Initialize_f( par_b, ierrtmp, except )

      call bHYPRE_IJParCSRVector_Create_f( bHYPRE_mpicomm,
     1     ilower, iupper, par_x, except )
c     vec_x will be needed later for function arguments
      call bHYPRE_Vector__cast_f( par_x, vec_x, except )

      call bHYPRE_IJParCSRVector_Initialize_f( par_x, ierrtmp, except )

c     Set the rhs values to h^2 and the solution to zero
      do i = 1, local_size
         rhs_values(i) = h2
         x_values(i) = 0.0
         rows(i) = ilower + i -1
      enddo
      call bHYPRE_IJParCSRVector_SetValues_f(
     1     par_b, local_size, rows, rhs_values, ierrtmp, except )
      call bHYPRE_IJParCSRVector_SetValues_f(
     1     par_x, local_size, rows, x_values, ierrtmp, except )

      call bHYPRE_IJParCSRVector_Assemble_f( par_b, ierrtmp, except )
      call bHYPRE_IJParCSRVector_Assemble_f( par_x, ierrtmp, except )

c     Choose a solver and solve the system

c      AMG
      if ( solver_id == 0 ) then

c        Create solver
         call bHYPRE_BoomerAMG_Create_f(
     1        bHYPRE_mpicomm, parcsr_A, amg_solver, except )

c        Set some parameters (See Reference Manual for more parameters)
c        PrintLevel=3 means print solve info + parameters
c        CoarsenType=6 means Falgout coarsening
c        RelaxType=3 means Gauss-Seidel/Jacobi hybrid relaxation
         call bHYPRE_BoomerAMG_SetIntParameter_f(
     1        amg_solver, "PrintLevel", 3, ierrtmp, except )
         call bHYPRE_BoomerAMG_SetIntParameter_f(
     1        amg_solver, "CoarsenType", 6, ierrtmp, except )
         call bHYPRE_BoomerAMG_SetIntParameter_f(
     1        amg_solver, "RelaxType", 3, ierrtmp, except )
         call bHYPRE_BoomerAMG_SetIntParameter_f(
     1        amg_solver, "NumSweeps", 1, ierrtmp, except )
         call bHYPRE_BoomerAMG_SetIntParameter_f(
     1        amg_solver, "MaxLevels", 20, ierrtmp, except )
         call bHYPRE_BoomerAMG_SetDoubleParameter_f(
     1        amg_solver, "Tolerance", tol, ierrtmp, except )

c        Now setup and solve!
         call bHYPRE_BoomerAMG_Setup_f(
     1        amg_solver, vec_b, vec_x, ierrtmp, except )
         call bHYPRE_BoomerAMG_Apply_f(
     1        amg_solver, vec_b, vec_x, ierrtmp, except )

c        Run info - needed logging turned on
         call bHYPRE_BoomerAMG_GetIntValue_f(
     1        amg_solver, "NumIterations", num_iterations, ierrtmp,
     2        except )
         ierr = ierr + ierrtmp
         call bHYPRE_BoomerAMG_GetDoubleValue_f(
     1        amg_solver, "RelResidualNorm", final_res_norm, ierrtmp,
     2        except )

      if (myid .eq. 0) then
         print *
         print *, "Iterations = ", num_iterations
         print *, "Final Relative Residual Norm = ", final_res_norm
         print *
      endif

c     Destroy solver
      call bHYPRE_BoomerAMG_deleteRef_f( amg_solver, except )

      endif

c     The calls of other solvers are not implemented yet.

c     Print the solution
      if ( print_solution .ne. 0 ) then
         call bHYPRE_IJParCSRVector_Print_f( par_x, "ij.out.x", except )
      endif

c     Clean up
      call bHYPRE_Operator_deleteRef_f( op_A, except )
      call bHYPRE_Vector_deleteRef_f( vec_b, except )
      call bHYPRE_Vector_deleteRef_f( vec_x, except )
      call bHYPRE_IJParCSRMatrix_deleteRef_f( parcsr_A, except )
      call bHYPRE_IJParCSRVector_deleteRef_f( par_b, except )
      call bHYPRE_IJParCSRVector_deleteRef_f( par_x, except )
      call bHYPRE_MPICommunicator_deleteRef_f( bHYPRE_mpicomm, except )

c     We need a multi-language equivalent of hypre_assert.
      if ( ierr .ne. 0 ) then
         print *
         print *, "***** Bad ierr = ", ierr
         print *
      endif

c     Finalize MPI
      call MPI_Finalize(ierrtmp)

      stop
      end


c
c	transformation matrix t1=<theta,z>
c
c	iverse = 1 straight transform
c	      =-1 inverse transform
c
	subroutine t1(itime,x_in,x_out,iverse)
c
	real theta,x_in(3),x_out(3),t0,ut,temp
	integer*4 itime(2),iday,iyr,iverse
	parameter (degrad=3.1415927/180.0)
c
	temp=t0(itime,iyr,iday,ut)
	theta=(100.461+36000.770*temp+15.04107*ut)*degrad
c
	call rotate_z (float(iverse)*theta,x_in,x_out)
c
	return
	end


C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
C     Projet MICO - Partie théorique (ver. FORTRAN 21.03.95)
C
C            Calcule u(v) et P(u) par Newton Raphson
C++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++

C ----Declarations--------
      integer i, boucle, vz
      double precision h, a, b, Vh, Vv, E, Lh, Lv
      double precision TOL, u, lastu, F, DF, Du, Pl(16), ul(16)
      double precision P(101), x(101), y(101)

C ----Donnees-------------
      h   = 40.
      a   = 24.
      b   = 40.
      Vh  = 160.
      Vv  = 200.
      E   = 70000.
      Lh  = 2*a
      Lv  = sqrt(h**2+(b+a)**2)
      TOL = 1e-5

C ----Trace u fct. de v---
      i=0
      u=0.
      lastu=0.

      do 10 v=0,90
         i=i+1
         boucle=0
         lastu=0
         F=(Vv/Lv**4)*(v**2+u**2-2*h*v+2*u*(a+b))*(u+a+b)
         F=F+(8*Vh/Lh**4)*(u**2+2*a*u)*(u+a)
         DF=(Vv/Lv**4)*((u+a+b)*(2*u+2*(a+b))
     *      +(v**2+u**2-2*h*v+2*u*(a+b)))
         DF=DF+(8*Vh/Lh**4)*((2*u+2*a)*(u+a)+(u**2+2*u*a))
         Du=-F/DF
         u=u+Du

20       F=(Vv/Lv**4)*(v**2+u**2-2*h*v+2*u*(a+b))*(u+a+b)
         F=F+(8*Vh/Lh**4)*(u**2+2*a*u)*(u+a)
         if (abs(u-lastu).GT.TOL) then
            DF=(Vv/Lv**4)*((u+a+b)*(2*u+2*(a+b))
     *         +(v**2+u**2-2*h*v+2*u*(a+b)))
            DF=DF+(8*Vh/Lh**4)*((2*u+2*a)*(u+a)+(u**2+2*u*a))
            Du=-F/DF
            lastu=u
            u=u+Du
         else
            boucle=1
         endif
         if (boucle.EQ.0) goto 20

         x(i)=v
         y(i)=u
         P(i)=(E*Vv/Lv**4)*(v*v+u*u-2*h*v+2*u*(a+b))*(v-h)
10    continue

C ----Réponse linéaire----

      do 40 vz=0,15
        ul(vz+1)=2*h*vz*(a+b)*Vv/Lv**4/(Vh/a**2+2*Vv*(a+b)**2/Lv**4)
        Pl(vz+1)=-2*h*Vv*E/Lv**4*(ul(vz+1)*(a+b)-h*vz)
40    continue

C ----Resultats-----------

32    open (UNIT = 1, FILE = 'th_1.m', STATUS='unknown')
      do 31 i=1,91
         write(1,*)'xt(',i,')=',x(i),';'
         write(1,*)'yt(',i,')=',y(i),';'
         write(1,*)'Pt(',i,')=',P(i),';'
31    continue
      do 30 i=1,16
         write(1,*)'ul(',i,')=',ul(i),';'
         write(1,*)'Pl(',i,')=',Pl(i),';'
30    continue
      write(1,*)'figure(1), plot(xt,yt,''k''), grid'
      write(1,*)'figure(2), plot(xt,Pt,''k''), grid'
      write(1,*)'figure(3), plot(0:15,Pl,''k'',xt,Pt,''k''), grid'
      write(1,*)'figure(4), plot(xt,yt,''k'',0:15,ul,''k''), grid'
      close (UNIT=1)
      end


MODULE math_routines
    USE structures_mod
    IMPLICIT NONE

CONTAINS

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!! This function interpolates using a cubic monotone piecewise              !!!
!!! interpolation. It takes the x array we want to interpolate to (mass),    !!!
!!! the known x values (valMass), array (valArr), and their size (tot).      !!!
!!!                                                                          !!!
!!! The input values are:                                                    !!!
!!! -mass, the array with mass coordinates for which we ignore the y values. !!!
!!! -valMass, the array with mass coordinates with known "y" values.         !!!
!!! -valARR, the known "y" array.                                            !!!
!!! -tot, the size of the mass array.                                        !!!
!!!                                                                          !!!
!!! Returns the interpolated values.                                         !!!
!!!                                                                          !!!
!!! Ref: Steffen, M. 1990, A&A, 239, 443.                                    !!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
FUNCTION interpolate(mass, valMass, valArr, tot)
    IMPLICIT NONE

    ! Input
    DOUBLE PRECISION::mass(:), valMass(:), valArr(:)
    INTEGER::tot

    ! Function
    DOUBLE PRECISION::interpolate(tot)

    ! Local
    DOUBLE PRECISION::yp1, y0, ym1, yp2, si0, sip1, sim1, deriv0, pip1, ai, bi
    DOUBLE PRECISION::derivp1, pi0, xp1, xp2, x0, xm1, hi0, hip1, him1, deltx
    INTEGER::p1, p2, ii, jj, valShells

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!END OF DECLARATIONS!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! The interpolated value is given by the formula:
    ! f_i(x) = ai*(x - x_i)^3 + bi*(x - x_i)^2 + ci*(x - x_i) + di

    ! Initialize some variables so the compiler does not complain
    xp1 = 0; x0 = 0; p1 = 1; p2 = 1

    ! Size for valMass
    valShells = SIZE(valMass)

    DO ii = 1, tot
        ! Get p1 and p2 for this mass and store x0 and xp1
        DO jj = p1, valShells - 1
            x0 = valMass(jj)
            xp1 = valMass(jj + 1)

            IF ((x0.LE.mass(ii)).AND.(xp1.GE.mass(ii))) THEN
                p1 = jj; p2 = jj + 1
                EXIT
            END IF
        END DO

        ! Fix p1 and p2 status if not correct
        IF (xp1.LT.mass(ii)) THEN
            p1 = valShells - 1
            p2 = valShells
        END IF

        ! Store yp1 and y0
        yp1 = valArr(p2); y0 = valArr(p1)

        hi0 = (xp1 - x0)
        si0 = (yp1 - y0)/hi0

        ! Calculate sim1 and deriv0
        IF (p1.GT.1) THEN
            ! Store x, y
            ym1 = valArr(p1 - 1)
            xm1 = valMass(p1 - 1)

            him1 = (x0 - xm1)
            sim1 = (y0 - ym1)/him1

            ! Pi0 calculation
            pi0 = (sim1*hi0 + si0*him1)/(him1 + hi0)

            ! Derivative
            deriv0 = SIGN(1.D0, sim1) + SIGN(1.D0, si0)
            deriv0 = deriv0*MIN(ABS(sim1), ABS(si0), 0.5D0*ABS(pi0))
        ELSE
            ! We are in the lowest extreme
            deriv0 = 0.D0
        END IF

        ! Calculate sip1, pip1 and derivp1
        IF (p2.LT.valShells) THEN
            yp2 = valArr(p2 + 1)
            xp2 = valMass(p2 + 1)

            hip1 = (xp2 - xp1)
            sip1 = (yp2 - yp1)/hip1

            ! Pip1 calculation
            pip1 = (si0*hip1 + sip1*hi0)/(hi0 + hip1)

            ! Derivative
            derivp1 = SIGN(1.D0, si0) + SIGN(1.D0, sip1)
            derivp1 = derivp1*MIN(ABS(si0), ABS(sip1), 0.5D0*ABS(pip1))
        ELSE
            ! We are in the highest extreme
            derivp1 = 0.D0
        END IF

        ! Now calculate coefficients (ci = deriv0; di = y0)
        ai = (deriv0 + derivp1 - 2.D0*si0)/(hi0*hi0)
        bi = (3.D0*si0 - 2*deriv0 - derivp1)/hi0

        deltx = mass(ii) - x0
        interpolate(ii) = ai*deltx**3 + bi*deltx**2 + deriv0*deltx + y0
    END DO

    RETURN

END FUNCTION interpolate

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!! Same as interpolate but for a scalar.                                    !!!
!!!                                                                          !!!
!!! Ref: Steffen, M. 1990, A&A, 239, 443.                                    !!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
FUNCTION interpolateOneValue(mass, valMass, valArr)
    IMPLICIT NONE

    ! Input
    DOUBLE PRECISION::mass, valMass(:), valArr(:)

    ! Function
    DOUBLE PRECISION::interpolateOneValue

    ! Local
    DOUBLE PRECISION::yp1, y0, ym1, yp2, si0, sip1, sim1, deriv0, pip1, ai, bi
    DOUBLE PRECISION::derivp1, pi0, xp1, xp2, x0, xm1, hi0, hip1, him1, deltx
    INTEGER::p1, p2, jj, valShells

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!END OF DECLARATIONS!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! The interpolated value is given by the formula:
    ! f_i(x) = ai*(x - x_i)^3 + bi*(x - x_i)^2 + ci*(x - x_i) + di

    ! Initialize some variables so the compiler does not complain
    xp1 = 0; x0 = 0; p1 = 1; p2 = 1

    ! Size for valMass
    valShells = SIZE(valMass)

    ! Get p1 and p2 for this mass and store x0 and xp1
    DO jj = 1, valShells - 1
        x0 = valMass(jj)
        xp1 = valMass(jj + 1)

        IF ((x0.LE.mass).AND.(xp1.GE.mass)) THEN
            p1 = jj; p2 = jj + 1
            EXIT
        END IF
    END DO

    ! Fix p1 and p2 status if not correct
    IF (xp1.LT.mass) THEN
        p1 = valShells - 1
        p2 = valShells
    END IF

    ! Store yp1 and y0
    yp1 = valArr(p2); y0 = valArr(p1)

    hi0 = (xp1 - x0)
    si0 = (yp1 - y0)/hi0

    ! Calculate sim1 and deriv0
    IF (p1.GT.1) THEN
        ! Store x, y
        ym1 = valArr(p1 - 1)
        xm1 = valMass(p1 - 1)

        him1 = (x0 - xm1)
        sim1 = (y0 - ym1)/him1

        ! Pi0 calculation
        pi0 = (sim1*hi0 + si0*him1)/(him1 + hi0)

        ! Derivative
        deriv0 = SIGN(1.D0, sim1) + SIGN(1.D0, si0)
        deriv0 = deriv0*MIN(ABS(sim1), ABS(si0), 0.5D0*ABS(pi0))
    ELSE
        ! We are in the lowest extreme
        deriv0 = 0.D0
    END IF

    ! Calculate sip1, pip1 and derivp1
    IF (p2.LT.valShells) THEN
        yp2 = valArr(p2 + 1)
        xp2 = valMass(p2 + 1)

        hip1 = (xp2 - xp1)
        sip1 = (yp2 - yp1)/hip1

        ! Pip1 calculation
        pip1 = (si0*hip1 + sip1*hi0)/(hi0 + hip1)

        ! Derivative
        derivp1 = SIGN(1.D0, si0) + SIGN(1.D0, sip1)
        derivp1 = derivp1*MIN(ABS(si0), ABS(sip1), 0.5D0*ABS(pip1))
    ELSE
        ! We are in the highest extreme
        derivp1 = 0.D0
    END IF

    ! Now calculate coefficients (ci = deriv0; di = y0)
    ai = (deriv0 + derivp1 - 2.D0*si0)/(hi0*hi0)
    bi = (3.D0*si0 - 2*deriv0 - derivp1)/hi0

    deltx = mass - x0
    interpolateOneValue = ai*deltx**3 + bi*deltx**2 + deriv0*deltx + y0

    RETURN

END FUNCTION interpolateOneValue

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!! This subroutine creates the jacobian.                                    !!!
!!!                                                                          !!!
!!! The input values are:                                                    !!!
!!! -crosLst, a linked list of CROSSARR types with the network cross         !!!
!!!            sections.                                                     !!!
!!! -dens, the shell abundances.                                             !!!
!!! -jacobian, the output jacobian matrix.                                   !!!
!!! -eIndices, an array of type INDICES with the indices of the maximum      !!!
!!!            contributors to the free electrons in the star.               !!!
!!!                                                                          !!!
!!! On output the jacobian is filled with the derivatives of the rates.      !!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE createJacobian(crosLst, dens, jacobian, eIndices)
    IMPLICIT NONE

    ! Input
    TYPE (CROSSARR), TARGET::crosLst
    TYPE (INDICES)::eIndices(:)
    DOUBLE PRECISION::dens(:), jacobian(:, :)

    ! Local
    TYPE (CROSSARR), POINTER::cCross
    DOUBLE PRECISION::derivative, Ye
    INTEGER::ii, jj, jjindx, iiindx

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!END OF DECLARATIONS!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    cCross => crosLst
    DO
        Ye = 1.D0

        ! If the reaction is "ec" we have to calculate Ye.
        IF (cCross%isEc) CALL calculateYe(dens, eIndices, Ye)

        ! Now calculate the jacobian elements: jacobian(j, i) = df_j/dy_i
        ! Bear in mind we are creating it transposed
        DO ii = 1, cCross%targnum
            iiindx = cCross%targindx(ii)

            ! First calculate the derivative. We have to multiply
            ! by the other targets.
            derivative = cCross%crossect*Ye
            DO jj = 1, cCross%targnum
                IF (jj.NE.ii) THEN
                    jjindx = cCross%targindx(jj)
                    derivative = derivative*dens(jjindx)
                END IF
            END DO

            ! Now input it in the jacobian.
            DO jj = 1, cCross%targnum + cCross%prodnum
                IF (jj.LE.cCross%targnum) THEN
                    jjindx = cCross%targindx(jj)
                    jacobian(iiindx, jjindx) = jacobian(iiindx, jjindx) - &
                                               derivative
                ELSE
                    jjindx = cCross%prodindx(jj - cCross%targnum)
                    jacobian(iiindx, jjindx) = jacobian(iiindx, jjindx) + &
                                               derivative
                END IF
            END DO
        END DO

        IF (ASSOCIATED(cCross%next)) THEN
            cCross => cCross%next
        ELSE
            EXIT
        END IF
    END DO

END SUBROUTINE createJacobian

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!! This subroutine creates the rates array.                                 !!!
!!!                                                                          !!!
!!! The input values are:                                                    !!!
!!! -crosLst, a linked list of CROSSARR types with the network cross         !!!
!!!            sections.                                                     !!!
!!! -dens, the shell abundances.                                             !!!
!!! -kk, production array.                                                   !!!
!!! -dd, destruction array.                                                  !!!
!!! -rates, the output rates array.                                          !!!
!!! -eIndices, an array of type INDICES with the indices of the maximum      !!!
!!!             contributors to the free electrons in the star.              !!!
!!!                                                                          !!!
!!! On output the rates array is filled with the rates values.               !!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE createRates(crosLst, dens, kk, dd, eIndices)
    IMPLICIT NONE

    ! Input
    TYPE (CROSSARR), TARGET::crosLst
    TYPE (INDICES)::eIndices(:)
    DOUBLE PRECISION::dens(:), kk(:), dd(:), ymin = 1.D-250

    ! Local
    TYPE (CROSSARR), POINTER::cCross
    DOUBLE PRECISION::rate, Ye, prod, oldProd, invDens(SIZE(dens))
    INTEGER::ii, iiindx

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!END OF DECLARATIONS!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! Zero kk and dd
    kk = 0.D0; dd = 0.D0
    invDens = 1/(dens + ymin)

    ! Link first reaction
    cCross => crosLst

    oldProd = 1
    DO
        ! If the reaction is "ec" we have to calculate Ye.
        IF (cCross%isEc) THEN
            Ye = 1.D0
            CALL calculateYe(dens, eIndices, Ye)
            rate = cCross%crossect*Ye
        ELSE
            rate = cCross%crossect
        END IF

        ! Calculate the rate: rates(ii) = f(ii)
        IF (cCross%isRepeated) THEN
            prod = oldProd
        ELSE
            prod = 1
            DO ii = 1, cCross%targnum
                iiindx = cCross%targindx(ii)
                prod = prod*(dens(iiindx) + ymin)
            END DO
            oldProd = prod
        END IF
        rate = rate*prod

        ! Input the rate.
        DO ii = 1, cCross%targnum
            iiindx = cCross%targindx(ii)
            dd(iiindx) = dd(iiindx) + rate
        END DO
        DO ii = 1, cCross%prodnum
            iiindx = cCross%prodindx(ii)
            kk(iiindx) = kk(iiindx) + rate
        END DO

        IF (ASSOCIATED(cCross%next)) THEN
            cCross => cCross%next
        ELSE
            EXIT
        END IF
    END DO

    dd = dd*invDens

END SUBROUTINE createRates

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!! This subroutine calculates Ye.                                           !!!
!!!                                                                          !!!
!!! The input values are:                                                    !!!
!!! -dens, the shell abundances.                                             !!!
!!! -eIndx, an array of type INDICES with the indices of the maximum         !!!
!!!         contributors to the free electrons in the star.                  !!!
!!! -Ye, the free electrons in mass number.                                  !!!
!!!                                                                          !!!
!!! On output, Ye has a value between 0.5 and 1 in [mole/g].                 !!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE calculateYe(dens, eIndx, Ye)
    IMPLICIT NONE

    ! Input
    TYPE (INDICES)::eIndx(:)
    DOUBLE PRECISION::dens(:), Ye

    ! Local
    TYPE (INDICES)::relation(5)
    DOUBLE PRECISION::metalDens
    INTEGER::ii, jj, iiindx, zz

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!END OF DECLARATIONS!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! Fill "relation" array, were posit is the atomic weight:
    relation(1)%elem = "p"; relation(1)%posit = 1
    relation(2)%elem = "d"; relation(2)%posit = 2
    relation(3)%elem = "t"; relation(3)%posit = 3
    relation(4)%elem = "he3"; relation(4)%posit = 3
    relation(5)%elem = "he4"; relation(5)%posit = 4

    ! Calculate metalicity (Xz)
    ! Here zz is A_i for p, d, he3 and he4 (zz = 1, 2, 3, 4)
    zz = 0                   ! (so the compiler doesn't complain)
    metalDens = 1.D0
    DO ii = 1, SIZE(eIndx)
        iiindx = eIndx(ii)%posit
        IF (iiindx.NE.0) THEN
            DO jj = 1, SIZE(relation)
                IF (eIndx(ii)%elem.EQ.relation(jj)%elem) THEN
                    zz = relation(jj)%posit
                    EXIT
                END IF
            END DO

            metalDens = metalDens - zz*dens(iiindx)
        END IF
    END DO

    ! Calculate Ye
    ! The electron mass number because of a metal is half the metal
    ! mass fraction (approximately)
    Ye = metalDens*5.D-1
    DO ii = 1, SIZE(eIndx)
        iiindx = eIndx(ii)%posit
        IF (iiindx.NE.0) THEN
            IF ((eIndx(ii)%elem.NE."he3").AND.(eIndx(ii)%elem.NE."he4")) THEN

                Ye = Ye + dens(iiindx)
            ELSE
                Ye = Ye + 2*dens(iiindx)
            END IF
        END IF
    END DO

END SUBROUTINE calculateYe

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!! This subroutine creates the system index.                                !!!
!!!                                                                          !!!
!!! The input values are:                                                    !!!
!!! -matrix, the matrix for the system index.                                !!!
!!! -sysInd, the integer array with indices.                                 !!!
!!! -he4indx, index for he4.                                                 !!!
!!! -siz, the matrix dimension.                                              !!!
!!!                                                                          !!!
!!! On output, sysInd has been filled with the nonzero indices.              !!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE createSysInd(matrix, sysInd, he4indx, siz)
    IMPLICIT NONE

    ! Input
    DOUBLE PRECISION::matrix(:, :)
    INTEGER::sysInd(:, :), he4indx, siz

    ! Local
    INTEGER::jj, kk, k1, k2, k3, k4, currStreak, maxStreak
    LOGICAL::inStreak

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!END OF DECLARATIONS!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! Store nonzero indices remember is already transposed
    DO kk = 1, siz
        ! Initialize
        sysInd(kk, :) = kk

        ! Introduce from helium onwards
        DO jj = he4indx + 1, kk - 1
            IF (ABS(matrix(jj, kk)).GT.0.D0) THEN
                sysInd(kk, 1) = jj
                EXIT
            END IF
        END DO

        ! And from the end, backwards
        DO jj = siz, kk + 1, -1
            IF (ABS(matrix(jj, kk)).GT.0.D0) THEN
                sysInd(kk, 4) = jj
                EXIT
            END IF
        END DO
    END DO

    ! Store biggest zero streak
    DO kk = 1, siz
        k2 = 0; k3 = 0
        currStreak = 0
        sysInd(kk, 2:3) = 0
        k1 = sysInd(kk, 1); k4 = sysInd(kk, 4)

        inStreak = .FALSE.
        maxStreak = 0
        DO jj = k1, k4
            ! Check for maximum streak and store indices if found
            IF ((ABS(matrix(jj, kk)).GT.0.D0).OR.(jj.EQ.kk)) THEN
                IF (inStreak) THEN
                    IF (currStreak.GT.maxStreak) THEN
                        maxStreak = currStreak
                        sysInd(kk, 2) = k2
                        sysInd(kk, 3) = k3
                    END IF

                    inStreak = .FALSE.
                END IF
            ELSE
                ! The indices are those of non-zero numbers
                IF (.NOT.inStreak) THEN
                    k2 = jj - 1
                    currStreak = 0
                END IF
                k3 = jj + 1

                currStreak = currStreak + 1
                inStreak = .TRUE.
            END IF
        END DO

        ! If k2 and k3 are 0, fix to avoid ifs
        k2 = sysInd(kk, 2)
        IF (k2.EQ.0) THEN
            sysInd(kk, 2:3) = k4
            sysInd(kk, 4) = k1 - 1
        END IF
    END DO

END SUBROUTINE createSysInd

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!! This subroutine performs a sparse gaussian elimination.                  !!!
!!!                                                                          !!!
!!! The input values are:                                                    !!!
!!! -aa, the matrix in which perform the elimination.                        !!!
!!! -tMatx, the matrix holding all the transformations done during the       !!!
!!!         elimination. That way we can transform the independent vector.   !!!
!!! -sysInd, array holding the system consecutive nonzero indices.           !!!
!!! -tInd, array holding the tMatx consecutive nonzero indices.              !!!
!!! -he4indx, index at which he4 is.                                         !!!
!!! -siz, aa size.                                                           !!!
!!!                                                                          !!!
!!! On output, aa, tMatx, sysInd and tInd have been modified.                !!!
!!!                                                                          !!!
!!! This subroutine is designed for a TRANSPOSED matrix. Transposed outside. !!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE sparseLU(aa, tMatx, sysInd, tInd, he4indx, siz)
    IMPLICIT NONE

    ! Input
    DOUBLE PRECISION::aa(:, :), tMatx(:, :)
    INTEGER::sysInd(:, :), tInd(:), he4indx, siz

    ! Local
    DOUBLE PRECISION::div, multp
    INTEGER::ii, jj, i1, i2, i3, i4

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!END OF DECLARATIONS!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! Add index to tInd
    DO ii = 1, siz
        tInd(ii) = ii
    END DO

    ! Perform factorization
    DO ii = siz, 1, -1
        ! Get indices for this row
        i1 = sysInd(ii, 1); i2 = sysInd(ii, 2)
        i3 = sysInd(ii, 3); i4 = sysInd(ii, 4)

        ! Only operate up to the diagonal
        IF (i2.GT.ii) i2 = ii
        IF (i4.GT.ii) i4 = ii

        ! First, divide this row by its diagonal value
        DO WHILE(ABS(1.D0 - aa(ii, ii)).GE.1.D-16)
            div = 1.D0/aa(ii, ii)

            IF (ii.LE.he4indx) THEN
                aa(1:i2, ii) = aa(1:i2, ii)*div
                aa(i3:i4, ii) = aa(i3:i4, ii)*div
            ELSE
                aa(1:he4indx, ii) = aa(1:he4indx, ii)*div
                aa(i1:i2, ii) = aa(i1:i2, ii)*div
                aa(i3:i4, ii) = aa(i3:i4, ii)*div
            END IF

            tMatx(ii:tInd(ii), ii) = tMatx(ii:tInd(ii), ii)*div
        END DO

        ! Now eliminate the non diagonal values of column ii
        DO jj = ii - 1, 1, -1
            IF ((sysInd(jj, 4).GE.ii).OR.(sysInd(jj, 2).GE.ii)) THEN
                IF (ABS(aa(ii, jj)).LT.1.D-300) CYCLE

                ! Operation on aa
                multp = aa(ii, jj)
                IF (ii.LE.he4indx) THEN
                    aa(1:i2, jj) = aa(1:i2, jj) - aa(1:i2, ii)*multp
                    aa(i3:i4, jj) = aa(i3:i4, jj) - aa(i3:i4, ii)*multp
                ELSE
                    aa(1:he4indx, jj) = aa(1:he4indx, jj) - &
                                        aa(1:he4indx, ii)*multp
                    aa(i1:i2, jj) = aa(i1:i2, jj) - aa(i1:i2, ii)*multp
                    aa(i3:i4, jj) = aa(i3:i4, jj) - aa(i3:i4, ii)*multp
                END IF

                ! Operation on tMatx
                tMatx(ii:tInd(ii), jj) = tMatx(ii:tInd(ii), jj) - &
                                         tMatx(ii:tInd(ii), ii)*multp

                ! Change aa indices
                sysInd(jj, 1) = MIN(sysInd(ii, 1), sysInd(jj, 1))
                sysInd(jj, 2) = MAX(sysInd(ii, 2), sysInd(jj, 2))
                sysInd(jj, 3) = MIN(sysInd(ii, 3), sysInd(jj, 3))
                sysInd(jj, 4) = MAX(sysInd(ii, 4), sysInd(jj, 4))

                ! Fix overlaps
                IF (sysInd(jj, 2).GE.sysInd(jj, 3)) THEN
                    IF (sysInd(jj, 4).GE.sysInd(jj, 3)) THEN
                        sysInd(jj, 2) = sysInd(jj, 3) - 1
                    END IF
                END IF

                ! Change tMatx indices
                tInd(jj) = MAX(tInd(ii), tInd(jj))
            END IF
        END DO
    END DO

END SUBROUTINE sparseLU

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!! This subroutine performs a sparse gaussian elimination tailored for the  !!!
!!! downwards overshooting matrix.                                           !!!
!!!                                                                          !!!
!!! The input values are:                                                    !!!
!!! -aa, the matrix in which perform the elimination.                        !!!
!!! -tMatx, the matrix holding all the transformations done during the       !!!
!!!         elimination. That way we can transform the independent vector.   !!!
!!! -convecIndex, the array holding the indices for the convective zones as  !!!
!!!               well as the furthermost index they affect.                 !!!
!!! -siz, aa size.                                                           !!!
!!!                                                                          !!!
!!! On output, aa and tMatx have been modified.                              !!!
!!!                                                                          !!!
!!! This subroutine is designed for a TRANSPOSED matrix. Transposed outside. !!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE sparseOvMatrixGauss(aa, tMatx, convecIndex, siz)
    IMPLICIT NONE

    ! Input
    DOUBLE PRECISION::aa(:, :), tMatx(:, :)
    INTEGER::convecIndex(:, :)
    INTEGER::siz

    ! Local
    DOUBLE PRECISION::div
    INTEGER::ii, jj, sIndx, eIndx

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!END OF DECLARATIONS!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! Initialize tMatx
    tMatx = 0.D0
    DO ii = 1, siz
        tMatx(ii, ii) = 1.D0
    END DO

    ! Perform factorization
    DO jj = 1, SIZE(convecIndex(:, 1))
        eIndx = convecIndex(jj, 1)
        sIndx = convecIndex(jj, 2)

        ! Now, from sIndx to eIndx - 1, eliminate the non diagonal values
        ! of row eIndx
        DO ii = sIndx, eIndx - 1
            ! First, divide this row by its diagonal value
            DO WHILE(ABS(1.D0 - aa(ii, ii)).GE.1.D-16)
                div = 1.D0/aa(ii, ii)
                aa(ii, ii) = aa(ii, ii)*div
                aa(eIndx, ii) = aa(eIndx, ii)*div
                tMatx(ii, ii) = tMatx(ii, ii)*div
            END DO

            ! Now eliminate
            aa(eIndx, eIndx) = aa(eIndx, eIndx) - aa(eIndx, ii)*aa(ii, eIndx)
            tMatx(ii, eIndx) = -tMatx(ii, ii)*aa(ii, eIndx)
            aa(ii, eIndx) = 0.D0
        END DO

        ! Make one the diagonal element of the convective shell
        DO WHILE(ABS(1.D0 - aa(eIndx, eIndx)).GE.1.D-16)
            div = 1.D0/aa(eIndx, eIndx)
            aa(eIndx, eIndx) = aa(eIndx, eIndx)*div
            tMatx(sIndx:eIndx, eIndx) = tMatx(sIndx:eIndx, eIndx)*div
        END DO
    END DO

END SUBROUTINE sparseOvMatrixGauss

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!! This subroutine performs a backwards substitution over aa to solve xx    !!!
!!! having bb. After the subroutine exits, the solution will be in xx. The   !!!
!!! matrix tMatx is the transformation matrix for bb.                        !!!
!!! dimSiz is the additional dimension for bb (more than one bb at once).    !!!
!!! This subroutine is the complement to sparseGauss.                        !!!
!!!                                                                          !!!
!!! The input values are:                                                    !!!
!!! -aa, the matrix in which perform the elimination.                        !!!
!!! -tMatx, the matrix holding all the transformations done during the       !!!
!!!          elimination. That way we can transform the independent vector.  !!!
!!! -bb, the array of independent terms arrays.                              !!!
!!! -xx, holds the solutions for the different bb on exit.                   !!!
!!! -convecIndex, the array holding the indices for the convective zones as  !!!
!!!               well as the further index they affect.                     !!!
!!! -siz, aa size.                                                           !!!
!!! -dimSiz, the number of different bb we have to solve simultaneously.     !!!
!!!                                                                          !!!
!!! On output the solution is given in the array xx.                         !!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
SUBROUTINE dimBackSub(aa, tMatx, bb, xx, convecIndex, siz, dimSiz)
    IMPLICIT NONE

    ! Input
    DOUBLE PRECISION::aa(:, :), tMatx(:, :), bb(:, :), xx(:, :)
    INTEGER::convecIndex(:, :), siz, dimSiz

    ! Local
    DOUBLE PRECISION::tot(dimSiz)
    INTEGER::ii, jj, jjindx, times

    !!!!!!!!!!!!!!!!!!!!!!!!!!!!!END OF DECLARATIONS!!!!!!!!!!!!!!!!!!!!!!!!!!!!

    ! First perform bb transformation
    times = 1
    DO ii = 1, siz
        ! Identify if we are in a radiative or convective shell
        IF (ii.EQ.convecIndex(times, 1)) THEN
            tot = 0
            DO jj = convecIndex(times, 2), ii
                tot = tot + tMatx(jj, ii)*bb(:, jj)
            END DO

            xx(:, ii) = tot
            times = times + 1
        ELSE
            xx(:, ii) = tMatx(ii, ii)*bb(:, ii)
        END IF
    END DO

    ! Now solve for every convective shell
    times = 1
    DO WHILE (times.LE.SIZE(convecIndex(:, 1)))
        jjindx = convecIndex(times, 1)
        DO ii = jjindx - 1, convecIndex(times, 2), -1
            xx(:, ii) = xx(:, ii) - aa(jjindx, ii)*xx(:, jjindx)
        END DO

        times = times + 1
    END DO

END SUBROUTINE dimBackSub

END MODULE math_routines


!*****************************************************************************************
!>
!  Test of Fortran Astrodynamics Toolkit - integrate a trajectory near the Earth,
!  using the GGM03C geopotential model.

    program gravity_test

    use fortran_astrodynamics_toolkit

    implicit none

    !spacecraft propagation type:
    ! extend the rk class to include data used in the deriv routine
    type,extends(rk8_10_class) :: spacecraft
        type(geopotential_model_mueller) :: grav   !central body geopotential model
        logical :: first = .true.  !first point is being exported
    end type spacecraft

    integer,parameter  :: n=6    !number of state variables
    real(wp),parameter :: mu_earth  = 398600.4418_wp   !grav. param of earth [km3/s2]
    real(wp),parameter :: orbit_inc = 45.0_wp*deg2rad  !orbit inclination [rad]
    real(wp),parameter :: orbit_sma = 6778.0_wp        !orbit semimajor axis [km]

    !the coefficient file:
    character(len=*),parameter :: gravfile = '../grav/GGM03C.GEO'
    integer,parameter :: grav_n = 10    !max degree
    integer,parameter :: grav_m = 10    !max order

    type(spacecraft) :: s
    real(wp) :: t0,tf,x0(n),dt,xf(n),x02(n)
    logical :: status_ok
    integer :: iunit,istat

    !open output file:
    open(newunit=iunit,file='gravity_test.txt',status='REPLACE',iostat=istat)

    !constructor (main body is Earth):
    call s%initialize(n=n,f=deriv,report=twobody_report)
    call s%grav%initialize(gravfile,grav_n,grav_m,status_ok)
    if (.not. status_ok) stop 'Error'

    !get an initial cartesian state vector:
    ! [circular, 45 deg inclination, radius of 6778 km]
    call els3pv(mu_earth,[mu_earth/orbit_sma,orbit_sma,orbit_inc,zero,zero,zero],x0)

    write(iunit,'(A/,*(E30.16/))') 'Initial state:',x0

    !initial conditions:
    t0 = zero         !initial time (sec)
    dt = 100.0_wp     !time step (sec)
    tf = two*day2sec  !final time (sec)

    !integrate:
    s%first = .true.
    call s%integrate(t0,x0,dt,tf,xf)
    write(iunit,*) ''
    write(iunit,'(A/,*(E30.16/))') 'Final state:',xf

    !cleanup:
    call s%grav%destroy()
    close(iunit,iostat=istat)

!*****************************************************************************************
    contains

    !*********************************************************
        subroutine deriv(me,et,x,xdot)

        !! derivative routine

        implicit none

        class(rk_class),intent(inout)         :: me
        real(wp),intent(in)                   :: et    !! this is ephemeris time
        real(wp),dimension(me%n),intent(in)   :: x
        real(wp),dimension(me%n),intent(out)  :: xdot

        real(wp),dimension(3) :: r,rb,v,a_grav
        real(wp),dimension(3,3) :: rotmat

        select type (me)
        class is (spacecraft)

            !get state:
            r = x(1:3)
            v = x(4:6)

            !input state is inertial frame, have to convert
            ! to body-fixed Earth frame:
            rotmat = icrf_to_iau_earth(et)  !rotation matrix
            rb = matmul(rotmat,r)    !r in body-fixed frame

            !get the acceleration due to the geopotential:
            call me%grav%get_acc(rb,grav_n,grav_m,a_grav)

            !convert acceleration back to inertial frame:
            a_grav = matmul(transpose(rotmat),a_grav)

            !derivative vector:
            xdot(1:3) = v
            xdot(4:6) = a_grav

        end select

        end subroutine deriv
    !*********************************************************

    !*********************************************************
        subroutine twobody_report(me,t,x)

        !! report function - write time,state to console

        implicit none

        class(rk_class),intent(inout)        :: me
        real(wp),intent(in)                  :: t
        real(wp),dimension(me%n),intent(in)  :: x

        select type (me)
        class is (spacecraft)
            if (me%first) then  !print header
                write(iunit,*) ''
                write(iunit,'(*(A15,1X))')  't (sec)','x (km)','y (km)','z (km)',&
                                        'vx (km/s)','vy (km/s)','vz (km/s)'
                me%first = .false.
            end if
        end select

        write(iunit,'(*(F15.6,1X))') t,x

        end subroutine twobody_report
    !*********************************************************

    end program gravity_test
!*****************************************************************************************


cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c  complex.f: Dealing with complex numbers on a comput                 c
c                                                                      c
c  taken from: "Projects in Computational Physics" by Landau and Paez  c
c	       copyrighted by John Wiley and Sons, New York            c
c                                                                      c
c  written by: students in PH465/565, Computational Physics,           c
c	       at Oregon State University                              c
c              code copyrighted by RH Landau                           c
c  supported by: US National Science Foundation, Northwest Alliance    c
c                for Computational Science and Engineering (NACSE),    c
c                US Department of Energy 	                       c
c								       c
c  UNIX (DEC OSF, IBM AIX): f77 complex.f  			       c
c                                                                      c
cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
       	Program complex
c
c complex numbers and functions
       	Implicit none
c declarations
        Complex*16 z, zsqrt, zlog,compOne
       	Real*8 i, pi, phi, x, y, zatan, zatan2
       	pi=3.1415926535897932385E0
	compOne=cmplx(-1.0,0.0)
	write(*,*) sqrt(compOne)
c write header for table
       	Write (*,10) 'phi','x','y','sqrt','log','atan','atan2'
       	Write (*,*) ' '
c loop for angle
 	Do 100 i=0, 2.6, 0.1
           phi    = i * pi
c calculate carthesian representation
           x      = cos(phi)
           y      = sin(phi)
           z      = cmplx(x,y)
c call functions
           zsqrt  = sqrt(z)
           zlog   = log(z)
           zatan  = atan(y/x)
           zatan2 = atan2(y,x)
c write results
           Write (*,20) i,'*pi',x,y,zsqrt,'i',zlog,'i',zatan,zatan2
 100   	Continue
 10    	Format (a4, 2a9, a14, a18, a14, a10)
 20    	Format (f3.1, a3, 3f9.4, f8.4, a1, f9.4, f8.4,a1, 2f9.4)
	Stop 'complex'
       	End


      SUBROUTINE FACTRB ( W, IPIVOT, D, NROW, NCOL, LAST, INFO)
C
C********************************************************************
C
C     adapted from p.132 of  element.numer.analysis  by conte-de boor
C
C     constructs a partial plu factorization, corresponding to steps
C      1,..., last   in gauss elimination, for the matrix  w  of
C      order ( nrow ,  ncol ), using pivoting of scaled rows.
C
C     parameters
C       w       contains the (nrow,ncol) matrix to be partially factored
C               on input, and the partial factorization on output.
C       ipivot  an integer array of length last containing a record of
C               the pivoting strategy used; explicit interchanges
C               are used for pivoting.
C       d       a work array of length nrow used to store row sizes
C               temporarily.
C       nrow    number of rows of w.
C       ncol    number of columns of w.
C       last    number of elimination steps to be carried out.
C       info    on output, zero if the matrix is found to be non-
C               singular, in case a zero pivot was encountered in row
C               n,  info = n on output.
C
C**********************************************************************
C
      INTEGER IPIVOT(NROW),NCOL,LAST,INFO, I,J,K,L,KP1
      DOUBLE PRECISION W(NROW,NCOL),D(NROW), COLMAX,T,S
      DOUBLE PRECISION DABS,DMAX1
C
C...  initialize  d
C
      DO 10 I = 1, NROW
        D(I) = 0.D0
   10 CONTINUE
      DO 20 J = 1, NCOL
        DO 20 I = 1, NROW
          D(I) = DMAX1( D(I) , DABS(W(I,J)))
   20 CONTINUE
C
C...  gauss elimination with pivoting of scaled rows, loop over
C...  k=1,.,last
C
      K = 1
C
C...  as pivot row for k-th step, pick among the rows not yet used,
C...  i.e., from rows  k ,..., nrow , the one whose k-th entry
C...  (compared to the row size) is largest. then, if this row
C...  does not turn out to be row k, interchange row k with this
C...  particular row and redefine ipivot(k).
C
   30      CONTINUE
           IF ( D(K) .EQ. 0.D0 )                    GO TO 90
           IF (K .EQ. NROW)                         GO TO 80
           L = K
           KP1 = K+1
           COLMAX = DABS(W(K,K)) / D(K)
C
C...       find the (relatively) largest pivot
C
           DO 40 I = KP1, NROW
             IF ( DABS(W(I,K)) .LE. COLMAX * D(I) ) GO TO 40
             COLMAX = DABS(W(I,K)) / D(I)
             L = I
   40      CONTINUE
           IPIVOT(K) = L
           T = W(L,K)
           S = D(L)
           IF ( L .EQ. K )                          GO TO 50
             W(L,K) = W(K,K)
             W(K,K) = T
             D(L) = D(K)
             D(K) = S
   50      CONTINUE
C
C...       if pivot element is too small in absolute value, declare
C...       matrix to be noninvertible and quit.
C
           IF ( DABS(T)+D(K) .LE. D(K) )            GO TO 90
C
C...       otherwise, subtract the appropriate multiple of the pivot
C...       row from remaining rows, i.e., the rows (k+1),..., (nrow)
C...       to make k-th entry zero. save the multiplier in its place.
C...       for high performance do this operations column oriented.
C
           T = -1.0D0/T
           DO 60 I = KP1, NROW
   60        W(I,K) = W(I,K) * T
           DO 70 J=KP1,NCOL
             T = W(L,J)
             IF ( L .EQ. K )                        GO TO 62
               W(L,J) = W(K,J)
               W(K,J) = T
   62        IF ( T .EQ. 0.D0 )                     GO TO 70
             DO 64 I = KP1, NROW
   64           W(I,J) = W(I,J) + W(I,K) * T
   70      CONTINUE
           K = KP1
C
C...       check for having reached the next block.
C
           IF ( K .LE. LAST )                       GO TO 30
      RETURN
C
C...  if  last  .eq. nrow , check now that pivot element in last row
C...  is nonzero.
C
   80 IF( DABS(W(NROW,NROW))+D(NROW) .GT. D(NROW) ) RETURN
C
C...  singularity flag set
C
   90 INFO = K
      RETURN
      END


c  find the biggest local minimum value in an array
c  by looking for the difference between the value and
c  a moving average around it.  Return the index of the
c  minimum, min value, and avg value at the minimum.

c  It would probably be a good idea to look for the
c  minimum with the greatest area rather than just
c  the deepest pixel value, but that's more involved.

      subroutine findlocmin(n,arr,minbest,amin,avgbest)

      real arr(n)

c radius of window in which to take average
      iwin = 10
      dwin = 2.0*iwin
c radius of buffer around point in question
      ibuff = 5
      irad = iwin+ibuff

      jmin=1+irad
      jmax=n-irad

c calculate the difference value at jmin
      sum1=0.0
      sum2=0.0
c      np = 0
      do i=1,jmin-ibuff-1
c I could put a test for >bad here
         sum1=sum1+arr(i)
      end do
      do i=jmin+ibuff+1,jmin+irad
         sum2=sum2+arr(i)
      end do
      avg = (sum1+sum2) / dwin
      diffmin = arr(jmin) - avg
      minbest = jmin

      do j=jmin+1,jmax
c  four points move in/out of the windows
         sum1 = sum1 - arr(j-irad-1)
         sum1 = sum1 + arr(j-ibuff-1)
         sum2 = sum2 - arr(j+ibuff)
         sum2 = sum2 + arr(j+irad)
         avg = (sum1 + sum2) / dwin
         diff = arr(j) - avg
         if (diff .lt. diffmin) then
c check to make sure it's actually lower then each of the windows,
c rather than being the point at the bottom of a "cliff"
            if (arr(j) .lt. sum1/iwin .and.
     $           arr(j) .lt. sum2/iwin) then
               diffmin = diff
               minbest = j
               avgbest = avg
            end if
         end if
      end do

      amin = arr(minbest)

      return
      end


      subroutine gen_test_mat(a,lda,na)
      implicit none
      integer lda,na
      integer i,j
      complex*16 a(lda,*)
      real*8 rr,ri

      do j = 1, na
        do i = 1, na
          rr = (11.0d0*i-3.0d0*j)/real(i+j)
          ri = (5.0d0*i-2.0d0*j)/real(i+j)
          a(i,j) = cmplx(rr,ri)
        end do
      end do

      end subroutine


module spherical

!> utility routines to compute various quantities relevant to spherical coordiante systems
use phys_consts, only: wp
implicit none (type, external)

contains

!> radial unit vector (expressed in ECEF cartesian coodinates, components permuted as ix,iy,iz)
pure function er_spherical(theta,phi) result(er)
  real(wp), dimension(:,:,:), intent(in) :: theta,phi
  real(wp), dimension(1:size(theta,1),1:size(theta,2),1:size(theta,3),3) :: er

  ! fixme: error checking

  er(:,:,:,1)=sin(theta)*cos(phi)
  er(:,:,:,2)=sin(theta)*sin(phi)
  er(:,:,:,3)=cos(theta)
end function er_spherical

!> zenith angle unit vector (expressed in ECEF cartesian coodinates
pure function etheta_spherical(theta,phi) result(etheta)
  real(wp), dimension(:,:,:), intent(in) :: theta,phi
  real(wp), dimension(1:size(theta,1),1:size(theta,2),1:size(theta,3),3) :: etheta

  ! fixme: error checking

  etheta(:,:,:,1)=cos(theta)*cos(phi)
  etheta(:,:,:,2)=cos(theta)*sin(phi)
  etheta(:,:,:,3)=-sin(theta)
end function etheta_spherical

!> azimuth angle unit vector (ECEF cart.)
pure function ephi_spherical(theta,phi) result(ephi)
  real(wp), dimension(:,:,:), intent(in) :: theta,phi
  real(wp), dimension(1:size(theta,1),1:size(theta,2),1:size(theta,3),3) :: ephi

  ! fixme: error checking

  ephi(:,:,:,1)=-sin(phi)
  ephi(:,:,:,2)=cos(phi)
  ephi(:,:,:,3)=0
end function ephi_spherical

end module spherical


c       this file contains the following user-callable routines:
c
c
c       routine idzp_id computes the ID of a matrix,
c       to a specified precision.
c
c       routine idzr_id computes the ID of a matrix,
c       to a specified rank.
c
c       routine idz_reconid reconstructs a matrix from its ID.
c
c       routine idz_copycols collects together selected columns
c       of a matrix.
c
c       routine idz_getcols collects together selected columns
c       of a matrix specified by a routine for applying the matrix
c       to arbitrary vectors.
c
c       routine idz_reconint constructs p in the ID a = b p,
c       where the columns of b are a subset of the columns of a,
c       and p is the projection coefficient matrix,
c       given list, krank, and proj output by routines idzr_id
c       or idzp_id.
c
c
ccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
c
c
c
c
        subroutine idzp_id(eps,m,n,a,krank,list,rnorms)
c
c       computes the ID of a, i.e., lists in list the indices
c       of krank columns of a such that
c
c       a(j,list(k))  =  a(j,list(k))
c
c       for all j = 1, ..., m; k = 1, ..., krank, and
c
c                        krank
c       a(j,list(k))  =  Sigma  a(j,list(l)) * proj(l,k-krank)       (*)
c                         l=1
c
c                     +  epsilon(j,k-krank)
c
c       for all j = 1, ..., m; k = krank+1, ..., n,
c
c       for some matrix epsilon dimensioned epsilon(m,n-krank)
c       such that the greatest singular value of epsilon
c       <= the greatest singular value of a * eps.
c       The present routine stores the krank x (n-krank) matrix proj
c       in the memory initially occupied by a.
c
c       input:
c       eps -- relative precision of the resulting ID
c       m -- first dimension of a
c       n -- second dimension of a, as well as the dimension required
c            of list
c       a -- matrix to be ID'd
c
c       output:
c       a -- the first krank*(n-krank) elements of a constitute
c            the krank x (n-krank) interpolation matrix proj
c       krank -- numerical rank
c       list -- list of the indices of the krank columns of a
c               through which the other columns of a are expressed;
c               also, list describes the permutation of proj
c               required to reconstruct a as indicated in (*) above
c       rnorms -- absolute values of the entries on the diagonal
c                 of the triangular matrix used to compute the ID
c                 (these may be used to check the stability of the ID)
c
c       _N.B._: This routine changes a.
c
c       reference:
c       Cheng, Gimbutas, Martinsson, Rokhlin, "On the compression of
c            low-rank matrices," SIAM Journal on Scientific Computing,
c            26 (4): 1389-1404, 2005.
c
        implicit none
        integer m,n,krank,k,list(n),iswap
        real*8 eps,rnorms(n)
        complex*16 a(m,n)
c
c
c       QR decompose a.
c
        call idzp_qrpiv(eps,m,n,a,krank,list,rnorms)
c
c
c       Build the list of columns chosen in a
c       by multiplying together the permutations in list,
c       with the permutation swapping 1 and list(1) taken rightmost
c       in the product, that swapping 2 and list(2) taken next
c       rightmost, ..., that swapping krank and list(krank) taken
c       leftmost.
c
        do k = 1,n
          rnorms(k) = k
        enddo ! k
c
        if(krank .gt. 0) then
          do k = 1,krank
c
c           Swap rnorms(k) and rnorms(list(k)).
c
            iswap = rnorms(k)
            rnorms(k) = rnorms(list(k))
            rnorms(list(k)) = iswap
c
          enddo ! k
        endif
c
        do k = 1,n
          list(k) = rnorms(k)
        enddo ! k
c
c
c       Fill rnorms for the output.
c
        if(krank .gt. 0) then
c
          do k = 1,krank
            rnorms(k) = a(k,k)
          enddo ! k
c
        endif
c
c
c       Backsolve for proj, storing it at the beginning of a.
c
        if(krank .gt. 0) then
          call idz_lssolve(m,n,a,krank)
        endif
c
c
        return
        end
c
c
c
c
        subroutine idzr_id(m,n,a,krank,list,rnorms)
c
c       computes the ID of a, i.e., lists in list the indices
c       of krank columns of a such that
c
c       a(j,list(k))  =  a(j,list(k))
c
c       for all j = 1, ..., m; k = 1, ..., krank, and
c
c                        krank
c       a(j,list(k))  =  Sigma  a(j,list(l)) * proj(l,k-krank)       (*)
c                         l=1
c
c                     +  epsilon(j,k-krank)
c
c       for all j = 1, ..., m; k = krank+1, ..., n,
c
c       for some matrix epsilon, dimensioned epsilon(m,n-krank),
c       whose norm is (hopefully) minimized by the pivoting procedure.
c       The present routine stores the krank x (n-krank) matrix proj
c       in the memory initially occupied by a.
c
c       input:
c       m -- first dimension of a
c       n -- second dimension of a, as well as the dimension required
c            of list
c       a -- matrix to be ID'd
c       krank -- desired rank of the output matrix
c                (please note that if krank > m or krank > n,
c                then the rank of the output matrix will be
c                less than krank)
c
c       output:
c       a -- the first krank*(n-krank) elements of a constitute
c            the krank x (n-krank) interpolation matrix proj
c       list -- list of the indices of the krank columns of a
c               through which the other columns of a are expressed;
c               also, list describes the permutation of proj
c               required to reconstruct a as indicated in (*) above
c       rnorms -- absolute values of the entries on the diagonal
c                 of the triangular matrix used to compute the ID
c                 (these may be used to check the stability of the ID)
c
c       _N.B._: This routine changes a.
c
c       reference:
c       Cheng, Gimbutas, Martinsson, Rokhlin, "On the compression of
c            low-rank matrices," SIAM Journal on Scientific Computing,
c            26 (4): 1389-1404, 2005.
c
        implicit none
        integer m,n,krank,j,k,list(n),iswap
        real*8 rnorms(n),ss
        complex*16 a(m,n)
c
c
c       QR decompose a.
c
        call idzr_qrpiv(m,n,a,krank,list,rnorms)
c
c
c       Build the list of columns chosen in a
c       by multiplying together the permutations in list,
c       with the permutation swapping 1 and list(1) taken rightmost
c       in the product, that swapping 2 and list(2) taken next
c       rightmost, ..., that swapping krank and list(krank) taken
c       leftmost.
c
        do k = 1,n
          rnorms(k) = k
        enddo ! k
c
        if(krank .gt. 0) then
          do k = 1,krank
c
c           Swap rnorms(k) and rnorms(list(k)).
c
            iswap = rnorms(k)
            rnorms(k) = rnorms(list(k))
            rnorms(list(k)) = iswap
c
          enddo ! k
        endif
c
        do k = 1,n
          list(k) = rnorms(k)
        enddo ! k
c
c
c       Fill rnorms for the output.
c
        ss = 0
c
        do k = 1,krank
          rnorms(k) = a(k,k)
          ss = ss + rnorms(k)**2
        enddo ! k
c
c
c       Backsolve for proj, storing it at the beginning of a.
c
        if(krank .gt. 0 .and. ss .gt. 0) then
          call idz_lssolve(m,n,a,krank)
        endif
c
        if(ss .eq. 0) then
c
          do k = 1,n
            do j = 1,m
c
              a(j,k) = 0
c
            enddo ! j
          enddo ! k
c
        endif
c
c
        return
        end
c
c
c
c
        subroutine idz_reconid(m,krank,col,n,list,proj,approx)
c
c       reconstructs the matrix that the routine idzp_id
c       or idzr_id has decomposed, using the columns col
c       of the reconstructed matrix whose indices are listed in list,
c       in addition to the interpolation matrix proj.
c
c       input:
c       m -- first dimension of cols and approx
c       krank -- first dimension of cols and proj; also,
c                n-krank is the second dimension of proj
c       col -- columns of the matrix to be reconstructed
c       n -- second dimension of approx; also,
c            n-krank is the second dimension of proj
c       list(k) -- index of col(1:m,k) in the reconstructed matrix
c                  when k <= krank; in general, list describes
c                  the permutation required for reconstruction
c                  via cols and proj
c       proj -- interpolation matrix
c
c       output:
c       approx -- reconstructed matrix
c
        implicit none
        integer m,n,krank,j,k,l,list(n)
        complex*16 col(m,krank),proj(krank,n-krank),approx(m,n)
c
c
        do j = 1,m
          do k = 1,n
c
            approx(j,list(k)) = 0
c
c           Add in the contributions due to the identity matrix.
c
            if(k .le. krank) then
              approx(j,list(k)) = approx(j,list(k)) + col(j,k)
            endif
c
c           Add in the contributions due to proj.
c
            if(k .gt. krank) then
              if(krank .gt. 0) then
c
                do l = 1,krank
                  approx(j,list(k)) = approx(j,list(k))
     1                              + col(j,l)*proj(l,k-krank)
                enddo ! l
c
              endif
            endif
c
          enddo ! k
        enddo ! j
c
c
        return
        end
c
c
c
c
        subroutine idz_lssolve(m,n,a,krank)
c
c       backsolves for proj satisfying R_11 proj ~ R_12,
c       where R_11 = a(1:krank,1:krank)
c       and R_12 = a(1:krank,krank+1:n).
c       This routine overwrites the beginning of a with proj.
c
c       input:
c       m -- first dimension of a
c       n -- second dimension of a; also,
c            n-krank is the second dimension of proj
c       a -- trapezoidal input matrix
c       krank -- first dimension of proj; also,
c                n-krank is the second dimension of proj
c
c       output:
c       a -- the first krank*(n-krank) elements of a constitute
c            the krank x (n-krank) matrix proj
c
        implicit none
        integer m,n,krank,j,k,l
        real*8 rnumer,rdenom
        complex*16 a(m,n),sum
c
c
c       Overwrite a(1:krank,krank+1:n) with proj.
c
        do k = 1,n-krank
          do j = krank,1,-1
c
            sum = 0
c
            do l = j+1,krank
              sum = sum+a(j,l)*a(l,krank+k)
            enddo ! l
c
            a(j,krank+k) = a(j,krank+k)-sum
c
c           Make sure that the entry in proj won't be too big;
c           set the entry to 0 when roundoff would make it too big
c           (in which case a(j,j) is so small that the contribution
c           from this entry in proj to the overall matrix approximation
c           is supposed to be negligible).
c
            rnumer = a(j,krank+k)*conjg(a(j,krank+k))
            rdenom = a(j,j)*conjg(a(j,j))
c
            if(rnumer .lt. 2**30*rdenom) then
              a(j,krank+k) = a(j,krank+k)/a(j,j)
            else
              a(j,krank+k) = 0
            endif
c
          enddo ! j
        enddo ! k
c
c
c       Move proj from a(1:krank,krank+1:n) to the beginning of a.
c
        call idz_moverup(m,n,krank,a)
c
c
        return
        end
c
c
c
c
        subroutine idz_moverup(m,n,krank,a)
c
c       moves the krank x (n-krank) matrix in a(1:krank,krank+1:n),
c       where a is initially dimensioned m x n, to the beginning of a.
c       (This is not the most natural way to code the move,
c       but one of my usually well-behaved compilers chokes
c       on more natural ways.)
c
c       input:
c       m -- initial first dimension of a
c       n -- initial second dimension of a
c       krank -- number of rows to move
c       a -- m x n matrix whose krank x (n-krank) block
c            a(1:krank,krank+1:n) is to be moved
c
c       output:
c       a -- array starting with the moved krank x (n-krank) block
c
        implicit none
        integer m,n,krank,j,k
        complex*16 a(m*n)
c
c
        do k = 1,n-krank
          do j = 1,krank
            a(j+krank*(k-1)) = a(j+m*(krank+k-1))
          enddo ! j
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idz_getcols(m,n,matvec,p1,p2,p3,p4,krank,list,
     1                         col,x)
c
c       collects together the columns of the matrix a indexed by list
c       into the matrix col, where routine matvec applies a
c       to an arbitrary vector.
c
c       input:
c       m -- first dimension of a
c       n -- second dimension of a
c       matvec -- routine which applies a to an arbitrary vector;
c                 this routine must have a calling sequence of the form
c
c                 matvec(m,x,n,y,p1,p2,p3,p4)
c
c                 where m is the length of x,
c                 x is the vector to which the matrix is to be applied,
c                 n is the length of y,
c                 y is the product of the matrix and x,
c                 and p1, p2, p3, and p4 are user-specified parameters
c       p1 -- parameter to be passed to routine matvec
c       p2 -- parameter to be passed to routine matvec
c       p3 -- parameter to be passed to routine matvec
c       p4 -- parameter to be passed to routine matvec
c       krank -- number of columns to be extracted
c       list -- indices of the columns to be extracted
c
c       output:
c       col -- columns of a indexed by list
c
c       work:
c       x -- must be at least n complex*16 elements long
c
        implicit none
        integer m,n,krank,list(krank),j,k
        complex*16 col(m,krank),x(n),p1,p2,p3,p4
        external matvec
c
c
        do j = 1,krank
c
          do k = 1,n
            x(k) = 0
          enddo ! k
c
          x(list(j)) = 1
c
          call matvec(n,x,m,col(1,j),p1,p2,p3,p4)
c
        enddo ! j
c
c
        return
        end
c
c
c
c
        subroutine idz_reconint(n,list,krank,proj,p)
c
c       constructs p in the ID a = b p,
c       where the columns of b are a subset of the columns of a,
c       and p is the projection coefficient matrix,
c       given list, krank, and proj output
c       by routines idzp_id or idzr_id.
c
c       input:
c       n -- part of the second dimension of proj and p
c       list -- list of columns retained from the original matrix
c               in the ID
c       krank -- rank of the ID
c       proj -- matrix of projection coefficients in the ID
c
c       output:
c       p -- projection matrix in the ID
c
        implicit none
        integer n,krank,list(n),j,k
        complex*16 proj(krank,n-krank),p(krank,n)
c
c
        do k = 1,krank
          do j = 1,n
c
            if(j .le. krank) then
              if(j .eq. k) p(k,list(j)) = 1
              if(j .ne. k) p(k,list(j)) = 0
            endif
c
            if(j .gt. krank) then
              p(k,list(j)) = proj(k,j-krank)
            endif
c
          enddo ! j
        enddo ! k
c
c
        return
        end
c
c
c
c
        subroutine idz_copycols(m,n,a,krank,list,col)
c
c       collects together the columns of the matrix a indexed by list
c       into the matrix col.
c
c       input:
c       m -- first dimension of a
c       n -- second dimension of a
c       a -- matrix whose columns are to be extracted
c       krank -- number of columns to be extracted
c       list -- indices of the columns to be extracted
c
c       output:
c       col -- columns of a indexed by list
c
        implicit none
        integer m,n,krank,list(krank),j,k
        complex*16 a(m,n),col(m,krank)
c
c
        do k = 1,krank
          do j = 1,m
c
            col(j,k) = a(j,list(k))
c
          enddo ! j
        enddo ! k
c
c
        return
        end


*> \brief \b DGET52
*
*  =========== DOCUMENTATION ===========
*
* Online html documentation available at
*            http://www.netlib.org/lapack/explore-html/
*
*  Definition:
*  ===========
*
*       SUBROUTINE DGET52( LEFT, N, A, LDA, B, LDB, E, LDE, ALPHAR,
*                          ALPHAI, BETA, WORK, RESULT )
*
*       .. Scalar Arguments ..
*       LOGICAL            LEFT
*       INTEGER            LDA, LDB, LDE, N
*       ..
*       .. Array Arguments ..
*       DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
*      $                   B( LDB, * ), BETA( * ), E( LDE, * ),
*      $                   RESULT( 2 ), WORK( * )
*       ..
*
*
*> \par Purpose:
*  =============
*>
*> \verbatim
*>
*> DGET52  does an eigenvector check for the generalized eigenvalue
*> problem.
*>
*> The basic test for right eigenvectors is:
*>
*>                           | b(j) A E(j) -  a(j) B E(j) |
*>         RESULT(1) = max   -------------------------------
*>                      j    n ulp max( |b(j) A|, |a(j) B| )
*>
*> using the 1-norm.  Here, a(j)/b(j) = w is the j-th generalized
*> eigenvalue of A - w B, or, equivalently, b(j)/a(j) = m is the j-th
*> generalized eigenvalue of m A - B.
*>
*> For real eigenvalues, the test is straightforward.  For complex
*> eigenvalues, E(j) and a(j) are complex, represented by
*> Er(j) + i*Ei(j) and ar(j) + i*ai(j), resp., so the test for that
*> eigenvector becomes
*>
*>                 max( |Wr|, |Wi| )
*>     --------------------------------------------
*>     n ulp max( |b(j) A|, (|ar(j)|+|ai(j)|) |B| )
*>
*> where
*>
*>     Wr = b(j) A Er(j) - ar(j) B Er(j) + ai(j) B Ei(j)
*>
*>     Wi = b(j) A Ei(j) - ai(j) B Er(j) - ar(j) B Ei(j)
*>
*>                         T   T  _
*> For left eigenvectors, A , B , a, and b  are used.
*>
*> DGET52 also tests the normalization of E.  Each eigenvector is
*> supposed to be normalized so that the maximum "absolute value"
*> of its elements is 1, where in this case, "absolute value"
*> of a complex value x is  |Re(x)| + |Im(x)| ; let us call this
*> maximum "absolute value" norm of a vector v  M(v).
*> if a(j)=b(j)=0, then the eigenvector is set to be the jth coordinate
*> vector.  The normalization test is:
*>
*>         RESULT(2) =      max       | M(v(j)) - 1 | / ( n ulp )
*>                    eigenvectors v(j)
*> \endverbatim
*
*  Arguments:
*  ==========
*
*> \param[in] LEFT
*> \verbatim
*>          LEFT is LOGICAL
*>          =.TRUE.:  The eigenvectors in the columns of E are assumed
*>                    to be *left* eigenvectors.
*>          =.FALSE.: The eigenvectors in the columns of E are assumed
*>                    to be *right* eigenvectors.
*> \endverbatim
*>
*> \param[in] N
*> \verbatim
*>          N is INTEGER
*>          The size of the matrices.  If it is zero, DGET52 does
*>          nothing.  It must be at least zero.
*> \endverbatim
*>
*> \param[in] A
*> \verbatim
*>          A is DOUBLE PRECISION array, dimension (LDA, N)
*>          The matrix A.
*> \endverbatim
*>
*> \param[in] LDA
*> \verbatim
*>          LDA is INTEGER
*>          The leading dimension of A.  It must be at least 1
*>          and at least N.
*> \endverbatim
*>
*> \param[in] B
*> \verbatim
*>          B is DOUBLE PRECISION array, dimension (LDB, N)
*>          The matrix B.
*> \endverbatim
*>
*> \param[in] LDB
*> \verbatim
*>          LDB is INTEGER
*>          The leading dimension of B.  It must be at least 1
*>          and at least N.
*> \endverbatim
*>
*> \param[in] E
*> \verbatim
*>          E is DOUBLE PRECISION array, dimension (LDE, N)
*>          The matrix of eigenvectors.  It must be O( 1 ).  Complex
*>          eigenvalues and eigenvectors always come in pairs, the
*>          eigenvalue and its conjugate being stored in adjacent
*>          elements of ALPHAR, ALPHAI, and BETA.  Thus, if a(j)/b(j)
*>          and a(j+1)/b(j+1) are a complex conjugate pair of
*>          generalized eigenvalues, then E(,j) contains the real part
*>          of the eigenvector and E(,j+1) contains the imaginary part.
*>          Note that whether E(,j) is a real eigenvector or part of a
*>          complex one is specified by whether ALPHAI(j) is zero or not.
*> \endverbatim
*>
*> \param[in] LDE
*> \verbatim
*>          LDE is INTEGER
*>          The leading dimension of E.  It must be at least 1 and at
*>          least N.
*> \endverbatim
*>
*> \param[in] ALPHAR
*> \verbatim
*>          ALPHAR is DOUBLE PRECISION array, dimension (N)
*>          The real parts of the values a(j) as described above, which,
*>          along with b(j), define the generalized eigenvalues.
*>          Complex eigenvalues always come in complex conjugate pairs
*>          a(j)/b(j) and a(j+1)/b(j+1), which are stored in adjacent
*>          elements in ALPHAR, ALPHAI, and BETA.  Thus, if the j-th
*>          and (j+1)-st eigenvalues form a pair, ALPHAR(j+1)/BETA(j+1)
*>          is assumed to be equal to ALPHAR(j)/BETA(j).
*> \endverbatim
*>
*> \param[in] ALPHAI
*> \verbatim
*>          ALPHAI is DOUBLE PRECISION array, dimension (N)
*>          The imaginary parts of the values a(j) as described above,
*>          which, along with b(j), define the generalized eigenvalues.
*>          If ALPHAI(j)=0, then the eigenvalue is real, otherwise it
*>          is part of a complex conjugate pair.  Complex eigenvalues
*>          always come in complex conjugate pairs a(j)/b(j) and
*>          a(j+1)/b(j+1), which are stored in adjacent elements in
*>          ALPHAR, ALPHAI, and BETA.  Thus, if the j-th and (j+1)-st
*>          eigenvalues form a pair, ALPHAI(j+1)/BETA(j+1) is assumed to
*>          be equal to  -ALPHAI(j)/BETA(j).  Also, nonzero values in
*>          ALPHAI are assumed to always come in adjacent pairs.
*> \endverbatim
*>
*> \param[in] BETA
*> \verbatim
*>          BETA is DOUBLE PRECISION array, dimension (N)
*>          The values b(j) as described above, which, along with a(j),
*>          define the generalized eigenvalues.
*> \endverbatim
*>
*> \param[out] WORK
*> \verbatim
*>          WORK is DOUBLE PRECISION array, dimension (N**2+N)
*> \endverbatim
*>
*> \param[out] RESULT
*> \verbatim
*>          RESULT is DOUBLE PRECISION array, dimension (2)
*>          The values computed by the test described above.  If A E or
*>          B E is likely to overflow, then RESULT(1:2) is set to
*>          10 / ulp.
*> \endverbatim
*
*  Authors:
*  ========
*
*> \author Univ. of Tennessee
*> \author Univ. of California Berkeley
*> \author Univ. of Colorado Denver
*> \author NAG Ltd.
*
*> \date November 2011
*
*> \ingroup double_eig
*
*  =====================================================================
      SUBROUTINE DGET52( LEFT, N, A, LDA, B, LDB, E, LDE, ALPHAR,
     $                   ALPHAI, BETA, WORK, RESULT )
*
*  -- LAPACK test routine (version 3.4.0) --
*  -- LAPACK is a software package provided by Univ. of Tennessee,    --
*  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
*     November 2011
*
*     .. Scalar Arguments ..
      LOGICAL            LEFT
      INTEGER            LDA, LDB, LDE, N
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), ALPHAI( * ), ALPHAR( * ),
     $                   B( LDB, * ), BETA( * ), E( LDE, * ),
     $                   RESULT( 2 ), WORK( * )
*     ..
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, TEN
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0, TEN = 10.0D0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            ILCPLX
      CHARACTER          NORMAB, TRANS
      INTEGER            J, JVEC
      DOUBLE PRECISION   ABMAX, ACOEF, ALFMAX, ANORM, BCOEFI, BCOEFR,
     $                   BETMAX, BNORM, ENORM, ENRMER, ERRNRM, SAFMAX,
     $                   SAFMIN, SALFI, SALFR, SBETA, SCALE, TEMP1, ULP
*     ..
*     .. External Functions ..
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           DLAMCH, DLANGE
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGEMV
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, MAX
*     ..
*     .. Executable Statements ..
*
      RESULT( 1 ) = ZERO
      RESULT( 2 ) = ZERO
      IF( N.LE.0 )
     $   RETURN
*
      SAFMIN = DLAMCH( 'Safe minimum' )
      SAFMAX = ONE / SAFMIN
      ULP = DLAMCH( 'Epsilon' )*DLAMCH( 'Base' )
*
      IF( LEFT ) THEN
         TRANS = 'T'
         NORMAB = 'I'
      ELSE
         TRANS = 'N'
         NORMAB = 'O'
      END IF
*
*     Norm of A, B, and E:
*
      ANORM = MAX( DLANGE( NORMAB, N, N, A, LDA, WORK ), SAFMIN )
      BNORM = MAX( DLANGE( NORMAB, N, N, B, LDB, WORK ), SAFMIN )
      ENORM = MAX( DLANGE( 'O', N, N, E, LDE, WORK ), ULP )
      ALFMAX = SAFMAX / MAX( ONE, BNORM )
      BETMAX = SAFMAX / MAX( ONE, ANORM )
*
*     Compute error matrix.
*     Column i = ( b(i) A - a(i) B ) E(i) / max( |a(i) B| |b(i) A| )
*
      ILCPLX = .FALSE.
      DO 10 JVEC = 1, N
         IF( ILCPLX ) THEN
*
*           2nd Eigenvalue/-vector of pair -- do nothing
*
            ILCPLX = .FALSE.
         ELSE
            SALFR = ALPHAR( JVEC )
            SALFI = ALPHAI( JVEC )
            SBETA = BETA( JVEC )
            IF( SALFI.EQ.ZERO ) THEN
*
*              Real eigenvalue and -vector
*
               ABMAX = MAX( ABS( SALFR ), ABS( SBETA ) )
               IF( ABS( SALFR ).GT.ALFMAX .OR. ABS( SBETA ).GT.
     $             BETMAX .OR. ABMAX.LT.ONE ) THEN
                  SCALE = ONE / MAX( ABMAX, SAFMIN )
                  SALFR = SCALE*SALFR
                  SBETA = SCALE*SBETA
               END IF
               SCALE = ONE / MAX( ABS( SALFR )*BNORM,
     $                 ABS( SBETA )*ANORM, SAFMIN )
               ACOEF = SCALE*SBETA
               BCOEFR = SCALE*SALFR
               CALL DGEMV( TRANS, N, N, ACOEF, A, LDA, E( 1, JVEC ), 1,
     $                     ZERO, WORK( N*( JVEC-1 )+1 ), 1 )
               CALL DGEMV( TRANS, N, N, -BCOEFR, B, LDA, E( 1, JVEC ),
     $                     1, ONE, WORK( N*( JVEC-1 )+1 ), 1 )
            ELSE
*
*              Complex conjugate pair
*
               ILCPLX = .TRUE.
               IF( JVEC.EQ.N ) THEN
                  RESULT( 1 ) = TEN / ULP
                  RETURN
               END IF
               ABMAX = MAX( ABS( SALFR )+ABS( SALFI ), ABS( SBETA ) )
               IF( ABS( SALFR )+ABS( SALFI ).GT.ALFMAX .OR.
     $             ABS( SBETA ).GT.BETMAX .OR. ABMAX.LT.ONE ) THEN
                  SCALE = ONE / MAX( ABMAX, SAFMIN )
                  SALFR = SCALE*SALFR
                  SALFI = SCALE*SALFI
                  SBETA = SCALE*SBETA
               END IF
               SCALE = ONE / MAX( ( ABS( SALFR )+ABS( SALFI ) )*BNORM,
     $                 ABS( SBETA )*ANORM, SAFMIN )
               ACOEF = SCALE*SBETA
               BCOEFR = SCALE*SALFR
               BCOEFI = SCALE*SALFI
               IF( LEFT ) THEN
                  BCOEFI = -BCOEFI
               END IF
*
               CALL DGEMV( TRANS, N, N, ACOEF, A, LDA, E( 1, JVEC ), 1,
     $                     ZERO, WORK( N*( JVEC-1 )+1 ), 1 )
               CALL DGEMV( TRANS, N, N, -BCOEFR, B, LDA, E( 1, JVEC ),
     $                     1, ONE, WORK( N*( JVEC-1 )+1 ), 1 )
               CALL DGEMV( TRANS, N, N, BCOEFI, B, LDA, E( 1, JVEC+1 ),
     $                     1, ONE, WORK( N*( JVEC-1 )+1 ), 1 )
*
               CALL DGEMV( TRANS, N, N, ACOEF, A, LDA, E( 1, JVEC+1 ),
     $                     1, ZERO, WORK( N*JVEC+1 ), 1 )
               CALL DGEMV( TRANS, N, N, -BCOEFI, B, LDA, E( 1, JVEC ),
     $                     1, ONE, WORK( N*JVEC+1 ), 1 )
               CALL DGEMV( TRANS, N, N, -BCOEFR, B, LDA, E( 1, JVEC+1 ),
     $                     1, ONE, WORK( N*JVEC+1 ), 1 )
            END IF
         END IF
   10 CONTINUE
*
      ERRNRM = DLANGE( 'One', N, N, WORK, N, WORK( N**2+1 ) ) / ENORM
*
*     Compute RESULT(1)
*
      RESULT( 1 ) = ERRNRM / ULP
*
*     Normalization of E:
*
      ENRMER = ZERO
      ILCPLX = .FALSE.
      DO 40 JVEC = 1, N
         IF( ILCPLX ) THEN
            ILCPLX = .FALSE.
         ELSE
            TEMP1 = ZERO
            IF( ALPHAI( JVEC ).EQ.ZERO ) THEN
               DO 20 J = 1, N
                  TEMP1 = MAX( TEMP1, ABS( E( J, JVEC ) ) )
   20          CONTINUE
               ENRMER = MAX( ENRMER, TEMP1-ONE )
            ELSE
               ILCPLX = .TRUE.
               DO 30 J = 1, N
                  TEMP1 = MAX( TEMP1, ABS( E( J, JVEC ) )+
     $                    ABS( E( J, JVEC+1 ) ) )
   30          CONTINUE
               ENRMER = MAX( ENRMER, TEMP1-ONE )
            END IF
         END IF
   40 CONTINUE
*
*     Compute RESULT(2) : the normalization error in E.
*
      RESULT( 2 ) = ENRMER / ( DBLE( N )*ULP )
*
      RETURN
*
*     End of DGET52
*
      END


!============================================================================
! CALCULO DE LA ENERGIA DE UNA DE LAS PARTICULAS DE LA CELDA
!
! Autor: Martin Alejandro Paredes Sosa
!============================================================================
Subroutine EnergyPart(Rx1, Ry1, i, V)
  Use cte
  Implicit None
  Real :: V, VNew, Dist, Rx1, Rxd, Ry1, Ryd
  Integer :: i, j
  !INICIAR ENERGIA EN 0
  V = 0

  BuscarPart: Do j=1, N

     NoLaMisma: If(i .NE. j) Then

        Rxd = Rx1 - X(j)
        Ryd = Ry1 - Y(j)

        !CONDICION DE IMAGEN MINIMA (LOCALIZAR PARTICULAS EN CELDAS CERCANAS)
        Rxd = Rxd - BoxL*Anint(Rxd/BoxL)
        Ryd = Ryd - BoxL*Anint(Ryd/BoxL)

        !INGRESANDO MODELO DE INTERACCON (DISCOS DUROS)
        Dist = sqrt( Rxd*Rxd + Ryd*Ryd  )

        ChecarInter: If(Dist .LT. RCut)  Then

           ChecarCercania: If (Dist .LE. 1.0) Then
              VNew = 1.0E+10
           Else
              VNew = 0
           End If ChecarCercania
           V = V + VNew
        End If ChecarInter

     End If NoLaMisma

  End Do BuscarPart

End Subroutine EnergyPart