*DECK INTYD
      SUBROUTINE INTYD (T, K, YH, NYH, DKY, IFLAG)
C***BEGIN PROLOGUE  INTYD
C***SUBSIDIARY
C***PURPOSE  Subsidiary to DEBDF
C***LIBRARY   SLATEC
C***TYPE      SINGLE PRECISION (INTYD-S, DINTYD-D)
C***AUTHOR  Watts, H. A., (SNLA)
C***DESCRIPTION
C
C   INTYD approximates the solution and derivatives at T by polynomial
C   interpolation. Must be used in conjunction with the integrator
C   package DEBDF.
C ----------------------------------------------------------------------
C INTYD computes interpolated values of the K-th derivative of the
C dependent variable vector Y, and stores it in DKY.
C This routine is called by DEBDF with K = 0,1 and T = TOUT, but may
C also be called by the user for any K up to the current order.
C (see detailed instructions in LSODE usage documentation.)
C ----------------------------------------------------------------------
C The computed values in DKY are gotten by interpolation using the
C Nordsieck history array YH.  This array corresponds uniquely to a
C vector-valued polynomial of degree NQCUR or less, and DKY is set
C to the K-th derivative of this polynomial at T.
C The formula for DKY is..
C              Q
C  DKY(I)  =  sum  C(J,K) * (T - TN)**(J-K) * H**(-J) * YH(I,J+1)
C             J=K
C where  C(J,K) = J*(J-1)*...*(J-K+1), Q = NQCUR, TN = TCUR, H = HCUR.
C The quantities  NQ = NQCUR, L = NQ+1, N = NEQ, TN, and H are
C communicated by common.  The above sum is done in reverse order.
C IFLAG is returned negative if either K or T is out of bounds.
C ----------------------------------------------------------------------
C
C***SEE ALSO  DEBDF
C***ROUTINES CALLED  (NONE)
C***COMMON BLOCKS    DEBDF1
C***REVISION HISTORY  (YYMMDD)
C   800901  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900328  Added TYPE section.  (WRB)
C   910722  Updated AUTHOR section.  (ALS)
C***END PROLOGUE  INTYD
C
CLLL. OPTIMIZE
      INTEGER K, NYH, IFLAG, I, IC, IER, IOWND, IOWNS, J, JB, JB2,
     1   JJ, JJ1, JP1, JSTART, KFLAG, L, MAXORD, METH, MITER, N, NFE,
     2   NJE, NQ, NQU, NST
      REAL T, YH, DKY,
     1   ROWND, ROWNS, EL0, H, HMIN, HMXI, HU, TN, UROUND,
     2   C, R, S, TP
      DIMENSION YH(NYH,*), DKY(*)
      COMMON /DEBDF1/ ROWND, ROWNS(210),
     1   EL0, H, HMIN, HMXI, HU, TN, UROUND, IOWND(14), IOWNS(6),
     2   IER, JSTART, KFLAG, L, METH, MITER, MAXORD, N, NQ, NST, NFE,
     3   NJE, NQU
C
C***FIRST EXECUTABLE STATEMENT  INTYD
      IFLAG = 0
      IF (K .LT. 0 .OR. K .GT. NQ) GO TO 80
      TP = TN - HU*(1.0E0 + 100.0E0*UROUND)
      IF ((T-TP)*(T-TN) .GT. 0.0E0) GO TO 90
C
      S = (T - TN)/H
      IC = 1
      IF (K .EQ. 0) GO TO 15
      JJ1 = L - K
      DO 10 JJ = JJ1,NQ
 10     IC = IC*JJ
 15   C = IC
      DO 20 I = 1,N
 20     DKY(I) = C*YH(I,L)
      IF (K .EQ. NQ) GO TO 55
      JB2 = NQ - K
      DO 50 JB = 1,JB2
        J = NQ - JB
        JP1 = J + 1
        IC = 1
        IF (K .EQ. 0) GO TO 35
        JJ1 = JP1 - K
        DO 30 JJ = JJ1,J
 30       IC = IC*JJ
 35     C = IC
        DO 40 I = 1,N
 40       DKY(I) = C*YH(I,JP1) + S*DKY(I)
 50     CONTINUE
      IF (K .EQ. 0) RETURN
 55   R = H**(-K)
      DO 60 I = 1,N
 60     DKY(I) = R*DKY(I)
      RETURN
C
 80   IFLAG = -1
      RETURN
 90   IFLAG = -2
      RETURN
C----------------------- END OF SUBROUTINE INTYD -----------------------
      END


module mask
implicit none

contains

subroutine mask_interpolation_non_uniform (points,Npts,nxp,nyp,nzp,xp,yp,zp,&
                           mask)
	 implicit none

	 !input
	 integer, intent(in) :: Npts,nxp,nyp, nzp

	 real(8), dimension(nxp), intent(in) :: xp
	 real(8), dimension(nyp), intent(in) :: yp
	 real(8), dimension(nzp), intent(in) :: zp

	 real(8), dimension(Npts,3), intent(in) :: points
	  real(8), dimension(nxp-1, nyp-1, nzp-1), intent(out) :: mask

     !constant
	 real(8) :: dx, dy, dz, x, y, z
	 integer :: indexx1, indexy1, indexz1
	 integer :: ip

     !$OMP PARALLEL DO DEFAULT(SHARED) &
     !$OMP PRIVATE(ip,indexx1, indexy1, indexz1,x, y, z)

	 Do ip=1, Npts
	 	x=points(ip,1)
	    y=points(ip,2)
		z=points(ip,3)

		indexx1=MINLOC(ABS(xp-x),  DIM=1)
		IF (xp(indexx1) < x) THEN
			indexx1=indexx1
		ELSE
		    indexx1=indexx1-1
		END IF

		IF (indexx1 <1) THEN
			indexx1=1
		END IF

		IF (indexx1 >=nxp) THEN
			indexx1=nxp-1
		END IF

		indexy1=MINLOC(ABS(yp-y), DIM=1)
		IF (yp(indexy1) < y) THEN
			indexy1=indexy1
		ELSE
		    indexy1=indexy1-1
		END IF

		IF (indexy1 <1) THEN
			indexy1=1
		END IF

		IF (indexy1 >=nyp) THEN
			indexy1=nyp-1
		END IF

		indexz1=MINLOC(ABS(zp-z), DIM=1)
		IF (zp(indexz1) < z) THEN
			indexz1=indexz1
		ELSE
		    indexz1=indexz1-1
		END IF

		IF (indexz1 <1) THEN
			indexz1=1
		END IF

		IF (indexz1 >=nzp) THEN
			indexz1=nzp-1
		END IF

   mask(indexx1, indexy1, indexz1) = 1

	END DO

	!$OMP END PARALLEL DO

end subroutine mask_interpolation_non_uniform

end module mask


!----------------------------------------------------------------------
!----------------------------------------------------------------------
!     brf  :  A parabolic PDE (the Brusselator)
!----------------------------------------------------------------------
!----------------------------------------------------------------------
!     (Discretized in space by fourth order finite differences)
!----------------------------------------------------------------------
!----------------------------------------------------------------------
! NOTE: The value of the constant NE is defined below in a module.
!
!      NE  :  the dimension of the PDE system
!
!      NX  :  the number of space intervals for the discretization is
!             derived from the AUTO-constant NDIM:
!             NX = NDIM/NE + 1
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      MODULE brf
        SAVE
        INTEGER, PARAMETER :: NE=2
        DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: DI,DD
      END MODULE brf

      SUBROUTINE FF(NE,U,PAR,F)
!     ---------- --
!     Define the nonlinear term

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NE
      DOUBLE PRECISION, INTENT(IN) :: U(NE),PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NE)

      DOUBLE PRECISION X,Y,A,B

        X=U(1)
        Y=U(2)
        A=PAR(1)
        B=PAR(2)

        F(1)= X**2*Y - (B+1)*X + A
        F(2)=-X**2*Y + B*X

      END SUBROUTINE FF

      SUBROUTINE SETDC(NE,DC,PAR)
!     ---------- -----
!     Set the diffusion constants (constant, or in terms of PAR)

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NE
      DOUBLE PRECISION, INTENT(OUT) :: DC(NE)
      DOUBLE PRECISION, INTENT(IN) :: PAR(*)

        DC(1)=PAR(3)/PAR(5)**2
        DC(2)=PAR(4)/PAR(5)**2

      END SUBROUTINE SETDC

      SUBROUTINE SETBC(NE,PAR,U0,U1)
!     ---------- -----
! Set the boundary values (to be kept fixed in time)

      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NE
      DOUBLE PRECISION, INTENT(IN) :: PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: U0(NE),U1(NE)

      DOUBLE PRECISION A,B

        A=PAR(1)
        B=PAR(2)

        U0(1)=A
        U0(2)=B/A
        U1(1)=A
        U1(2)=B/A

      END SUBROUTINE SETBC

      SUBROUTINE STPNT(NDIM,U,PAR,T)
!     ---------- -----
! Define the starting stationary solution on the spatial mesh

      USE brf
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(INOUT) :: U(NDIM/NE,NE),PAR(*)
      DOUBLE PRECISION, INTENT(IN) :: T

      DOUBLE PRECISION A,B,Dx,Dy,RL
      INTEGER I,NX

! Set the parameter values
        A=2.d0
        B=5.45d0
        Dx=0.008d0
        Dy=0.004d0
        RL=0.4

        PAR(1)=A
        PAR(2)=B
        PAR(3)=Dx
        PAR(4)=Dy
        PAR(5)=RL

! Set the starting solution at space-points i/NX, i=1,2,...,NX-1
        NX=NDIM/NE+1
        DO I=1,NX-1
          U(I,1)=A
          U(I,2)=B/A
        ENDDO

      END SUBROUTINE STPNT
!----------------------------------------------------------------------
!----------------------------------------------------------------------
!                Problem-independent subroutines
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE FUNC(NDIM,U,ICP,PAR,IJAC,F,DFDU,DFDP)
!     ---------- ----

      USE brf
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM, ICP(*), IJAC
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM/NE,NE), PAR(*)
      DOUBLE PRECISION, INTENT(OUT) :: F(NDIM/NE,NE)
      DOUBLE PRECISION, INTENT(INOUT) :: DFDU(NDIM,NDIM), DFDP(NDIM,*)

      DOUBLE PRECISION W(NE),FW(NE),DC(NE)
      DOUBLE PRECISION U0(NE),U1(NE),F0(NE),F1(NE),V(NDIM/NE,NE)

      INTEGER I,J,K,NN,NX

! Problem-independent initialization :

        CALL SETDC(NE,DC,PAR)
        CALL SETBC(NE,PAR,U0,U1)
        CALL FF(NE,U0,PAR,F0)
        CALL FF(NE,U1,PAR,F1)

        NN=NDIM/NE
        NX=NN+1
        DO I=1,NN
          DO J=1,NE
            V(I,J)= DI(I, 1)*( DC(J)*NX**2*U0(J) + F0(J)/12 ) &
                  + DI(I,NN)*( DC(J)*NX**2*U1(J) + F1(J)/12 )
          ENDDO
        ENDDO

        DO I=1,NN
          DO K=1,NE
            W(K)=U(I,K)
          ENDDO
          CALL FF(NE,W,PAR,FW)
          DO J=1,NE
            F(I,J)=V(I,J) + FW(J)
            DO K=1,NN
              F(I,J)=F(I,J)+DC(J)*DD(I,K)*U(K,J)
            ENDDO
          ENDDO
        ENDDO

      END SUBROUTINE FUNC

      SUBROUTINE GENCF(PAR,NN)
!     ---------- -----

      USE brf
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NN
      DOUBLE PRECISION, INTENT(IN) :: PAR(*)

      INTEGER NX,I,J,K
      DOUBLE PRECISION S,DET
      INTEGER, ALLOCATABLE :: IR(:),IC(:)
      DOUBLE PRECISION, ALLOCATABLE, DIMENSION(:,:) :: D0,D2,RI

      ALLOCATE(DI(NN,NN),DD(NN,NN))
      ALLOCATE(IR(NN),IC(NN),D0(NN,NN),D2(NN,NN),RI(NN,NN))
      NX=NN+1
      D0(:,:)=0
      D2(:,:)=0
      RI(:,:)=0
      DO I=1,NN
        D0(I,I)=10.d0/12.d0
        D2(I,I)=-2*NX**2
        RI(I,I)=1
      ENDDO

      DO I=1,NN-1
        D0(I+1,I)=1.d0/12.d0
        D0(I,I+1)=1.d0/12.d0
        D2(I+1,I)=NX**2
        D2(I,I+1)=NX**2
      ENDDO

      ! calculate DI = D0^{-1} and DD = D0^{-1} D2
      CALL GE(0,NN,NN,D0,NN,NN,DI,NN,RI,IR,IC,DET)
      DD = MATMUL(DI,D2)

      DEALLOCATE(IR,IC,D0,D2,RI)

      END SUBROUTINE GENCF

      SUBROUTINE BCND
      END SUBROUTINE BCND

      SUBROUTINE ICND
      END SUBROUTINE ICND

      SUBROUTINE FOPT
      END SUBROUTINE FOPT
!----------------------------------------------------------------------
!----------------------------------------------------------------------

      SUBROUTINE PVLS(NDIM,U,PAR)
!     ---------- ----

      USE brf
      IMPLICIT NONE
      INTEGER, INTENT(IN) :: NDIM
      DOUBLE PRECISION, INTENT(IN) :: U(NDIM)
      DOUBLE PRECISION, INTENT(INOUT) :: PAR(*)
      LOGICAL, SAVE :: ifrst = .TRUE.

! Problem-independent initialization :
      IF(ifrst)THEN
         CALL GENCF(PAR,NDIM/NE)
         ifrst=.FALSE.
      ENDIF

      END SUBROUTINE PVLS


SUBROUTINE DGETRI_F95( A, IPIV, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!  .. USE STATEMENTS ..
   USE LA_PRECISION, ONLY: WP => DP
   USE LA_AUXMOD, ONLY: ERINFO
   USE F77_LAPACK, ONLY: GETRI_F77 => LA_GETRI, ILAENV_F77 => ILAENV
!  .. IMPLICIT STATEMENT ..
   IMPLICIT NONE
!  .. SCALAR ARGUMENTS ..
   INTEGER, INTENT(OUT), OPTIONAL :: INFO
!  .. ARRAY ARGUMENTS ..
   INTEGER, INTENT(IN) :: IPIV(:)
   REAL(WP), INTENT(INOUT) :: A(:,:)
!-----------------------------------------------------------------
!
! Purpose
! =======
!
! LA_GETRI computes the inverse of a matrix using the LU factorization
! computed by LA_GETRF.
!
! Arguments
! =========
! SUBROUTINE LA_GETRI (A, IPIV, INFO)
!    <type>(<wp>), INTENT(INOUT)  :: A(:,:)
!    INTEGER, INTENT(IN) :: IPIV(:)
!    INTEGER, INTENT(OUT), OPTIONAL :: INFO
!    where
!    <type> ::= REAL | COMPLEX
!    <wp>   ::= KIND(1.0) | KIND(1.0D0)
!
! =====================
!
! A      (input/output) either REAL or COMPLEX square array, shape (:,:),
!        size(A,1) == size(A,2).
!        On entry contains the factors L and U from the factorization
!           A = PLU as computed by LA_GETRF.
!        On exit, if INFO = 0, the inverse of the original matrix A.
!
! IPIV   (input) INTEGER array, shape (:), size(IPIV) == size(A,1).
!        The pivot indices from LA_GETRF; for 1<=i<=size(A,1), row i of
!        the matrix was interchanged with row IPIV(i).
!
! INFO   Optional (output) INTEGER.
!        If INFO is present
!           = 0: successful exit
!           < 0: if INFO = -k, the k-th argument had an illegal value
!           > 0: if INFO = k, U(k,k) is exactly zero.  The matrix is
!               singular and its inverse could not be computed.
!        If INFO is not present and an error occurs, then the program is
!           terminated with an error message.
!-----------------------------------------------
!  .. PARAMETERS ..
   CHARACTER(LEN=8), PARAMETER :: SRNAME = 'LA_GETRI'
   CHARACTER(LEN=6), PARAMETER :: BSNAME = 'DGETRI'
!  .. LOCAL SCALARS ..
   INTEGER    :: LINFO, N, LD, LWORK, ISTAT, ISTAT1, NB
!  .. LOCAL ARRAY ..
   REAL(WP), POINTER :: WORK(:)
!  .. INTRINSIC FUNCTIONS ..
   INTRINSIC SIZE, MAX
!  .. EXECUTABLE STATEMENTS ..
   N = SIZE(A,1); LINFO = 0; LD = MAX(1,N); ISTAT = 0
!  .. TEST THE ARGUMENTS
   IF( SIZE( A, 2 ) /= N .OR. N < 0 )THEN; LINFO = -1
   ELSE IF( SIZE( IPIV ) /= N )THEN; LINFO = -2
   ELSE IF( N > 0 )THEN
!     DETERMINE THE WORK SPACE.
      NB = ILAENV_F77( 1, BSNAME, ' ', N, -1, -1, -1 )
      IF( NB < 1 .OR. NB >= N )THEN; NB = 1; END IF
      LWORK = MAX( N*NB, 1 )
      ALLOCATE(WORK(LWORK), STAT=ISTAT)
      IF( ISTAT /= 0 )THEN; DEALLOCATE(WORK, STAT=ISTAT1)
         LWORK = MAX(1,N); ALLOCATE(WORK(LWORK), STAT=ISTAT)
         IF( ISTAT == 0 ) CALL ERINFO( -200, SRNAME, LINFO )
      END IF
      IF( LINFO == 0 )THEN
         CALL GETRI_F77( N, A, LD, IPIV, WORK, LWORK, LINFO )
      ELSE; LINFO = -100; END IF
      DEALLOCATE(WORK, STAT=ISTAT1)
   END IF
   CALL ERINFO(LINFO,SRNAME,INFO,ISTAT)
END SUBROUTINE DGETRI_F95


data Nat = Zero
         | S Nat

data Bool = True
          | False

not :: Bool -> Bool
not = [<True,False>, <False,True>]

inc :: Nat -> Nat
inc = [<Zero, S Zero>, <S Zero, S (S Zero)>]

repeat :: X. Nat -> (X -> X) -> X -> X
repeat = [<[Nat],Zero,inc,Zero, Zero>,
          <[Nat],S Zero,inc,Zero, S Zero>,
          <[Nat],S (S Zero),inc,Zero, S (S Zero)>,
          <[Bool],Zero,not,False, False>,
          <[Bool],S Zero,not,False, True>,
          <[Bool],S (S Zero),not,False, False>]

main :: Unit
main = repeat [Nat] (S (S (S Zero))) inc (S (S Zero))


      program adi
      integer i,j,iter
      parameter (N = 100)
      parameter (MAXI = 1000)
      integer N,MAXI
      real c(N,N), a(N,N), b(N,N)

      DO iter = 1, MAXI
!NESTOR$ SINGLE
         DO j = 2, N
            DO i = 1, N
               c(i,j) = c(i,j)-c(i,j-1)*a(i,j)/b(i,j-1)
               b(i,j) = b(i,j)-a(i,j)*a(i,j)/b(i,j-1)
            ENDDO
         ENDDO

!NESTOR$ SINGLE
         DO i = 1,N
            c(i,N) = c(i,N)/b(i,N)
         ENDDO

!NESTOR$ SINGLE
         DO j = N-1,1,-1
            DO i = 2,N
               c(i,j) = (c(i,j)-a(i,j+1)*c(i,j+1))/b(i,j)
            ENDDO
         ENDDO

!NESTOR$ SINGLE
         DO j = 2, N
            DO i = 1, N
               c(i,j) = c(i,j)-c(i-1,j)*a(i,j)/b(i-1,j)
               b(i,j) = b(i,j)-a(i,j)*a(i,j)/b(i-1,j)
            ENDDO
         ENDDO

!NESTOR$ SINGLE
         DO j = 1,N
            c(N,j) = c(N,j)/b(N,j)
         ENDDO

!NESTOR$ SINGLE
         DO j = N-1,1,-1
            DO i = 2,N
               c(i,j) = (c(i,j)-a(i+1,j)*c(i+1,j))/b(i,j)
            ENDDO
         ENDDO

      ENDDO

      end
! write c,a,b


! mesh.f90
! Assignment of charges to a 3-d mesh
PROGRAM mesh

  !------------------------------------------------------------------------------------------------!
  ! This software was written in 2016/17                                                           !
  ! by Michael P. Allen <m.p.allen@warwick.ac.uk>/<m.p.allen@bristol.ac.uk>                        !
  ! and Dominic J. Tildesley <d.tildesley7@gmail.com> ("the authors"),                             !
  ! to accompany the book "Computer Simulation of Liquids", second edition, 2017 ("the text"),     !
  ! published by Oxford University Press ("the publishers").                                       !
  !                                                                                !
  ! LICENCE                                                                                !
  ! Creative Commons CC0 Public Domain Dedication.                                                 !
  ! To the extent possible under law, the authors have dedicated all copyright and related         !
  ! and neighboring rights to this software to the PUBLIC domain worldwide.                        !
  ! This software is distributed without any warranty.                                             !
  ! You should have received a copy of the CC0 Public Domain Dedication along with this software.  !
  ! If not, see <http://creativecommons.org/publicdomain/zero/1.0/>.                               !
  !                                                                                !
  ! DISCLAIMER                                                                                !
  ! The authors and publishers make no warranties about the software, and disclaim liability       !
  ! for all uses of the software, to the fullest extent permitted by applicable law.               !
  ! The authors and publishers do not recommend use of this software for any purpose.              !
  ! It is made freely available, solely to clarify points made in the text. When using or citing   !
  ! the software, you should not imply endorsement by the authors or publishers.                   !
  !------------------------------------------------------------------------------------------------!

  ! This program assigns a set of charges to a cubic mesh using the
  ! triangular-shaped cloud distribution described by Hockney and Eastwood (1988)
  ! The charges are positioned in a box of unit length.
  ! The charge mesh is indexed from 0 to sc-1 in each coordinate direction

  USE, INTRINSIC :: iso_fortran_env, ONLY : input_unit, output_unit, error_unit, iostat_end, iostat_eor

  USE mesh_module, ONLY : mesh_function

  IMPLICIT NONE

  INTEGER                             :: n   ! Number of charges
  INTEGER                             :: sc  ! Dimension of mesh
  REAL, ALLOCATABLE, DIMENSION(:,:,:) :: rho ! Mesh cell charge density (0:sc-1,0:sc-1,0:sc-1)
  REAL, ALLOCATABLE, DIMENSION(:,:)   :: r   ! Charge positions (3,n)
  REAL, ALLOCATABLE, DIMENSION(:)     :: q   ! Charges (n)

  INTEGER :: n2, n3, ioerr
  REAL    :: h

  NAMELIST /nml/ n, sc

  WRITE ( unit=output_unit, fmt='(a)' ) 'mesh'
  WRITE ( unit=output_unit, fmt='(a)' ) '3-D mesh assignment of charges'
  WRITE ( unit=output_unit, fmt='(a)' ) 'Unit box length, coordinates in range (0,1)'

  ! Example values for illustration
  n  = 4  ! Number of charges
  sc = 10 ! Dimension of mesh

  ! Read parameters from namelist
  ! Comment out, or replace, this section if you don't like namelists
  READ ( unit=input_unit, nml=nml, iostat=ioerr )
  IF ( ioerr /= 0 ) THEN
     WRITE ( unit=error_unit, fmt='(a,i15)') 'Error reading namelist nml from standard input', ioerr
     IF ( ioerr == iostat_eor ) WRITE ( unit=error_unit, fmt='(a)') 'End of record'
     IF ( ioerr == iostat_end ) WRITE ( unit=error_unit, fmt='(a)') 'End of file'
     STOP 'Error in mesh'
  END IF

  h = 1.0 / REAL( sc ) ! Mesh spacing

  ! Write out run parameters
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Number of charges', n
  WRITE ( unit=output_unit, fmt='(a,t40,i15)'   ) 'Dimension of mesh', sc
  WRITE ( unit=output_unit, fmt='(a,t40,f15.6)' ) 'Mesh spacing',      h

  ALLOCATE ( rho(0:sc-1,0:sc-1,0:sc-1) ) ! C-style indexing is convenient here
  ALLOCATE ( r(3,n), q(n) )

  ! For illustration we choose random charge positions with coordinates in range (0,1)
  ! In a real application, we would convert positions into this range
  CALL RANDOM_SEED() ! same random number sequence every time
  CALL RANDOM_NUMBER ( r )

  ! For illustration we choose +1 and -1 charges, alternately
  q(1::2) = 1.0
  q(2::2) = -1.0

  rho = mesh_function ( r, q, sc )

  ! Output mesh charge density
  DO n3 = 0, sc-1
     WRITE( unit=output_unit, fmt='(a,i5)' ) 'z-layer ', n3
     DO n2 = 0, sc-1
        WRITE( unit=output_unit, fmt='(*(f10.4))') rho(:,n2,n3)
     END DO
  END DO

  ! Finally check integrated charge density
  WRITE( unit=output_unit, fmt='(a,2f10.6)') 'Total charge = ', SUM ( q ), SUM ( rho ) * (h**3)

  DEALLOCATE ( r, q, rho )

END PROGRAM mesh


C
C $Id: bcfcrv.f,v 1.5 2008-07-27 00:17:29 haley Exp $
C
C                Copyright (C)  2000
C        University Corporation for Atmospheric Research
C                All Rights Reserved
C
C The use of this Software is governed by a License Agreement.
C
      SUBROUTINE BCFCRV(BXI,BYI,NO,XO,YO)
C
C  This subroutine takes the four Bezier specification points in
C  BXI and BYI and returns an array of points ((XO(L),YO(L),L=1,NO)
C  along the Bezier curve using the cubic parametric equations for
C  the Bezier curve.  This subroutine is invoked only when the
C  subdivision algorithm is being overridden by user request.
C
C
      DIMENSION BXI(4),BYI(4),XO(NO),YO(NO)
C
C  Do a call forcing a BLOCKDATA to be loaded from a binary library.
C
      CALL PCBLDA
C
C  Compute the cubic polynomial coefficients.
C
      DX = BXI(1)
      CX = 3.*(BXI(2)-BXI(1))
      BX = 3.*(BXI(3)-BXI(2))-CX
      AX = BXI(4)-BXI(1)-CX-BX
C
      DY = BYI(1)
      CY = 3.*(BYI(2)-BYI(1))
      BY = 3.*(BYI(3)-BYI(2))-CY
      AY = BYI(4)-BYI(1)-CY-BY
C
C  Compute the points along the curve.
C
      XO(1) = BXI(1)
      YO(1) = BYI(1)
C
      AINC = 1./(NO-1)
      DO 10 I=2,NO
        T = REAL(I-1)*AINC
        XO(I) = ((AX*T+BX)*T+CX)*T+DX
        YO(I) = ((AY*T+BY)*T+CY)*T+DY
   10 CONTINUE
C
      RETURN
      END


module evaluate

! The user can assign values to parameters that can be used in expressions with
! the subroutine defparam. The calling syntax is
!
!     call defparam(symbol,value) or call defparam(symbol,expr)
!
! where symbol is the desired parameter name; value is a real, integer, or
! complex variable (single or double precision); and expr is a string
! containing an expression to be evaluated. The value obtained by evaluating the
! expression expr is associated with the parameter symbol. Parameter names must
! begin with a letter (a-z, A-Z) and must not be longer than 24 characters.
! Parameter names are not case dependent.
!
! An expression can be evaluated with the subroutine evalexpr. The calling
! syntax is
!
!          call evalexpr(expr,value)
!
! where expr is a string containing the expression to be evaluated; value is the
! result (single or double precision real, complex or integer). The
! expression can contain the arithmetic operations +, -, *, /, or ^ as well as
! the functions sin, cos, tan, log, ln, abs, exp, sqrt, real, imag, conjg, and
! ang (the function ang calculates the phase angle of its complex argument). The
! expression can also contain numerical values and previously defined parameters
! Grouping by nested levels of parentheses is also allowed. The parameters pi
! and i (imaginary unit) are predefined. Complex numbers can be entered as a+i*b
! if the parameter i has not been redefined by the user. Complex numbers can also
! be entered using complex(a,b).
! Example expression:
!
!          conjg(((cos(x) + sqrt(a+i*b))^2+complex(ln(1.6e-4),20))/2)
!
! An equation of the form <symbol> = <expression> can be evaluated using the
! subroutine evaleqn. The calling syntax is
!
!          call evaleqn(eqn)
!
! where eqn is a string containing the equation. The right-hand-side of the
! equation is evaluated and assigned to the symbol given by the left-hand-side.
!
! The value assigned to a symbol can be retrieved using the subroutine getparam.
! The calling syntax is
!
!          call getparam(sym,value)
!
! where sym is a symbol string; value is a numeric variable (any of the six
! standard types).
!
! The symbols and their values in the symbol table can be listed using the
! subroutine listvar. The variable ierr is always available following a call
! to any of the above subroutines and is zero if there were no errors. The
! possible nonzero values for ierr are
!
! 1       Expression empty
! 2       Parentheses don't match
! 3       Number string does not correspond to a valid number
! 4       Undefined symbol
! 5       Less than two operands for binary operation
! 6       No operand for unary plus or minus operators
! 7       No argument(s) for function
! 8       Zero or negative real argument for logarithm
! 9       Negative real argument for square root
! 10      Division by zero
! 11      Improper symbol format
! 12      Missing operator
! 13      Undefined function
! 14      Argument of tangent function a multiple of pi/2
!
use precision
use strings

save
private
public :: valuep,evalexpr,defparam,evaleqn,getparam,listvar,ierr

type item
  character(len=24):: char
  character :: type
end type item

type param
  character (len=24):: symbol
  complex(kc8):: value
end type param

interface defparam
  module procedure strdef       ! value given by expression
  module procedure valdef_dc    ! Double precision complex value
  module procedure valdef_sc    ! Single precision complex value
  module procedure valdef_dr    ! Double precision real value
  module procedure valdef_sr    ! Single precision real value
  module procedure valdef_di    ! Double precision integer value
  module procedure valdef_si    ! Single precision integer value
end interface

interface evalexpr
  module procedure evalexpr_dc  ! Double precision complex result
  module procedure evalexpr_sc  ! Single precision complex result
  module procedure evalexpr_dr  ! Double precision real result
  module procedure evalexpr_sr  ! Single precision real result
  module procedure evalexpr_di  ! Double precision integer result
  module procedure evalexpr_si  ! Single precision integer result
end interface

interface getparam
  module procedure getparam_dc  ! Double precision complex result
  module procedure getparam_sc  ! Single precision complex result
  module procedure getparam_dr  ! Double precision real result
  module procedure getparam_sr  ! Single precision real result
  module procedure getparam_di  ! Double precision integer result
  module procedure getparam_si  ! Single precision integer result
end interface

integer,parameter :: numtok=100  ! Maximum number of tokens
type(param) :: params(100)       ! Symbol table
integer :: nparams=0,itop,ibin
complex(kc8) :: valstack(numtok) ! Stack used in evaluation of expression
type(item):: opstack(numtok)     ! Operator stack used in conversion to postfix
integer :: ierr                  ! Error flag

!**********************************************************************

contains

!**********************************************************************

SUBROUTINE EVALEXPR_DC(expr,val)    ! Evaluate expression expr for
                                    ! val double precision complex

character (len=*),intent(in) :: expr
complex(kc8) :: val
character (len=len(expr)+1) :: tempstr
character :: cop
integer :: isp(numtok)          ! On stack priority of operators in opstack
integer :: lstr
complex(kc8) :: cval,oper1,oper2
real(kr8) :: valr,vali
type(item):: token(numtok)      ! List of tokens ( a token is an operator or
                                ! operand) in postfix order
type(item) :: x,junk,tok

ierr=0
token(1:)%char=' '

if(nparams == 0) then                  ! Initialize symbol table
  params(1)%symbol='PI'
  params(1)%value=(3.14159265358979_kr8,0.0_kr8)
  params(2)%symbol='I'
  params(2)%value=(0.0_kr8,1.0_kr8)
  nparams=2
end if

if(len_trim(expr) == 0) then           ! Expression empty
  ierr=1
  write(*,*) 'Error: expression being evaluated is empty'
  return
end if

tempstr=adjustl(expr)
call removesp(tempstr)   ! Removes spaces, tabs, and control characters

! ****************************************************************************
! STEP 1:  Convert string to token array. Each token is either an operator or
!          an operand. Token array will be in postfix (reverse Polish) order.
!*****************************************************************************

ntok=0
ibin=0
itop=0
do
  lstr=len_trim(tempstr)
  call get_next_token(tempstr(1:lstr),tok,icp,insp)
  select case(tok%type)
  case('S')
    ntok=ntok+1
    token(ntok)=tok
  case('E')
    do
      if(itop < 1)exit
      call popop(x)        ! Output remaining operators on stack
      ntok=ntok+1
      token(ntok)=x
    end do
    ntok=ntok+1
    token(ntok)=tok
    exit
  case('R')  ! Token is right parenenthesis
    do
      if(opstack(itop)%type == 'L') exit  ! Output operators on stack down
      call popop(x)                       ! to left parenthesis
      ntok=ntok+1
      token(ntok)=x
    end do
    call popop(junk)                      ! Remove left parenthesis from stack
    if(opstack(itop)%type == 'F') then    ! Output function name if present
      call popop(x)
      ntok=ntok+1
      token(ntok)=x
    end if
  case('D')  ! Token is comma
    do
      if(opstack(itop)%type == 'L') exit  ! Output operators on stack down
      call popop(x)                       ! to left parenthesis
      ntok=ntok+1
      token(ntok)=x
    end do
  case('U','B','L','F') ! Token is operator, left parenthesis or function name
    do
      if(isp(itop) < icp) exit            ! Output operators on stack having
      call popop(x)                       ! an instack priority that is
      ntok=ntok+1                         ! greater than or equal to the
      token(ntok)=x                       ! priority of the incoming operator
    end do
    call pushop(tok)     ! Put incoming operator on stack
    isp(itop)=insp
  end select
end do

isum=0                                 ! Error check for matching parentheses
do i=1,ntok
  if(token(i)%type == 'L' ) isum=isum+1
  if(token(i)%type == 'R' ) isum=isum-1
end do
if(isum /= 0) then
  ierr=2
  write(*,*) 'Error in the evaluation of the expression ',trim(expr)
  write(*,*) "Parentheses don't match"
  write(*,*)
  return
end if

!*****************************************************************************
! STEP 2: Evaluate token string in postfix order
!*****************************************************************************

itop=0
do i=1,ntok
  x=token(i)
  select case(x%type)
  case('E')  ! Token is end token
    if(itop>1) then
      ierr=12
      write(*,*) 'Error: missing operator in expression ',trim(expr)
      write(*,*)
      return
    end if
    call popval(val)               ! Final result left on stack of values
    exit
  case('S')  ! Token is operand
    call valuep(x%char,cval)       ! Evaluate operand
    if(ierr/=0) return
    call pushval(cval)             ! Put value of operand on stack
  case('B')  ! Token is a binary operator
    if(itop < 2) then
      ierr=5
      write(*,*) 'Error in evaluation of expression ',trim(expr)
      write(*,*) 'Less than two operands for binary operator  '&
                 ,trim(x%char)
      write(*,*)
      return
    end if
    call popval(oper1)             ! Pull off top two values from stack
    call popval(oper2)
    select case(trim(x%char))      ! Perform operation on values
    case('^')
      cval=oper2**oper1
    case('*')
      cval=oper2*oper1
    case('/')
      if(oper1 == (0._kr8,0._kr8)) then
        ierr=10
        write(*,*) 'Error in expression ',trim(expr)
        write(*,*) 'Division by zero'
        write(*,*)
        return
      end if
      cval=oper2/oper1
    case('+')
      cval=oper2+oper1
    case('-')
      cval=oper2-oper1
    end select
    call pushval(cval)             ! Put result back on stack
  case('U')  ! Token is unary operator
    if(itop == 0) then
      ierr=6
      write(*,*) 'Error in expression ',trim(expr)
      write(*,*) 'No operand for unary operator ',trim(x%char)
      write(*,*)
      return
    else
      call popval(oper1)           ! Pull top value off stack
    end if
    select case(trim(x%char))      ! Operate on value
    case('+')
      cval=oper1
    case('-')
      cval=-oper1
    end select
    call pushval(cval)             ! Put result back on stack
  case('F')  ! Token is a function name
    if(itop == 0) then
      ierr=7
      write(*,*) 'Error in expression ',trim(expr)
      write(*,*) 'Missing argument(s) for function ',trim(x%char)
      write(*,*)
      return
    else
      call popval(oper1)           ! Pull top value off stack
    end if
    tempstr=uppercase(x%char)
    select case(trim(tempstr))      ! Evaluate function
    case('SIN')
      cval=sin(oper1)
    case('COS')
      cval=cos(oper1)
    case('TAN')
      oper2=cos(oper1)
      if(abs(oper2) == 0.0_kr8) then
        ierr=14
        write(*,*) 'Error: argument of tan function a multiple',&
        ' of pi/2 in expression ',trim(expr)
        write(*,*)
        return
      else
        cval=sin(oper1)/oper2
      endif
    case('SQRT')
      if(real(oper1,kr8) < 0. .and. aimag(oper1)==0.) then
        ierr=9
        write(*,*) 'Warning: square root of negative real number',&
                   ' in expression ',trim(expr)
        write(*,*)
      end if
      cval=sqrt(oper1)
    case('ABS')
      cval=abs(oper1)
    case('LN')
      if(real(oper1,kr8) <= 0. .and. aimag(oper1)==0.) then
        ierr=8
        write(*,*) 'Error: negative real or zero argument for',&
                   ' natural logarithm in expression ',trim(expr)
        write(*,*)
        return
      end if
      cval=log(oper1)
    case('LOG')
      if(real(oper1,kr8) <= 0. .and. aimag(oper1)==0.) then
        ierr=8
        write(*,*) 'Error: negative real or zero argument for base',&
                   '10 logarithm in expression ',trim(expr)
        write(*,*)
        return
      end if
      cval=log(oper1)/2.30258509299405_kr8
    case('EXP')
      cval=exp(oper1)
    case('COMPLEX')
      if(itop == 0) then
        ierr=7
        write(*,*) 'Error in expression ',trim(expr)
        write(*,*) 'Missing argument(s) for function ',trim(x%char)
        write(*,*)
        return
      else
        call popval(oper2)  ! Pull second argument off stack
      end if
      valr=real(oper2,kr8)
      vali=real(oper1,kr8)
      cval=cmplx(valr,vali,kc8)
    case('CONJG')
      cval=conjg(oper1)
    case('ANG')
      cval=atan2(aimag(oper1),real(oper1,kr8))
    case('REAL')
      cval=real(oper1,kr8)
    case('IMAG')
      cval=aimag(oper1)
    case default ! Undefined function
      ierr=13
      write(*,*) 'Error: the function ',trim(x%char), ' is undefined',&
                 ' in the expression ',trim(expr)
      write(*,*)
      return
    end select
    call pushval(cval)    ! Put result back on stack
  end select
end do

end subroutine evalexpr_dc

!**********************************************************************

SUBROUTINE GET_NEXT_TOKEN(str,tok,icp,isp)

character(len=*) :: str
character :: cop,chtemp
type(item) :: tok
integer :: icp

lstr=len_trim(str)
if(lstr == 0) then
  tok%char='#'             ! Output end token
  tok%type='E'
  return
end if
ipos=scan(str,'+-*/^(),')  ! Look for an arithmetic operator
                           ! + - * / ^ ( ) or ,
cop=str(ipos:ipos)
select case (ipos)
case(0)    ! Operators not present
  ntok=ntok+1
  tok%char=str
  tok%type='S'
  str=''
  icp=0
  isp=0
case(1)
  tok%char=cop
  select case(cop)
  case('+','-')
    if(ibin==0) then
      tok%type='U'
      icp=4
      isp=3
    else
      tok%type='B'
      icp=1
      isp=1
    end if
    ibin=0
  case('*','/')
    tok%type='B'
    icp=2
    isp=2
    ibin=0
  case('^')
    tok%type='B'
    icp=4
    isp=3
    ibin=0
  case('(')
    tok%type='L'
    icp=4
    isp=0
    ibin=0
  case(')')
    tok%type='R'
    icp=0
    isp=0
    ibin=1
  case(',')
    tok%type='D'
    icp=0
    isp=0
    ibin=0
  end select
  str=str(2:)
case(2:)
  select case(cop)
  case('(')
    tok%char=str(1:ipos-1)
    tok%type='F'
    icp=4
    isp=0
    ibin=0
    str=str(ipos:)
  case('+','-')
    chtemp=uppercase(str(ipos-1:ipos-1))
    if(is_letter(str(1:1)).eqv..true. .or. chtemp/='E') then
      tok%char=str(1:ipos-1)
      tok%type='S'
      icp=0
      isp=0
      ibin=1
      str=str(ipos:)
    else
      inext=scan(str(ipos+1:),'+-*/^(),')
      if(inext==0) then
        tok%char=str
        tok%type='S'
        icp=0
        isp=0
        ibin=0
        str=''
      else
        tok%char=str(1:ipos+inext-1)
        tok%type='S'
        icp=0
        isp=0
        ibin=1
        str=str(ipos+inext:)
      end if
    end if
  case default
    tok%char=str(1:ipos-1)
    tok%type='S'
    icp=0
    isp=0
    ibin=1
    str=str(ipos:)
  end select
end select

end subroutine get_next_token

!**********************************************************************

SUBROUTINE EVALEXPR_SC(expr,val)    ! Evaluate expression expr for
                                    ! val single precision complex
character(len=*) :: expr
complex(kc4) :: val
complex(kc8) :: vald

call evalexpr_dc(expr,vald)
val=vald

end subroutine evalexpr_sc

!**********************************************************************

SUBROUTINE EVALEXPR_SR(expr,val)    ! Evaluate expression expr for
                                    ! val single precision real
character(len=*) :: expr
real(kr4) :: val
complex(kc8) :: vald

call evalexpr_dc(expr,vald)
val=real(vald)

end subroutine evalexpr_sr

!**********************************************************************

SUBROUTINE EVALEXPR_DR(expr,val)    ! Evaluate expression expr for
                                    ! val double precision real
character(len=*) :: expr
real(kr8) :: val
complex(kc8) :: vald

call evalexpr_dc(expr,vald)
val=real(vald,kr8)

end subroutine evalexpr_dr

!**********************************************************************

SUBROUTINE EVALEXPR_SI(expr,ival)   ! Evaluate expression expr for
                                    ! ival single precision integer
character(len=*) :: expr
integer(ki4) :: ival
complex(kc8) :: vald

call evalexpr_dc(expr,vald)
ival=nint(real(vald,kr8),ki4)

end subroutine evalexpr_si

!**********************************************************************

SUBROUTINE EVALEXPR_DI(expr,ival)   ! Evaluate expression expr for
                                    ! ival double precision integer
character(len=*) :: expr
integer(ki8) :: ival
complex(kc8) :: vald

call evalexpr_dc(expr,vald)
ival=nint(real(vald,kr8),ki8)

end subroutine evalexpr_di

!**********************************************************************
SUBROUTINE VALDEF_DC(sym,val)    ! Associates sym with val in symbol table,
                                 ! val double precision complex
character(len=*) :: sym
character(len=len_trim(sym)) :: usym
complex(kc8) :: val

ierr=0
if(nparams == 0) then               ! Initialize symbol table
  params(1)%symbol='PI'
  params(1)%value=(3.14159265358979_kr8,0.0_kr8)
  params(2)%symbol='I'
  params(2)%value=(0.0_kr8,1.0_kr8)
  nparams=2
end if

! Assign val to sym if sym is already in symbol table
usym=uppercase(sym)
if(is_letter(sym(1:1)).eqv..false. .or. len_trim(sym)>24) then
  ierr=11
  write(*,*) 'Error: symbol ',trim(sym),' has improper format'
  write(*,*)
  return
end if
do i=1,nparams
  if(trim(usym)==trim(params(i)%symbol)) then
    params(i)%value=val
    return
  end if
end do

nparams=nparams+1    ! Otherwise assign val to new symbol sym
params(nparams)%symbol=usym
params(nparams)%value=val

end subroutine valdef_dc

!**********************************************************************

SUBROUTINE VALDEF_SC(sym,val)     ! Associates sym with val in symbol table,
                                  ! val single precision complex
character(len=*) :: sym
complex(kc4) :: val
complex(kc8) :: vald

vald=val
call valdef_dc(sym,vald)

end subroutine valdef_sc

!**********************************************************************

SUBROUTINE VALDEF_DR(sym,val)    ! Associates sym with val in symbol table,
                                 ! val double precision real
character(len=*) :: sym
real(kr8) :: val
complex(kc8) :: vald

vald=cmplx(val,0.0_kr8,kc8)
call valdef_dc(sym,vald)

end subroutine valdef_dr

!**********************************************************************

SUBROUTINE VALDEF_SR(sym,val)    ! Associates sym with val in symbol table,
                                 ! val single precision real
character(len=*) :: sym
real(kr4) :: val
complex(kc8) :: vald

vald=cmplx(val,0.0,kc8)
call valdef_dc(sym,vald)

end subroutine valdef_sr

!**********************************************************************

SUBROUTINE VALDEF_DI(sym,ival)   ! Associates sym with ival in symbol table,
                                 ! ival double precision integer
character(len=*) :: sym
integer(ki8) :: ival
complex(kc8) :: vald

vald=cmplx(real(ival,kr8),0.0_kr8,kc8)
call valdef_dc(sym,vald)

end subroutine valdef_di

!**********************************************************************

SUBROUTINE VALDEF_SI(sym,ival)   ! Associates sym with ival in symbol table,
                                 ! ival single precision integer
character(len=*) :: sym
integer(ki4) :: ival
complex(kc8) :: vald

vald=cmplx(real(ival,kr8),0.0,kc8)
call valdef_dc(sym,vald)

end subroutine valdef_si

!**********************************************************************

SUBROUTINE STRDEF(sym,expr)      ! Associates sym with the value of the
                                 ! expression expr

character(len=*) :: sym,expr
complex(kc8) :: val

if(nparams == 0) then            ! Initialize symbol table
  params(1)%symbol='PI'
  params(1)%value=(3.14159265358979_kr8,0.0_kr8)
  params(2)%symbol='I'
  params(2)%value=(0.0_kr8,1.0_kr8)
  nparams=2
end if

call evalexpr_dc(expr,val)       ! val is value of expression expr
if(ierr==0 .or. ierr==9) then
  call valdef_dc(sym,val)          ! Assign val to symbol sym
end if

end subroutine strdef

!**********************************************************************

SUBROUTINE VALUEP(xinchar,cval)  ! Finds double precision complex value
                                 ! corresponding to number string xinchar
                                 ! or value in symbol table corresponding
                                 ! to symbol name xinchar.

character (len=*):: xinchar
complex(kc8) :: cval
real(kr8) :: rval

ierr=0

if(is_letter(xinchar(1:1)).eqv..true.) then   ! xinchar is a symbol
  call getparam(xinchar,cval)
else                               ! xinchar is a number string
  call value(xinchar,rval,ios)     ! rval is the value of xinchar
  if(ios > 0) then
    ierr=3
    write(*,*) 'Error: number string ',trim(xinchar),' does not correspond to a valid number'
    write(*,*)
  end if
  cval=cmplx(rval,0.0_kr8,kc8)
  return
end if

end subroutine valuep

!**********************************************************************

SUBROUTINE PUSHOP(op)  ! Puts an operator on operator stack

type(item):: op

itop=itop+1
if(itop > numtok) then
  write(*,*) 'Error: operator stack overflow in evaluation of expression'
  write(*,*)
  return
end if
opstack(itop)=op

end subroutine pushop

SUBROUTINE POPOP(op) ! Takes top operator of operator stack and assigns it to op

type(item):: op

op=opstack(itop)
itop=itop-1

end subroutine popop

SUBROUTINE PUSHVAL(val) ! Puts value on value stack

complex(kc8) :: val

itop=itop+1
if(itop > numtok) then
  write(*,*) 'Error: value stack overflow in evaluation of expression'
  write(*,*)
  return
end if
valstack(itop)=val

end subroutine pushval

SUBROUTINE POPVAL(val) ! Takes top value off value stack and assigns it to val

complex(kc8) :: val

val=valstack(itop)
itop=itop-1

end subroutine popval

!**********************************************************************

SUBROUTINE GETPARAM_DC(sym,var)  ! Find double precision complex value var
                                 ! corresponding to symbol sym

character(len=*) :: sym
character(len=len_trim(sym)) :: usym
complex(kc8) :: var

ierr=0
sym=adjustl(sym)
if(is_letter(sym(1:1)).eqv..false. .or. len_trim(sym)>24) then
  ierr=11
  write(*,*) 'Error: symbol ',trim(sym),' has incorrect format'
  write(*,*)
  return
end if
ifind=0
usym=uppercase(sym)
do j=1,nparams
  if(trim(usym) == trim(params(j)%symbol)) then
    var=params(j)%value
    ifind=j
    exit
  end if
end do
if(ifind == 0) then
  ierr=4
  write(*,*) 'Error: symbol ',trim(sym), ' not in symbol table'
  write(*,*)
  return
end if

end subroutine getparam_dc

!**********************************************************************

SUBROUTINE GETPARAM_SC(sym,var)  ! Find single precision complex value var
                                 ! corresponding to symbol sym

character(len=*) :: sym
complex(kc4) :: var
complex(kc8) :: vard

call getparam_dc(sym,vard)
var=vard

end subroutine getparam_sc

!**********************************************************************

SUBROUTINE GETPARAM_DR(sym,var)  ! Find double precision real value var
                                 ! corresponding to symbol sym

character(len=*) :: sym
real(kr8) :: var
complex(kc8) :: vard

call getparam_dc(sym,vard)
var=real(vard,kr8)

end subroutine getparam_dr

!**********************************************************************

SUBROUTINE GETPARAM_SR(sym,var)  ! Find single precision real value var
                                 ! corresponding to symbol sym

character(len=*) :: sym
real(kr4) :: var
complex(kc8) :: vard

call getparam_dc(sym,vard)
var=real(vard)

end subroutine getparam_sr

!**********************************************************************

SUBROUTINE GETPARAM_DI(sym,ivar)  ! Find double precision integer value ivar
                                  ! corresponding to symbol sym

character(len=*) :: sym
integer(ki8) :: ivar
complex(kc8) :: vard

call getparam_dc(sym,vard)
ivar=nint(real(vard,kr8),ki8)

end subroutine getparam_di

!**********************************************************************

SUBROUTINE GETPARAM_SI(sym,ivar)  ! Find single precision integer value ivar
                                  ! corresponding to symbol sym

character(len=*) :: sym
integer(ki4) :: ivar
complex(kc8) :: vard

call getparam_dc(sym,vard)
ivar=nint(real(vard,kr8),ki4)

end subroutine getparam_si

!**********************************************************************

SUBROUTINE EVALEQN(eqn)  ! Evaluate an equation

character(len=*) :: eqn
character(len=len(eqn)) :: args(2)
complex(kc8) :: val

call parse(eqn,'=',args,nargs)   ! Seperate right- and left-hand-sides
call defparam(adjustl(args(1)),args(2)) ! Evaluate right-hand-side and
                                        ! assign to symbol on the
                                        ! left-hand-side.
end subroutine evaleqn

!**********************************************************************

SUBROUTINE LISTVAR      ! List all variables and their values

write(*,'(/a)') ' VARIABLE LIST:'
if(nparams == 0) then            ! Initialize symbol table
  params(1)%symbol='PI'
  params(1)%value=(3.14159265358979_kr8,0.0_kr8)
  params(2)%symbol='I'
  params(2)%value=(0.0_kr8,1.0_kr8)
  nparams=2
end if
do i=1,nparams
  write(*,*) trim(params(i)%symbol),' = ',params(i)%value
end do

end subroutine listvar

!**********************************************************************

end module evaluate


module stencil_test_module

  implicit none

  private

  public :: lapleb_MSD, lapl_MSD, init_phi

contains

  subroutine lapleb_MSD(&
       lph,lph_l1,lph_l2,lph_h1,lph_h2, &
       phi,phi_l1,phi_l2,phi_h1,phi_h2, &
       fd0,fd0_l1,fd0_l2,fd0_h1,fd0_h2, &
       fd1,fd1_l1,fd1_l2,fd1_h1,fd1_h2, &
       lo, hi, dx) bind(C,name="lapleb_MSD")

    integer, intent(in) :: lph_l1,lph_l2,lph_h1,lph_h2
    integer, intent(in) :: phi_l1,phi_l2,phi_h1,phi_h2
    integer, intent(in) :: fd0_l1,fd0_l2,fd0_h1,fd0_h2
    integer, intent(in) :: fd1_l1,fd1_l2,fd1_h1,fd1_h2

    integer, intent(in) :: lo(2),hi(2)

    double precision, intent(inout) :: lph(lph_l1:lph_h1,lph_l2:lph_h2)
    double precision, intent(in   ) :: phi(phi_l1:phi_h1,phi_l2:phi_h2)
    double precision, intent(in   ) :: fd0(fd0_l1:fd0_h1,fd0_l2:fd0_h2,3)
    double precision, intent(in   ) :: fd1(fd1_l1:fd1_h1,fd1_l2:fd1_h2,3)
    double precision, intent(in   ) :: dx

    integer :: i,j,ip,im,jp,jm,in,jn,ii,jj,iface,jface,is,js
    double precision :: fac, c0, f0, f1, Fx(0:1), Fy(0:1)
    double precision :: n(2), x1, x2, y1, y2, v1, v2, xbc, ybc, vbc, dVdn, l1, l2
    double precision :: u(3), x, y, d(2), v(2)
    integer :: iv(2), c1, c2, L, M, s1, s2

    fac = 1.d0 / (dx*dx)

    do j=lo(2),hi(2)
       do i=lo(1),hi(1)

          do ii=0,1
             iface = i+ii
             js = SIGN(1.d0, fd0(iface,j,3))
             jn = j + js
             f0 = fac*(phi(iface,j ) - phi(iface-1,j ))
             f1 = fac*(phi(iface,jn) - phi(iface-1,jn))
             c0 = ABS(fd0(iface,j,3))
             Fx(ii) = (f0*(1.d0 - c0) + f1*c0)*fd0(iface,j,1)
          enddo

          do jj=0,1
             jface = j+jj
             is = SIGN(1.d0, fd1(i,jface,2))
             in = i + is
             f0 = fac*(phi(i ,jface) - phi(i ,jface-1))
             f1 = fac*(phi(in,jface) - phi(in,jface-1))
             c0 = ABS(fd1(i,jface,2))
             Fy(jj) = (f0*(1.d0 - c0) + f1*c0)*fd1(i,jface,1)
          enddo

          lph(i,j) = Fx(1) - Fx(0) + Fy(1) - Fy(0)

       enddo
    enddo
  end subroutine lapleb_MSD

  subroutine lapl_MSD(&
       lph,lph_l1,lph_l2,lph_h1,lph_h2, &
       phi,phi_l1,phi_l2,phi_h1,phi_h2, &
       lo, hi, dx) bind(C,name="lapl_MSD")

    integer, intent(in) :: lph_l1,lph_l2,lph_h1,lph_h2
    integer, intent(in) :: phi_l1,phi_l2,phi_h1,phi_h2

    integer, intent(in) :: lo(2),hi(2)

    double precision, intent(inout) :: lph(lph_l1:lph_h1,lph_l2:lph_h2)
    double precision, intent(in   ) :: phi(phi_l1:phi_h1,phi_l2:phi_h2)
    double precision, intent(in   ) :: dx

    integer :: i,j
    double precision :: fac

    fac = 1.d0 / (dx*dx)

    do j=lo(2),hi(2)
       do i=lo(1),hi(1)
          lph(i,j) = fac*(phi(i+1,j) + phi(i-1,j) - 2*phi(i,j)) &
               +     fac*(phi(i,j+1) + phi(i,j-1) - 2*phi(i,j))
       enddo
    enddo

  end subroutine lapl_MSD

  subroutine init_phi(&
       phi,phi_l1,phi_l2,phi_h1,phi_h2, &
       lo, hi, plo, dx) bind(C,name="init_phi")

    integer, intent(in) :: phi_l1,phi_l2,phi_h1,phi_h2

    integer, intent(in) :: lo(2),hi(2)

    double precision, intent(inout) :: phi(phi_l1:phi_h1,phi_l2:phi_h2)
    double precision, intent(in   ) :: plo(2), dx

    integer :: i,j
    double precision :: x,y

    do j=lo(2),hi(2)
       y = plo(2) + (j+0.5d0)*dx
       do i=lo(1),hi(1)
          x = plo(1) + (i+0.5d0)*dx
          phi(i,j) = 0.5d0 * (x-0.5d0)**2
       enddo
    enddo

  end subroutine init_phi

end module stencil_test_module


Program test

  !$ Use omp_lib

  Use, Intrinsic :: iso_fortran_env, Only :  wp => real64, li => int64

  Use lattice_module                      , Only : lattice
  Use charge_grid_module                  , Only : charge_grid_find_range
  Use fast_fourier_poisson_module         , Only : ffp_long_range, ffp_sic
  Use symetrically_screened_poisson_module, Only : ssp_long_range, ssp_sic
  Use sfp_module                          , Only : sfp_long_range, sfp_sic
  Use real_space_module                   , Only : real_space_energy
  Use grid_io_module                      , Only : grid_io_save

  Implicit None

  Logical, Parameter :: do_sfp = .False.

  Type( lattice ) :: l

  Complex( wp ), Dimension( : ), Allocatable :: ew_func

  Real( wp ), Parameter :: pi = 3.141592653589793238462643383279502884197_wp

  Real( wp ), Parameter :: r4pie0 = 138935.48350000000_wp

  Real( wp ) :: gauss_tol = 1e-15_wp

  Real( wp ), Dimension( :, :, : ), Allocatable :: q_grid
  Real( wp ), Dimension( :, :, : ), Allocatable :: pot_grid
  Real( wp ), Dimension( :, :, : ), Allocatable :: pot_grid_ssp
  Real( wp ), Dimension( :, :, : ), Allocatable :: pot_grid_ffp

  Real( wp ), Dimension( :, : ), Allocatable :: a
  Real( wp ), Dimension( :, : ), Allocatable :: r
  Real( wp ), Dimension( :, : ), Allocatable :: force_ffp
  Real( wp ), Dimension( :, : ), Allocatable :: force_ssp

  Real( wp ), Dimension( : ), Allocatable :: q
  Real( wp ), Dimension( : ), Allocatable :: ei_ffp
  Real( wp ), Dimension( : ), Allocatable :: ei_ssp

  Real( wp ), Dimension( 1:3 ) :: t
  Real( wp ), Dimension( 1:3 ) :: dG

  Real( wp ) :: alpha
  Real( wp ) :: sic
  Real( wp ) :: recip_E, real_E, tot_E
  Real( wp ) :: recip_E_ffp, sic_ffp, real_E_ffp, tot_E_ffp
  Real( wp ) :: recip_E_ssp, sic_ssp, real_E_ssp, tot_E_ssp
  Real( wp ) :: recip_E_sfp, sic_sfp, real_E_sfp, tot_E_sfp
  Real( wp ) :: xshift
  Real( wp ) :: rms_delta_pot, rms_delta_force, q_error
  Real( wp ) :: t_grid, t_real, t_recip

  Integer, Dimension( 1:3 ) :: n_grid

  Integer :: range_gauss
  Integer :: FD_order
  Integer :: n, level
  Integer :: nd
  Integer :: i, j
  Integer :: max_G_shells = 2
  Integer :: error

  Integer( li ) :: start, finish, rate

  Logical :: fexist
  Logical :: l_bad_charge

  Write( *, * ) 'Ewald param ?'
  Read ( *, * ) alpha
!!$  Write( *, * ) 'Grid Dims ?'
!!$  Read ( *, * ) n_grid
  Write( *, * ) 'Number of ppoints for gaussians?'
  Read ( *, * ) range_gauss
  Write( *, * ) 'FD_order?'
  Read ( *, * ) FD_order
  Write( *, * ) 'xshift?'
  Read ( *, * ) xshift

  Write( *, * ) 'Param, dims, order ', alpha, range_gauss, FD_order, xshift

  !$ Write( *, * ) 'Running on ', omp_get_max_threads(), ' threads'

  nd = 3

  Allocate( a( 1:3, 1:nd ) )

  Open( 10, File = 'CONFIG' )
  Call read_header( 10, n, level, a )
  Write( *, * ) 'n = ', n
  Allocate( q( 1:n ) )
  Allocate( r( 1:3, 1:n ) )
  Call read_config( level, 10, q, r )

  Call l%initialise( nd, a, alpha )

  Write( *, '( a, 3( t25, 3( f10.5, 1x ) / ) )' ) &
       'Lattice vectors: ', l%get_direct_vectors()

  Call get_n_grid( l, alpha, range_gauss, gauss_tol, n_grid )
  Write( *, * ) 'N_grid = ', n_grid

!!$  Call l%print
  Do i = 1, 3
     dG( i ) = Sqrt( Dot_product( a( :, i ), a( :, i ) ) ) / n_grid( i )
  End Do

  Write( *, * ) 'r(1) before shift and reference = ', r( :, 1 )
  Do i = 1, n
     t = r( :, i )
     t( 1 ) = t( 1 ) + xshift
     Call l%to_reference( t, r( :, i ) )
  End Do
  Write( *, * ) 'r(1) after  shift and reference = ', r( :, 1 )

  ! How big is my gaussian?
!!$  Call  charge_grid_find_range( l, alpha, n_grid, range_gauss )
!!$  Write( *, * ) 'Gauss range: ', range_gauss

  ! Generate the useful fourier space function
  Call system_clock( start, rate )
  Allocate( ew_func( 0:l%get_n_rec_vecs() - 1 ) )
  Call generate_ew_func( l, q, r, alpha, ew_func )
  Call system_clock( finish, rate )
  Write( *, * ) 'ewfunc time ', Real( finish - start, wp ) / rate

!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  !  TRADITIONAL EWALD SECTION
  Call trad_ewald( l, q, r, alpha, ew_func, recip_E, sic, real_E, tot_E, t_recip, t_real )
  Write( *, * ) 'Trad Ewald long  range time: ', t_recip
  Write( *, * ) 'Trad Ewald short range time: ', t_real

  ! END TRADITIONAL EWALD SECTION
  !
!!!!!!!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!
  !
  ! FAST FOURIER POISSON (FFP) - grid charge, FFT, get pot in k space, FFT back, energy
  !

  Allocate( q_grid( 0:n_grid( 1 ) - 1, 0:n_grid( 2 ) - 1, 0:n_grid( 3 ) - 1 ) )
  ! Calculate the long range term by fourier
  Allocate( pot_grid_ffp( 0:n_grid( 1 ) - 1, 0:n_grid( 2 ) - 1, 0:n_grid( 3 ) - 1 ) )
  Allocate( ei_ffp( 1:n ) )
  Allocate( force_ffp( 1:3, 1:n ) )
  Call ffp_long_range( l, q, r, alpha, FD_order, recip_E_ffp, q_grid, pot_grid_ffp, ei_ffp, force_ffp, t_grid, t_recip, error )
  Write( *, * ) 'Nett force ', Sum( force_ffp( 1, : ) ), Sum( force_ffp( 2, : ) ), Sum( force_ffp( 3, : ) )
  Open( 11, file = 'forces_ffp.dat' )
  Write( 11, * ) n, '     #number of particles'
  Write( 11, * ) Sum( force_ffp( 1, : ) ), Sum( force_ffp( 2, : ) ), Sum( force_ffp( 3, : ) ), '     #Nett force'
  Do i = 1, n
     Write( 11, * ) i, force_ffp( :, i )
  End Do
  Close( 11 )
  Write( *, * ) 'FFP grid  time: ', t_grid
  Write( *, * ) 'FFP solve time: ', t_recip
  l_bad_charge = .False.
  Select Case( error )
  Case( -1 )
     Write( *, * ) 'WARNING: Sum of charge on grid greater than tolerance but "fixed" (for some value of fixed)'
     l_bad_charge = .True.
  Case( -2 )
     Write( *, * ) 'WARNING: Sum of charge on grid greater than tolerance AND could not be fixed'
     l_bad_charge = .True.
     Stop
  End Select

  ! Check how well the charge grid adds up to zero
  q_error = Sum( q_grid )

  ! Save the FFP potential
  Call grid_io_save( 11, 'pot_grid_FFP.dat', l, pot_grid_ffp )

  Write( *, * ) 'FFP: Sum of charge over grid: ', Sum( q_grid )
  Write( *, * ) 'FFP: Sum over pot grid      : ', Sum( pot_grid_ffp )

  ! SIC
  sic_ffp = ffp_sic( q, alpha )

  ! Calculate short range
  Call system_clock( start, rate )
  !$omp parallel default( none ) shared( l, q, r, alpha, max_G_shells, real_E_ffp )
  Call real_space_energy( l, q, r, alpha / Sqrt( 2.0_wp ), max_G_shells, real_E_ffp )
  !$omp end parallel
  Call system_clock( finish, rate )
  Write( *, * ) 'FFP real time: ', Real( finish - start, wp ) / rate

  ! And hence total energy
  tot_E_ffp = real_E_ffp + sic_ffp + recip_E_ffp

  ! END FFP SECTION
  !
!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!
  !
  ! SLOW FOURIER POISSON SOLVER (SFP) i.e. no FFT
  ! Can be slow so optional

  If( do_sfp ) Then
     ! Fourier space energy
     Allocate( pot_grid( 0:n_grid( 1 ) - 1, 0:n_grid( 2 ) - 1, 0:n_grid( 3 ) - 1 ) )
     Call sfp_long_range(  l, q, r, alpha, ew_func, recip_E_sfp, q_grid, pot_grid, t_grid, t_recip, error )
     l_bad_charge = .False.
     Select Case( error )
     Case( -1 )
        Write( *, * ) 'WARNING: Sum of charge on grid greater than tolerance but "fixed" (for some value of fixed)'
        l_bad_charge = .True.
     Case( -2 )
        Write( *, * ) 'WARNING: Sum of charge on grid greater than tolerance AND could not be fixed'
        l_bad_charge = .True.
        Stop
     End Select

     Write( *, * ) 'SFP grid  time: ', t_grid
     Write( *, * ) 'SFP solve time: ', t_recip
     ! Save the q grid to file
     Call grid_io_save( 11, 'q_grid.dat', l, q_grid )

     Write( *, * ) 'SFP: Sum of charge over grid: ', Sum( q_grid )
     Write( *, * ) 'SFP: Sum over pot grid      : ', Sum( pot_grid )

     ! Save the pot grid to file
     Call grid_io_save( 11, 'pot_grid.dat', l, pot_grid )

     ! SFP self interaction correction
     sic_sfp = sfp_sic( q, alpha )

     ! SFP Real Space - same as FFP
     real_E_sfp = real_E_ffp

     ! And hence the total energy
     tot_E_sfp = real_E_sfp + sic_sfp + recip_E_sfp
  End If

  ! END SFP SECTION
  !
!!!!!!!!!!!!!

!!!!!!!!!!
  !
  ! SYMETRICALLY SCREENED POISSON (SSP) - purely real space methods used, finite difference to solve eqns
  !

  ! Calculate the long range term by finite difference methods
  Allocate( pot_grid_ssp( 0:n_grid( 1 ) - 1, 0:n_grid( 2 ) - 1, 0:n_grid( 3 ) - 1 ) )
  Allocate( ei_ssp( 1:n ) )
  Allocate( force_ssp( 1:3, 1:n ) )
  Call ssp_long_range( l, q, r, alpha, FD_order, recip_E_ssp, q_grid, pot_grid_ssp, ei_ssp, force_ssp, t_grid, t_recip, error )
  Write( *, * ) 'Nett force ', Sum( force_ssp( 1, : ) ), Sum( force_ssp( 2, : ) ), Sum( force_ssp( 3, : ) )
  Open( 11, file = 'forces_ssp.dat' )
  Write( 11, * ) n, '     #number of particles'
  Write( 11, * ) Sum( force_ssp( 1, : ) ), Sum( force_ssp( 2, : ) ), Sum( force_ssp( 3, : ) ), '     #Nett force'
  Do i = 1, n
     Write( 11, * ) i, force_ssp( :, i )
  End Do
  Close( 11 )
  Write( *, * ) 'SSP grid  time: ', t_grid
  Write( *, * ) 'SSP solve time: ', t_recip
  l_bad_charge = .False.
  Select Case( error )
  Case( -1 )
     Write( *, * ) 'WARNING: Sum of charge on grid greater than tolerance but "fixed" (for some value of fixed)'
     l_bad_charge = .True.
  Case( -2 )
     Write( *, * ) 'WARNING: Sum of charge on grid greater than tolerance AND could not be fixed'
     l_bad_charge = .True.
     Stop
  End Select

  ! Save the SSP potential
  Call grid_io_save( 11, 'pot_grid_SSP.dat', l, pot_grid_ssp )

  Write( *, * ) 'SSP: Sum of charge over grid: ', Sum( q_grid )
  Write( *, * ) 'SSP: Sum over pot grid      : ', Sum( pot_grid_ssp )

  ! SIC ( Really same as ffp but let's be methodical )
  sic_ssp = ssp_sic( q, alpha )

  ! long range same as for ffp
  real_E_ssp = real_E_ffp

  ! And hence total energy
  tot_E_ssp = real_E_ssp + sic_ssp + recip_E_ssp

  ! END SSP SECTION
  !
!!!!!!!!!!!!!!!!!!!!!

!!!!!!!!!!!!!!!!!!!!!!!!!!!!
  !
  ! REPORT RESULTS

  Write( *, '( t39, a, t149, a )' ) 'Internal', 'DL_POLY'
  Write( *, '( t14, a, t39, a, t64, a, t89, a, t124, a, t149, a, t174, a, t199, a  )' ) &
       'Reciprocal', 'SIC', 'Real', 'Total', 'Reciprocal', 'SIC', 'Real', 'Total'
  Write( *, '( a4, 2( 4( g24.14, 1x ), :, 10x ) )' ) 'Ew  ', Real( recip_E, wp ), sic, real_E, tot_E, &
       Real( recip_E, wp ) * r4pie0, sic * r4pie0, real_E * r4pie0, tot_E * r4pie0
  If( do_sfp ) Then
     Write( *, '( a4, 2( 4( g24.14, 1x ), :, 10x ) )' ) &
          'SFP ', recip_E_sfp, sic_sfp, real_E_sfp, tot_E_sfp, &
          recip_E_sfp * r4pie0, sic_sfp * r4pie0, real_E_sfp * r4pie0, tot_E_sfp * r4pie0
  End If
  Write( *, '( a4, 2( 4( g24.14, 1x ), :, 10x ) )' ) &
       'FFP ', recip_E_ffp, sic_ffp, real_E_ffp, tot_E_ffp, &
       recip_E_ffp * r4pie0, sic_ffp * r4pie0, real_E_ffp * r4pie0, tot_E_ffp * r4pie0
  Write( *, '( a4, 2( 4( g24.14, 1x ), :, 10x ) )' ) &
       'SSP ', recip_E_ssp, sic_ssp, real_E_ssp, tot_E_ssp, &
       recip_E_ssp * r4pie0, sic_ssp * r4pie0, real_E_ssp * r4pie0, tot_E_ssp * r4pie0

  Write( *, * )
  If( do_sfp ) Then
     Write( *, '( "Difference in energy SFP - EW: ", g30.16 )' ) tot_E_sfp - tot_E
  End If
  Write( *, '( "Difference in energy FFP - EW:  ", g30.16 )' ) tot_E_ffp - tot_E
  Write( *, '( "Difference in energy SSP - EW:  ", g30.16 )' ) tot_E_ssp - tot_E
  Write( *, '( "Difference in energy FFP - SSP: ", g30.16 )' ) tot_E_ffp - tot_E_ssp

  rms_delta_pot   = Sum( ( pot_grid_ffp - pot_grid_ssp ) ** 2 )
  rms_delta_pot   = Sqrt( rms_delta_pot ) / Size( pot_grid_ffp )
  rms_delta_force = Sum( ( force_ffp - force_ssp ) ** 2 )
  rms_delta_force = Sqrt( rms_delta_force ) / Size( force_ffp )
  Write( *, '( a, g20.12 )' ) 'RMS (FFP-SSP) in potential: ', rms_delta_pot
  Write( *, '( a, g20.12 )' ) 'RMS (FFP-SSP) in force    : ', rms_delta_force

  ! Add a line to the summary file
  Inquire( file = 'summary.dat', exist = fexist )
  Open( 11, file = 'summary.dat', position = 'append' )
  If( .Not. fexist ) Then
     Write( 11, '( a7, 2x, a5, 2x, a2, 1x, a6, 1x, a2, 1x, a9, &
          & t40, 3( a14, 11x ), t120, 3( a14, 11x ), t200, a14, t230, a, t260, a )' ) &
          'alpha', 'dg', 'Od', 'xshift', 'Rg', 'Q error', &
          'tot E'  , 'tot E SSP'  , 'Delta tot E', &
          'recip E FFP', 'recip E SSP', 'Delta recip E', &
          'RMS delta pot', 'RMS Delta force', 'Bad Charge'
  End If
  Write( 11, '( f8.6, 1x, f6.4, 1x, i2, 1x, f6.4, 1x, i2, 1x, g9.2, &
       & t40, 3( g24.14, 1x ), t120, 3( g24.14, 1x ), t200, g24.14, t230, g24.14, t260, l1 )' ) &
       alpha, dg( 1 ), FD_order, xshift, range_gauss, q_error, &
       tot_E, tot_E_ssp, Abs( tot_E - tot_E_ssp ), &
       Real( recip_E_ffp, wp ), recip_E_ssp, Abs( Real( recip_E_ffp, wp ) - recip_E_ssp ), &
       rms_delta_pot, rms_delta_force, l_bad_charge
  Close( 11 )

  ! END REPORTING RESULTS SECTION
  !
!!!!!!!!!!!

Contains

  Subroutine read_header( unit, n, level, vecs )

    Integer                      , Intent( In    ) :: unit
    Integer                      , Intent(   Out ) :: n
    Integer                      , Intent(   Out ) :: level
    Real( wp ), Dimension( :, : ), Intent(   Out ) :: vecs

    Integer :: junk

    Read( unit, * )
    Read( unit, * ) level, junk, n
    Read( unit, * ) vecs

  End Subroutine read_header

  Subroutine read_config( level, unit, q, r )

    Integer                      , Intent( In    ) :: level
    Integer                      , Intent( In    ) :: unit
    Real( wp ), Dimension( :    ), Intent(   Out ) :: q
    Real( wp ), Dimension( :, : ), Intent(   Out ) :: r

    Integer :: n
    Integer :: i

    Character( Len = 3 ) :: what

    n = Size( q )

    Do i = 1, n
       Read( unit, * ) what
       If( what == 'Na+' ) Then
          q( i ) = +1.0_wp
       Else If( what == 'Cl-' ) Then
          q( i ) = -1.0_wp
       Else
          Write( *, * ) 'what is a ', what, ' ?'
          Stop 'Error in CONFIG reading'
       End If
       Read( unit, * ) r( :, i )
       If( level >= 1 ) Then
          Read( unit, * )
       End If
       If( level >= 2 ) Then
          Read( unit, * )
       End If
    End Do

  End Subroutine read_config

  Subroutine generate_ew_func( l, q, r, alpha, ew_func )

    Use, Intrinsic :: iso_fortran_env, Only :  wp => real64

    Type( lattice )               , Intent( In    ) :: l
    Real( wp ), Dimension( :     ), Intent( In    ) :: q
    Real( wp ), Dimension( :, :  ), Intent( In    ) :: r
    Real( wp ),                     Intent( In    ) :: alpha
    Complex( wp ), Dimension( 0: ), Intent(   Out ) :: ew_func

    Complex( wp ) :: s_fac

    Real( wp ), Dimension( 1:3 ) :: G

    Real( wp ) :: G_len_sq, G_fac

    Integer :: iG

    ew_func( 0 ) = 0.0_wp
    !$omp parallel default( none ) shared( n, ew_func, l, alpha, q, r ) &
    !$omp                          private( s_fac, ig, G, G_len_sq, G_fac )
    !$omp do
    Do iG = 1, Ubound( ew_func, Dim = 1 )
       Call l%get_nth_rec_vec( ig + 1, G )
       G = G * 2.0_wp * pi
       ! Calculate the structure factor for this G vector
       s_fac = 0.0_wp
       Do j = 1, n
          s_fac = s_fac + &
               q( j ) * Exp( Cmplx( 0.0_wp, - Dot_product( G, r( :, j ) ), wp ) )
       End Do
       G_len_sq = Dot_product( G, G )
       G_fac = Exp( - G_len_sq / ( 4.0_wp * alpha * alpha ) ) / G_len_sq
       ! Note difference from Darden paper - here in the ewfunc we have adsorbed 2*pi into the lattice vectors
       ! Hence we multiply though by 4 * pi * pi and then another factor of 2 as this is for the potential
       ! not the energy. This formulation is the same as in Appendix B of Kittel
       ew_func( iG ) = ( 4.0_wp * pi / l%get_volume() ) * s_fac * g_fac
    End Do
    !$omp end do
    !$omp end parallel

  End Subroutine generate_ew_func

  Subroutine trad_ewald( l, q, r, alpha, ew_func, recip_E, sic, real_E, tot_E, t_recip, t_real )

    Use, Intrinsic :: iso_fortran_env, Only :  wp => real64, li => int64

    Use lattice_module, Only : lattice

    Type( lattice )               , Intent( In    ) :: l
    Real( wp ), Dimension( :     ), Intent( In    ) :: q
    Real( wp ), Dimension( :, :  ), Intent( In    ) :: r
    Real( wp ),                     Intent( In    ) :: alpha
    Complex( wp ), Dimension( 0: ), Intent( In    ) :: ew_func
    Real( wp )                    , Intent( Out   ) :: recip_E
    Real( wp )                    , Intent( Out   ) :: SIC
    Real( wp )                    , Intent( Out   ) :: real_E
    Real( wp )                    , Intent( Out   ) :: tot_E
    Real( wp )                    , Intent( Out   ) :: t_recip
    Real( wp )                    , Intent( Out   ) :: t_real

    Complex( wp ) :: potg
    Complex( wp ) :: cc, cy, ct

    Real( wp ), Dimension( 1:3 ) :: G
    Real( wp ), Dimension( 1:3 ) :: ri

    Real( wp ) :: pot

    Integer :: max_G_shells = 2
    Integer :: n
    Integer :: i, iG

    Integer( li ) :: start, finish, rate

    n = Size( q )

    Call system_clock( start, rate )
    recip_E = 0.0_wp
    !$omp parallel default( none ) shared( l, r, recip_E, q, n, ew_func ) &
    !$omp                          private( i, iG, pot, G, ri, cc, cy, ct, potg )
    cc = 0.0_wp
    !$omp do reduction( +:recip_E )
    Do i = 1, n
       pot = 0.0_wp
       ri = r( :, i )
       Do iG = 1, Ubound( ew_func, Dim = 1 )
          Call l%get_nth_rec_vec( ig + 1, G )
          G = G * 2.0_wp * pi
          potG = Exp( Cmplx( 0.0_wp, Dot_product(   G, ri ), wp ) ) *        ew_func( ig )
          pot = pot + Real( potG + Conjg( potG ), wp )
       End Do
       cy = q( i ) * pot - cc
       ct = recip_E + cy
       cc = ( ct - recip_E ) - cy
       recip_E = Real( ct, wp )
    End Do
    !$omp end do
    !$omp end parallel
    recip_E = recip_E * 0.5_wp
    Call system_clock( finish, rate )
    t_recip = Real( finish - start, wp ) / rate

    ! Self interaction correction
    sic = - Sum( q * q ) * alpha / Sqrt( pi )

    Call system_clock( start, rate )
    !$omp parallel default( none ) shared( l, q, r, alpha, max_G_shells, real_E )
    Call real_space_energy( l, q, r, alpha, max_G_shells, real_E )
    !$omp end parallel
    Call system_clock( finish, rate )
    t_real = Real( finish - start, wp ) / rate

    tot_E = real_E + Real( recip_E, wp ) + sic

  End Subroutine trad_ewald

  Subroutine get_n_grid( l, alpha, range_gauss, gauss_tol, n_grid )

    Type( lattice ),              Intent( In    ) :: l
    Real( wp ),                   Intent( In    ) :: alpha
    Integer   ,                   Intent( In    ) :: range_gauss
    Real( wp ),                   Intent( In    ) :: gauss_tol
    Integer   , Dimension( 1:3 ), Intent(   Out ) :: n_grid

    Real( wp ), Parameter :: pi = 3.141592653589793238462643383279502884197_wp

    Real( wp ), Dimension( 1:3, 1:3 ) :: dir_vecs

    Real( wp ), Dimension( 1:3 ) :: dr

    Real( wp ) :: Gsq

    Real( wp ) :: max_r

    Integer :: i

    ! Find range after which the NORMALISED gaussian decays to below the tolerance
    max_r = pi * Sqrt( pi ) * gauss_tol / ( alpha * alpha * alpha )
    max_r = - Log( max_r ) / ( alpha * alpha )
    max_r = Sqrt( max_r )

    ! Now work out what resolution that require given the number of grid points
    ! we are using to represent the gaussian
    dr = max_r / range_gauss

    ! And so how many grid points along each lattice vector, rounding up
    ! to ensure accuracy
    dir_vecs = l%get_direct_vectors()

    Do i = 1, 3
       Gsq = Dot_product( dir_vecs( :, i ), dir_vecs( :, i ) )
       n_grid( i ) = Ceiling( Sqrt( Gsq ) / dr( i ) )
    End Do

  End Subroutine get_n_grid

End Program test


***********************************************************************
c                    ORBEL_EHYBRID.F
***********************************************************************
*     PURPOSE:  Solves Kepler's eqn.   e is ecc.   m is mean anomaly.
*
*             Input:
*                           e ==> eccentricity anomaly. (real scalar)
*                           m ==> mean anomaly. (real scalar)
*             Returns:
*              orbel_ehybrid ==>  eccentric anomaly. (real scalar)
*
*     ALGORITHM: For e < 0.18 uses fast routine ESOLMD
*	         For larger e but less than 0.8, uses EGET
*	         For e > 0.8 uses EHIE
*     REMARKS: Only EHIE brings M and E into range (0,TWOPI)
*     AUTHOR: M. Duncan
*     DATE WRITTEN: May 25,1992.
*     REVISIONS: 2/26/93 hfl
***********************************************************************

	real*8 function orbel_ehybrid(e,m)

      include '../swift.inc'

c...  Inputs Only:
	real*8 e,m

c...  Internals:
	real*8 orbel_esolmd,orbel_eget,orbel_ehie

c----
c...  Executable code

	if(e .lt. 0.18d0) then
	  orbel_ehybrid = orbel_esolmd(e,m)
	else
	  if( e .le. 0.8d0) then
	     orbel_ehybrid = orbel_eget(e,m)
	  else
	     orbel_ehybrid = orbel_ehie(e,m)
	  endif
	endif

	return
	end     ! orbel_ehybrid

c--------------------------------------------------------------------


c=======================================================================
c
c     subroutine ETAHAT
c
c     etah= sum(i,j = 1,n, (f(i,j)-cov(i,j))^2)
c
c-----------------------------------------------------------------------
      subroutine etahat(p, cov, f, etah)
c-----------------------------------------------------------------------
c
c     INPUT
c
c            p      : number of assets (p > 1)                   integer
c            cov    : covariance matrix (p*p)                     double
c            f      : shrinkage target matrix (p*p)               double
c
c     OUTPUT
c            etah   : scalar useful for the computation of the
c                    shrinkage intensity                          double
c
c-----------------------------------------------------------------------
c
      implicit none
c     i/o variables
      integer p
      double precision cov(*), f(*), etah
c     local variables
      double precision temp
      integer i, j

      etah = 0.
      do i=1,p
        do j=1,i-1
            temp = cov((i-1)*p+j)-f((i-1)*p+j)
            temp = temp * temp
            etah = etah + temp
        enddo
      enddo
      etah = 2* etah
c     Remark: Diagonals of f and cov are equal
      return
      end


module derived_types
    use, intrinsic :: iso_fortran_env, dp => real64
    use math, only: PI
    use astronomy, only: convertEquatorToGalact, &
                         convertGalacticToXYZ, &
                         convertEquatorMotionToUVW
    implicit none

    private

    public :: Star, &
              JaggedArray

    type Star
        real(dp) :: distance, &
                    rightAscension, &
                    declination, &
                    motionInRA, &
                    motionInDEC, &
                    magnitude, &
                    lattitude, &
                    longitude
        real(dp), dimension(3) :: coords, &
                                  vel
        character(len = 5) :: spectralType
    contains
        procedure :: equatToGalact => star_equatToGalact
        procedure :: galactToXYZ => star_galactToXYZ
        procedure :: equatToUVW => star_equatToUVW
    end type

    type JaggedArray
        type(Star), dimension(:), allocatable :: row
    end type JaggedArray

contains

    impure elemental subroutine star_equatToGalact(this)
        class (Star), intent(inout) :: this

        if ((abs(this%rightAscension) > 2.0_dp*PI) .or. &
            (abs(this%declination) > 2.0_dp*PI)) stop "Error: wrong angle &
            &input in star_equatToGalact"

        call convertEquatorToGalact(this%rightAscension, &
                                    this%declination, &
                                    this%longitude, &
                                    this%lattitude)
    end subroutine star_equatToGalact

    impure elemental subroutine star_galactToXYZ(this)
        class(Star), intent(inout) :: this

        ! TODO: check why I have an angle more than 2pi
        ! print *, i, this%longitude, this%lattitude
        ! i = i + 1
        ! if ((abs(this%longitude) > 2.0_dp*PI) .or. &
        !     (abs(this%lattitude) > 2.0_dp*PI)) stop "Error: wrong angle &
        !     &input in star_galactToXYZ"

        this%coords = convertGalacticToXYZ(this%distance, &
                                           this%longitude, &
                                           this%lattitude)
    end subroutine star_galactToXYZ

    impure elemental subroutine star_equatToUVW(this)
        class(Star), intent(inout) :: this

        call convertEquatorMotionToUVW(this%rightAscension, &
                                       this%declination, &
                                       this%distance, &
                                       this%motionInDEC, &
                                       this%motionInRA, &
                                       this%vel)
    end subroutine star_equatToUVW

end module derived_types


MODULE  qflow

  USE prms

  IMPLICIT none

  integer                              :: NsQ
  real, allocatable, dimension(:)      :: Qi
  real, allocatable, dimension(:,:)    :: Xi

  real                                 :: alphaQ

  integer                              :: Nk1,Nk2
  complex, allocatable, dimension(:,:) :: Qhat
  real , allocatable, dimension(:,:)   :: km2,km2i
  real, allocatable, dimension(:)      :: kap1,kap2

CONTAINS

  SUBROUTINE initQflow

    integer      :: l,k,k1,k2

    open(1,file='qflow.in')
    read(1,*) alphaQ
    read(1,*) Nk1,Nk2
    read(1,*) NsQ

    allocate(Qi(NsQ))
    allocate(Xi(2,NsQ))

    do l = 1,NsQ
       read(1,*)Qi(l),Xi(:,l)
    end do
    close(1)
    Xi(1,:) = Xi(1,:)*Lb(1)
    Xi(2,:) = Xi(2,:)*Lb(2)

    allocate(Qhat(-Nk1:Nk1,-Nk2:Nk2))
    allocate(kap1(-Nk1:Nk1),kap2(-Nk2:Nk2),km2(-Nk1:Nk1,-Nk2:Nk2),km2i(-Nk1:Nk1,-Nk2:Nk2))

    do k = -Nk1,Nk1
       kap1(k) = 2.*Pi*REAL(k)/Lb(1)
    end do
    do k = -Nk2,Nk2
       kap2(k) = 2.*Pi*REAL(k)/Lb(2)
    end do
    do k2 = -Nk2,Nk2
       do k1 = -Nk1,Nk1
          km2(k1,k2) = kap1(k1)**2 + kap2(k2)**2
       end do
    end do
    km2i = 1./km2
    km2i(0,0) = 0.

    print *,km2(Nk1,Nk2)
    write(6,"('Q FOURIER: ',E20.10)")EXP(-km2(Nk1,Nk2)/4./alphaQ)
    write(6,"('Q REAL:    ',E20.10)")MAXVAL(EXP(-Lb**2*alphaQ))

    call getQhat

  END SUBROUTINE initQflow

  SUBROUTINE testQflow

    integer, parameter     :: Nx = 200
    integer, parameter     :: Ny = 200
    integer, parameter     :: Np = Nx*Ny

    real, dimension(2,Nx,Ny)  :: Xt
    real, dimension(2,Nx,Ny)  :: u

    integer                 :: i,j,k

    do j = 1,Ny
       do i = 1,Nx
          Xt(1,i,j) = Lb(1)*REAL(i-1)/REAL(Nx-1)
          Xt(2,i,j) = Lb(2)*REAL(j-1)/REAL(Ny-1)
       end do
    end do

    call getQflow(Np,Xt,u)

    open(1,file='uout.f')
    write(1,*)Nx,Ny,2
    write(1,*)u(1,:,:),u(2,:,:)
    close(1)

    open(1,file='uout.g')
    write(1,*)Nx,Ny
    write(1,*)Xt(1,:,:),Xt(2,:,:)
    close(1)

  END SUBROUTINE testQflow

  SUBROUTINE getQhat

    integer    :: k1,k2
    integer    :: i

    Qhat = 0.

    do k2 = -Nk2,Nk2
       do k1 = -Nk1,Nk1
          do i = 1,NsQ
             Qhat(k1,k2) = Qhat(k1,k2)  &
                  + Qi(i)*EXP(-(0.,1.)*(kap1(k1)*Xi(1,i) + kap2(k2)*Xi(2,i)))
          end do
       end do
    end do

  END SUBROUTINE getQhat

  SUBROUTINE getQflow(Np,X,u)
    integer                :: Np
    real, dimension(2,Np)  :: X,u

    integer                :: i,j,k1,k2

    real                   :: r2
    real, dimension(2)     :: xij

    u = 0.
    do j = 1,Np
       do i = 1,NsQ
          xij = X(:,j)-Xi(:,i)
          xij = xij - NINT(xij/Lb)*Lb
          r2 = SUM(xij*xij)
          u(:,j) = u(:,j) + Qi(i)*EXP(-alphaQ*r2)*xij/r2/(2.*Pi)
       end do

       do k2 = -Nk2,Nk2
          do k1 = -Nk1,Nk1
             u(:,j) = u(:,j) - REAL(Qhat(k1,k2)* &
                  (0.,1.)*(/ kap1(k1),kap2(k2) /)*km2i(k1,k2) &
                  * EXP(-km2(k1,k2)/4./alphaQ+(0.,1.)*(kap1(k1)*X(1,j) + kap2(k2)*X(2,j))))/tau0
          end do
       end do
    end do

  END SUBROUTINE getQflow

END MODULE qflow


*DECK CPPFA
      SUBROUTINE CPPFA (AP, N, INFO)
C***BEGIN PROLOGUE  CPPFA
C***PURPOSE  Factor a complex Hermitian positive definite matrix stored
C            in packed form.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2D1B
C***TYPE      COMPLEX (SPPFA-S, DPPFA-D, CPPFA-C)
C***KEYWORDS  LINEAR ALGEBRA, LINPACK, MATRIX FACTORIZATION, PACKED,
C             POSITIVE DEFINITE
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     CPPFA factors a complex Hermitian positive definite matrix
C     stored in packed form.
C
C     CPPFA is usually called by CPPCO, but it can be called
C     directly with a saving in time if  RCOND  is not needed.
C     (Time for CPPCO) = (1 + 18/N)*(Time for CPPFA) .
C
C     On Entry
C
C        AP      COMPLEX (N*(N+1)/2)
C                the packed form of a Hermitian matrix  A .  The
C                columns of the upper triangle are stored sequentially
C                in a one-dimensional array of length  N*(N+1)/2 .
C                See comments below for details.
C
C        N       INTEGER
C                the order of the matrix  A .
C
C     On Return
C
C        AP      an upper triangular matrix  R , stored in packed
C                form, so that  A = CTRANS(R)*R .
C
C        INFO    INTEGER
C                = 0  for normal return.
C                = K  If the leading minor of order  K  is not
C                     positive definite.
C
C
C     Packed Storage
C
C          The following program segment will pack the upper
C          triangle of a Hermitian matrix.
C
C                K = 0
C                DO 20 J = 1, N
C                   DO 10 I = 1, J
C                      K = K + 1
C                      AP(K) = A(I,J)
C             10    CONTINUE
C             20 CONTINUE
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  CDOTC
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CPPFA
      INTEGER N,INFO
      COMPLEX AP(*)
C
      COMPLEX CDOTC,T
      REAL S
      INTEGER J,JJ,JM1,K,KJ,KK
C***FIRST EXECUTABLE STATEMENT  CPPFA
         JJ = 0
         DO 30 J = 1, N
            INFO = J
            S = 0.0E0
            JM1 = J - 1
            KJ = JJ
            KK = 0
            IF (JM1 .LT. 1) GO TO 20
            DO 10 K = 1, JM1
               KJ = KJ + 1
               T = AP(KJ) - CDOTC(K-1,AP(KK+1),1,AP(JJ+1),1)
               KK = KK + K
               T = T/AP(KK)
               AP(KJ) = T
               S = S + REAL(T*CONJG(T))
   10       CONTINUE
   20       CONTINUE
            JJ = JJ + J
            S = REAL(AP(JJ)) - S
            IF (S .LE. 0.0E0 .OR. AIMAG(AP(JJ)) .NE. 0.0E0) GO TO 40
            AP(JJ) = CMPLX(SQRT(S),0.0E0)
   30    CONTINUE
         INFO = 0
   40 CONTINUE
      RETURN
      END


! Rosenbrock integrator with manual time step control
! Solve: d/dt c = f(t,c)

! written by Edwin Spee, CWI, Amsterdam. Last update: July 28, 1997
! email: Edwin.Spee@cwi.nl (http://edwin-spee.mypage.org/)
! adapted to KPP-2.1 by Rolf Sander, Max-Planck Institute, Mainz, Germany, 2005
!
! Integration method for Ros2:
! C_{n+1} = C_n + 3/2 dt k_1 + 1/2 dt k_2
! k_1 = S f(t_n, C_n)
! k_2 = S [f(t_{n+1},C_n + dt k_1) - 2 k_1]
!
! where g = 1.0 + sqrt(0.5_dp),
! S = (I - g dt J ) ^ {-1}
! with J the Jacobian

MODULE KPP_ROOT_Integrator

  USE KPP_ROOT_Precision, ONLY: dp

  IMPLICIT NONE
  PUBLIC
  SAVE

  ! description of the error numbers IERR
  CHARACTER(LEN=50), PARAMETER, DIMENSION(1) :: IERR_NAMES = (/ &
    'dummy value                                       ' /)

CONTAINS

  ! **************************************************************************

  SUBROUTINE INTEGRATE( TIN, TOUT, &
    ICNTRL_U, RCNTRL_U, ISTATUS_U, RSTATUS_U, IERR_U )

    IMPLICIT NONE

    KPP_REAL, INTENT(IN) :: TIN  ! TIN - Start Time
    KPP_REAL, INTENT(IN) :: TOUT ! TOUT - End Time
    ! Optional input parameters and statistics
    INTEGER,  INTENT(IN),  OPTIONAL :: ICNTRL_U(20)
    KPP_REAL, INTENT(IN),  OPTIONAL :: RCNTRL_U(20)
    INTEGER,  INTENT(OUT), OPTIONAL :: ISTATUS_U(20)
    KPP_REAL, INTENT(OUT), OPTIONAL :: RSTATUS_U(20)
    INTEGER,  INTENT(OUT), OPTIONAL :: IERR_U

    CALL ROS2(TIN, TOUT)

    ! if optional parameters are given for output
    ! use them to store information in them
    IF (PRESENT(ISTATUS_U)) ISTATUS_U(:) = 0
    IF (PRESENT(RSTATUS_U)) THEN
      RSTATUS_U(:) = 0._dp
      RSTATUS_U(1)=TOUT ! put final time into RSTATUS_U
    ENDIF
    IF (PRESENT(IERR_U)) IERR_U = 1 ! dummy value

  END SUBROUTINE INTEGRATE

  ! **************************************************************************

  SUBROUTINE ROS2(Tstart,Tend)

    USE KPP_ROOT_Jacobian,         ONLY: Jac_SP
    USE KPP_ROOT_Global,           ONLY: VAR,   & ! VARiable species
                                         FIX,   & ! FIXed species
                                         RCONST   ! rate coefficients
    USE KPP_ROOT_JacobianSP,       ONLY: LU_DIAG
    USE KPP_ROOT_Function,         ONLY: Fun
    USE KPP_ROOT_LinearAlgebra,    ONLY: KppDecomp, KppSolve
    USE KPP_ROOT_Parameters,       ONLY: NVAR, LU_NONZERO

    IMPLICIT NONE

    KPP_REAL, INTENT(IN) :: Tstart, Tend

    KPP_REAL :: dt ! time step
    KPP_REAL :: k1(NVAR), k2(NVAR), w1(NVAR), g, jvs(LU_NONZERO)
    INTEGER ising, i

    dt = Tend - Tstart
    g = 1.0 + SQRT(0.5_dp)
    CALL JAC_sp(VAR, FIX, RCONST, jvs)
    jvs(1:LU_NONZERO) = -g*dt*jvs(1:LU_NONZERO)

    ! Rolf von Kuhlmann:
    ! optionally cut this out and replace it by directly addressed statements
    DO i=1,NVAR
      jvs(LU_DIAG(i)) = jvs(LU_DIAG(i)) + 1.0_dp
    END DO

    CALL KppDecomp (jvs, ising)

    IF (ising /= 0) THEN
      PRINT *,'ising <> 0, dt=',dt
      STOP
    END IF

    CALL Fun(VAR, FIX, RCONST, k1 )

    CALL KppSolve (jvs,k1)

    DO i = 1,NVAR
      w1(i) = MAX(0.0_dp, VAR(i) + dt * k1(i) )
    END DO

    CALL Fun(w1, FIX, RCONST, k2 )

    k2(1:NVAR) = k2(1:NVAR) - 2.0_dp*k1(1:NVAR)
    CALL KppSolve (jvs,k2)
    DO i = 1,NVAR
      VAR(i) = MAX( 0.0_dp, VAR(i)+1.5_dp*dt*k1(i)+0.5_dp*dt*k2(i) )
    END DO

  END SUBROUTINE ROS2

  ! **************************************************************************

END MODULE KPP_ROOT_Integrator


c=======================================================================
c
c     MVE
c
c     Efficient Frontier (Lagrange Method)
c
c-----------------------------------------------------------------------
      SUBROUTINE mve( nbValues, retA, retB, retC, volA, volB, volC,
     &                minExpectedReturn, maxExpectedReturn,
     &                iwork, dwork,
     &                mveRet, mveVol, info)
c-----------------------------------------------------------------------
c
c	Inputs
c		nbValues: integer, number of point(s) (>1)
c		retA: double, mean return of portfolio A
c		retB: double, mean return of portfolio B
c		retC: double, mean return of portfolio C
c		volA: double, volatility of portfolio A (>=0)
c		volB: double, volatility of portfolio B (>=0)
c		volC: double, volatility of portfolio C (>=0)
c		minExpectedReturn: double, minimum return of universe
c		maxExpectedReturn: double, maximum return of universe
c
c	Outputs
c		mveReturns: double array of dimension nbValues, vector of mean returns
c		mveVolatilities: double array of dimension nbValues, vector of volatilities
c		info: integer array of dimension 1, diagnostic argument
c
c	Call
c		nls
c
c=======================================================================
c
      IMPLICIT NONE
c
c     i/o arguments
      INTEGER nbValues, info
      DOUBLE PRECISION retA, retB, retC, volA, volB, volC
      DOUBLE PRECISION minExpectedReturn, maxExpectedReturn
      DOUBLE PRECISION mveRet(*), mveVol(*)
      EXTERNAL simext
c
c     workspaces
      INTEGER iwork(*)
      DOUBLE PRECISION dwork(*)
c
c     local variables
      INTEGER i, pdxinit, pdgrid, pdudat, pdxopt, pdgrad,
     &        pdobs, pdnls, piudat, pinls

      INTEGER mxopt, nfct, spadim, liudat, ldudat
      DOUBLE PRECISION epsbfg, eps, funct, step, tmp
      PARAMETER ( eps = 1.E-15 )
c
c-----------------------------------------------------------------------
c
c     initializations
      info   = 0
      mxopt  = 3
      nfct   = 3
      spadim = 1
      epsbfg = 1.E-8
      liudat = 0
      ldudat = 0
      funct = 0.
c
c     Double workspaces
c
      pdxinit = 1
c     needs mxopt
      pdobs = pdxinit + mxopt
c     needs nfct so mxopt + nfct
      pdgrid = pdobs + nfct
c     needs nfct so mxopt + nfct + nfct*spadim
      pdudat = pdgrid + nfct*spadim
c     needs 1 so mxopt + nfct + nfct*spadim + 1
      pdxopt = pdudat +1
c     needs mxopt so 2*mxopt + nfct + nfct*spadim + 1
      pdgrad = pdxopt + mxopt
c     needs mxopt so 3*mxopt + nfct + nfct*spadim + 1
      pdnls = pdgrad + mxopt
c     needs ( mxopt*(mxopt+17)/2 + nfct*(mxopt+3+spadim) + ldudat ) so
c     so mxopt*(mxopt+23)/2 + nfct*(mxopt+4+2*spadim) + 1
c
c     Integer workspaces
      piudat = 1
c     needs 1 so 1
      pinls = piudat + 1
c     needs 2*mxopt + 6 + liudat
c     so 2*mxopt + 6 + 1 = 2* mxopt + 7
c
      dwork(pdxinit)     = 0.1
      dwork(pdxinit + 1) = 0.1
      dwork(pdxinit + 2) = 0.1
c
c     volatilities
      dwork(pdgrid)   = retA
      dwork(pdgrid+1) = retB
      dwork(pdgrid+2) = retC
c
c     performances (returns)
      dwork(pdobs)     = volA
      dwork(pdobs + 1) = volB
      dwork(pdobs + 2) = volC
c
c     non-linear least-square (NLS)
      CALL nls ( simext, mxopt, nfct, dwork(pdxinit), dwork(pdobs),
     &           spadim, dwork(pdgrid), epsbfg, liudat, iwork(piudat),
     &           ldudat, dwork(pdudat), iwork(pinls), dwork(pdnls),
     &           dwork(pdxopt), funct, dwork(pdgrad), info)
      IF (info .LT. 0) RETURN
c
      step = (maxExpectedReturn - minExpectedReturn) / (nbValues - 1)
c
      DO i = 1,nbValues
        mveRet(i)= minExpectedReturn + i * step
      ENDDO
      DO i = 1,nbValues
        tmp = mveRet(i)
        mveVol(i) = dwork(pdxopt) + dwork(pdxopt+1)*tmp +
     &  dwork(pdxopt+2)*tmp*tmp
      ENDDO
      DO i = 1,nbValues
        IF (mveVol(i) .LT. 0.) mveVol(i) = 0.
      ENDDO
c
      RETURN
      END


      program blocking
      implicit none

C     Fortran code to illustrate effects of blocking for addition of matrix to
C     transpose of a matrix
C
C     Z = X + YT
C
C     Usage: blocking n
C            n = array dimension

      character(len=32) :: arg
      integer i, j, k, ii, jj, kk, tile, n
      integer clock1, clock2
      double precision, allocatable :: x(:,:), y (:,:), z(:,:)
      double precision elapsed_time, time

C     Get the array rank from command line
      call get_command_argument(1, arg)
      read(arg,*) n

C     Allocate arrays for arguments and result
      allocate(x(n,n), y(n,n), z(n,n))

C     Initialize the arrays x, y and z
      do j=1,n
         do i=1,n
            x(i,j) = i*1.1 + j*2.2
            y(i,j) = i*3.3 + j*4.4
            z(i,j) = 0.0
         enddo
      enddo

C     Matrix multiplication
      call system_clock(clock1)
      do j=1,n
         do k=1,n
            do i=1,n
               z(i,j) = z(i,j) + x(i,k) * y(k,j)
            enddo
         enddo
      enddo
      call system_clock(clock2)
      time = elapsed_time(clock1, clock2)

C     Add arrays X and YT using tiling
c      call system_clock(clock1)
c      tile = 128
c      do jj=1,n,tile
c         do kk=1,n,tile
c            do ii=1,n,tile
c               do j=jj,min(n, jj+tile-1)
c                  do k=kk,min(n, kk+tile-1)
c                     do i=ii,min(n, ii+tile-1)
c                        z(i,j) = z(i,j) + x(i,k) * y(k,j)
c                     enddo
c                  enddo
c               enddo
c            enddo
c         enddo
c      enddo
c      call system_clock(clock2)
c      time = elapsed_time(clock1, clock2)

C     Following code prevents compiler from optimizing away matrix
C     addition operation. Leaves open the possibility that the results
C     will be used
      if (z(1,1) == -1.0) then
         open (3,file="z.out",form="unformatted",access="sequential")
         write(3) z
      endif

      write(*,*) 'n    = ', n
      write(*,*) 'time = ', time

      end program blocking

C     -------------------------------------------------------------------

      double precision function elapsed_time(c1, c2)
      implicit none

C     Return the elapsed time bewteen the clock counts c1 and
C     c2. Although c2 corresponds to a later time than c1, we need to
C     explicitly test for the possibility that the system clock had
C     rolled over.

      integer, intent(in) :: c1, c2
      integer ticks, clockrate, clockmax

      call system_clock(count_max=clockmax, count_rate=clockrate)

      ticks = c2-c1
      if(ticks < 0) then
         ticks = clockmax + ticks
      endif
      elapsed_time = dble(ticks)/dble(clockrate)

      return
      end function elapsed_time


program test_constants
	use constants_def
    use constants_lib
    integer :: ierr

    call constants_init('',ierr)
    if (ierr /= 0) stop

	call do_one('pi',pi)
	call do_one('twopi',twopi)
	call do_one('threepi',threepi)
	call do_one('fourpi',fourpi)
	call do_one('onethird',onethird)
	call do_one('twothird',twothird)
	call do_one('fivethird',fivethird)
	call do_one('seventhird',seventhird)
	call do_one('threepisquare',threepisquare)
	call do_one('boltzmann',boltzmann)
	call do_one('avogadro',avogadro)
	call do_one('clight',clight)
	call do_one('clight2',clight2)
	call do_one('amu',amu)
	call do_one('amu*NA-1',amu*avogadro-1.0_dp)
	call do_one('hbar',hbar)
	call do_one('finestructure',finestructure)
	call do_one('GMsun',GMsun)
	call do_one('Gnewton',Gnewton)
	call do_one('Msun',Msun)
	call do_one('Mneutron',Mneutron)
	call do_one('Mproton',Mproton)
	call do_one('electroncharge',electroncharge)
	call do_one('e**2/(hbar*c)/alpha-1',electroncharge**2/hbar/clight/finestructure-1.0_dp)
	call do_one('Melectron',Melectron)
	call do_one('Mmuon',Mmuon)
	call do_one('mev_to_ergs',mev_to_ergs)
	call do_one('fm_to_cm',fm_to_cm)
	call do_one('ergs_to_mev',ergs_to_mev)
	call do_one('cm_to_fm',cm_to_fm)
	call do_one('a_Bohr',a_Bohr)
	call do_one('a_Bohr/a_Bohr(CODATA)-1',a_Bohr/0.52917721092e-8_dp - 1.0_dp)
	call do_one('Rydberg',Rydberg)
	call do_one('Rydberg/CODATA - 1',2.0_dp*Rydberg/4.35974434e-11_dp - 1.0_dp)
	call do_one('hbarc_n',hbarc_n)
	call do_one('mass_n',mass_n)
	call do_one('length_n',length_n)
	call do_one('density_n',density_n)
	call do_one('pressure_n',pressure_n)
	call do_one('temperature_n',temperature_n)
	call do_one('Mn_n',Mn_n)
	call do_one('Mp_n',Mp_n)
	call do_one('Me_n',Me_n)
	call do_one('mass_g',mass_g)
	call do_one('potential_g',potential_g)
	call do_one('length_g',length_g)
	call do_one('density_g',density_g)
	call do_one('pressure_g',pressure_g)
	call do_one('time_g',time_g)

	contains
	subroutine do_one(name,val)
		character(len=*), parameter :: fmt = '(a24," = ",es20.13)'
		character(len=*), intent(in) ::  name
		real(dp), intent(in) :: val
		write (*,fmt) name, val
	end subroutine do_one

end program test_constants