!*******************************************************************************
!**
!**  PROGRAM test_Ar_FCCcohesive_NEIGH_RVEC
!**
!**  KIM compliant program to find (using the Golden section search algorithm)
!**  the minimum energy of one atom in a periodic FCC crystal (spec="Ar") as a 
!**  function of lattice spacing.
!**
!**  Works with the following NBC methods:
!**        NEIGH-RVEC-F
!**
!**  Authors: Valeriu Smirichinski, Ryan S. Elliott, Ellad B. Tadmor
!**
!**  Copyright 2011 Ellad B. Tadmor, Ryan S. Elliott, and James P. Sethna
!**  All rights reserved.
!**
!*******************************************************************************


!-------------------------------------------------------------------------------
!
! Main program
!
!-------------------------------------------------------------------------------
program test_Ar_FCCcohesive_NEIGH_RVEC
  use KIMservice
  implicit none

!============================== VARIABLE DEFINITIONS ==========================

  ! parameters controlling behavior of test
  !
  character(len=80), parameter :: testname    = "test_Ar_FCCcohesive_NEIGH_RVEC"
  character(len=2),  parameter :: specname    = 'Ar'
  double precision,  parameter :: TOL         = 1.0d-8
  double precision,  parameter :: FCCspacing  = 5.26d0 ! in angstroms
  double precision,  parameter :: MinSpacing  = 0.800d0*FCCspacing
  double precision,  parameter :: MaxSpacing  = 1.200d0*FCCspacing
  integer,           parameter :: DIM         = 3

  ! significant local variables
  !
  integer,          allocatable :: NLRvecLocs(:)     ! neighbor list pointers
  integer,          allocatable :: neighborList(:,:) ! neighbor list storage
  double precision, allocatable :: RijList(:,:,:)    ! Rij vector list storage

  integer              :: NNeighbors         ! maximum number of neighbors for an atom

  double precision     :: FinalSpacing       ! crystal lattice parameter

  double precision     :: FinalEnergy        ! energy per atom of crystal 
                                             ! at current spacing

  integer              :: CellsPerCutoff     ! number of unit cells along
                                             ! box (of size cutoff) side


  ! KIM variables
  !
  character(len=80)         :: modelname     ! KIM-compliant model name

  integer(kind=kim_intptr)  :: pkim          ! pointer to KIM API object

  integer                   :: ier           ! error flag

  real*8 coordum(DIM,1);   pointer(pcoor,coordum)         ! coordinate

  real*8 cutoff; pointer(pcutoff,cutoff)                  ! cutoff radius of Model

  integer(kind=kim_intptr) :: N                           ! number of atoms


  ! other variables
  !
  double precision, external  ::  get_model_cutoff_firsttime

!========================= END VARIABLE DEFINITIONS ==========================


  ! Read in KIM Model name to use
  !
  print '("Please enter a valid KIM model name: ")'
  read(*,*) modelname


  ! We'll use just one atom for this calculation!
  !
  N = 1


  ! Setup the KIM API object
  !
  call setup_KIM_API_object(pkim, testname, modelname, N, specname)


  ! allocate storage for neighbor lists, compute them for the first time, 
  ! and store necessary pointers in KIM API object
  !
  ! First, access the `cutoff' arguemt
  !
  pcutoff = kim_api_get_data_f(pkim, "cutoff", ier)
  if (ier.le.0) then
     call report_error(__LINE__, "kim_api_get_data_f", ier)
     stop
  endif
  !
  ! Second, determine how many neighbors we will need
  !
  CellsPerCutoff = ceiling(cutoff/MinSpacing+ 0.05d0) ! the 0.05 is a saftey factor
  NNeighbors = 4*((2*CellsPerCutoff + 1)**3)
  !
  ! allocate memory for the neighbor list and Rij vectors
  !
  allocate(neighborList(NNeighbors+1,N))
  allocate(RijList(3,NNeighbors+1,N))
  allocate(NLRvecLocs(3))
  !
  NLRvecLocs(1) = loc(neighborList)
  NLRvecLocs(2) = loc(RijList)
  NLRvecLocs(3) = NNeighbors+1
  call setup_neighborlist_Rij_KIM_access(pkim, NLRvecLocs)


  ! find equilibrium spacing by minimizing coheseive energy with respect
  ! to the periodic box size
  !
  call NEIGH_RVEC_compute_equilibrium_spacing(pkim, &
         DIM,CellsPerCutoff,MinSpacing,MaxSpacing,  &
         TOL,N,NNeighbors,neighborlist,RijList,     &
         .false.,FinalSpacing,FinalEnergy)

  ! print results to screen
  !
  print '(80(''-''))'
  print '("This is Test          : ",A)', testname
  print '("Results for KIM Model : ",A)', modelname
  print *
  print '("Found minimum energy configuration to within",E25.15)', TOL
  print *
  print '("Energy/atom = ",E25.15,"; Spacing = ",E25.15)', FinalEnergy, FinalSpacing
  print '(80(''-''))'


  ! Don't forget to free and/or deallocate
  !
  deallocate(neighborList)
  deallocate(RijList)
  deallocate(NLRvecLocs)
  call free_KIM_API_object(pkim)

  stop

end program test_Ar_FCCcohesive_NEIGH_RVEC

!-------------------------------------------------------------------------------
!
! NEIGH_RVEC_compute_equilibrium_spacing : 
!
!    Use the Golden section search algorithm to find the equilibrium spacing by 
!    minimizing the energy of the system with respect to the periodic box size.
!
!-------------------------------------------------------------------------------
subroutine NEIGH_RVEC_compute_equilibrium_spacing(pkim, &
             DIM,CellsPerCutoff,MinSpacing,MaxSpacing,  &
             TOL,N,NNeighbors,neighborlist,RijList,     &
             verbose,RetSpacing,RetEnergy)
  use KIMservice
  implicit none
  
  !-- Transferred variables
  integer(kind=kim_intptr), intent(in)  :: pkim
  integer,                  intent(in)  :: DIM
  integer,                  intent(in)  :: CellsPerCutoff
  double precision,         intent(in)  :: MinSpacing
  double precision,         intent(in)  :: MaxSpacing
  double precision,         intent(in)  :: TOL
  integer(kind=kim_intptr), intent(in)  :: N
  integer,                  intent(in)  :: NNeighbors
  integer,                  intent(in)  :: neighborList(NNeighbors+1,N)
  double precision,         intent(in)  :: RijList(3,NNeighbors+1,N)
  logical,                  intent(in)  :: verbose
  double precision,         intent(out) :: RetSpacing
  double precision,         intent(out) :: RetEnergy
  
  !-- Local variables
  double precision,         parameter :: Golden      = (1.d0 + sqrt(5.d0))/2.d0
  integer ier
  double precision Spacings(4)
  double precision Energies(4)
  real*8 energy;           pointer(penergy,energy)
  integer N4
  real*8 coordum(DIM,1);   pointer(pcoor,coordum)
  real*8, pointer :: coords(:,:)
  real*8 cutoff;           pointer(pcutoff,cutoff)

  ! Unpack data from KIM object
  !
  penergy = kim_api_get_data_f(pkim, "energy", ier)
  if (ier.le.0) then
     call report_error(__LINE__, "kim_api_get_data_f", ier)
     stop
  endif

  pcoor = kim_api_get_data_f(pkim, "coordinates", ier)
  if (ier.le.0) then
     call report_error(__LINE__, "kim_api_get_data_f", ier)
     stop
  endif
  N4 = N  ! (Some routines expect N to be integer*4)
  call toRealArrayWithDescriptor2d(coordum, coords, DIM, N4)

  pcutoff = kim_api_get_data_f(pkim, "cutoff", ier)
  if (ier.le.0) then
     call report_error(__LINE__, "kim_api_get_data_f", ier)
     stop
  endif


  ! Initialize for minimization
  !
  Spacings(1) = MinSpacing
  ! compute new neighbor lists (could be done more intelligently, I'm sure)
  call NEIGH_RVEC_F_periodic_FCC_neighborlist(CellsPerCutoff, (cutoff+0.75), &
                                              Spacings(1), N4, NNeighbors,   &
                                              neighborList, RijList)
  call kim_api_model_compute_f(pkim, ier)
  if (ier.le.0) then
     call report_error(__LINE__, "kim_api_model_compute_f", ier)
     stop
  endif
  Energies(1) = energy
  if (verbose) &
     print *, "Energy/atom = ", Energies(1), "; Spacing = ", Spacings(1)

  ! setup and compute for max spacing
  Spacings(3) = MaxSpacing
  ! compute new neighbor lists (could be done more intelligently, I'm sure)
  call NEIGH_RVEC_F_periodic_FCC_neighborlist(CellsPerCutoff, (cutoff+0.75), &
                                              Spacings(3), N4, NNeighbors,   &
                                              neighborList, RijList)
  ! Call model compute
  call kim_api_model_compute_f(pkim, ier)
  if (ier.le.0) then
     call report_error(__LINE__, "kim_api_model_compute_f", ier)
     stop
  endif
  Energies(3) = energy
  if (verbose) &
     print *, "Energy/atom = ", Energies(3), "; Spacing = ", Spacings(3)

  ! setup and compute for first intermediate spacing
  Spacings(2) = MinSpacing + (2.0 - Golden)*(MaxSpacing - MinSpacing)
  ! compute new neighbor lists (could be done more intelligently, I'm sure)
  call NEIGH_RVEC_F_periodic_FCC_neighborlist(CellsPerCutoff, (cutoff+0.75), &
                                              Spacings(2), N4, NNeighbors,   &
                                              neighborList, RijList)
  ! Call model compute
  call kim_api_model_compute_f(pkim, ier)
  if (ier.le.0) then
     call report_error(__LINE__, "kim_api_model_compute_f", ier)
     stop
  endif
  Energies(2) = energy
  if (verbose) &
     print *, "Energy/atom = ", Energies(2), "; Spacing = ", Spacings(2)


  ! iterate until convergence.
  !
  do while (abs(Spacings(3) - Spacings(1)) .gt. TOL)
     ! set new spacing
     Spacings(4) = (Spacings(1) + Spacings(3)) - Spacings(2)
     ! compute new neighbor lists (could be done more intelligently, I'm sure)
     call NEIGH_RVEC_F_periodic_FCC_neighborlist(CellsPerCutoff, (cutoff+0.75), &
                                                 Spacings(4), N4, NNeighbors,   &
                                                 neighborList, RijList)
     ! Call model compute
     call kim_api_model_compute_f(pkim, ier)
     if (ier.le.0) then
        call report_error(__LINE__, "kim_api_model_compute_f", ier)
        stop
     endif
     Energies(4) = energy
     if (verbose) &
        print *, "Energy/atom = ", Energies(4), "; Spacing = ", Spacings(4)

     ! determine the new interval
     if (Energies(4) .lt. Energies(2)) then
        ! We want the right-hand interval
        Spacings(1) = Spacings(2); Energies(1) = Energies(2)
        Spacings(2) = Spacings(4); Energies(2) = Energies(4)
     else
        ! We want the left-hand interval
        Spacings(3) = Spacings(1); Energies(3) = Energies(1)
        Spacings(1) = Spacings(4); Energies(1) = Energies(4)
     endif
  enddo

  ! pull out results and return
  !
  RetSpacing = Spacings(2)
  RetEnergy  = Energies(2)

  return

end subroutine NEIGH_RVEC_compute_equilibrium_spacing

!-------------------------------------------------------------------------------
!
! setup_KIM_API_object : Create KIM API object, 
!                        allocate memory and set known values.
!
!-------------------------------------------------------------------------------
subroutine setup_KIM_API_object(pkim, testname, modelname, N, specname)
  use KIMservice
  implicit none

  !-- Transferred variables
  integer(kind=kim_intptr), intent(in)  :: pkim
  character(len=80),        intent(in)  :: testname
  character(len=80),        intent(in)  :: modelname
  integer(kind=kim_intptr), intent(in)  :: N
  character(len=2),         intent(in)  :: specname

  !-- Local variables
  integer, parameter :: ATypes = 1  ! hard-wired to one atomic type
  integer ier, N4
  integer(kind=8) numberOfAtoms; pointer(pnAtoms,numberOfAtoms)
  integer numberAtomTypes;       pointer(pnAtomTypes,numberAtomTypes)
  integer atomTypesdum(1);       pointer(patomTypesdum,atomTypesdum)
  integer, pointer :: atomTypes(:)

  ! Initialize KIM API object
  !
  ier = kim_api_init_f(pkim, testname, modelname)
  if (ier.le.0) then
     call report_error(__LINE__, "kim_api_init_f", ier)
     stop
  endif
  call kim_api_allocate_f(pkim, N, ATypes, ier)
  if (ier.le.0) then
     call report_error(__LINE__, "kim_api_allocate_f", ier)
     stop
  endif

  ! call model's init routine
  !
  ier = kim_api_model_init_f(pkim)
  if (ier.le.0) then
     call report_error(__LINE__, "kim_api_model_init_f", ier)
     stop
  endif

  ! Unpack data from KIM object whose values need to be set
  !
  pnAtoms = kim_api_get_data_f(pkim, "numberOfAtoms", ier);
  if (ier.le.0) then
     call report_error(__LINE__, "kim_api_get_data_f", ier)
     stop
  endif

  pnAtomTypes = kim_api_get_data_f(pkim, "numberAtomTypes", ier)
  if (ier.le.0) then
     call report_error(__LINE__, "kim_api_get_data_f", ier)
     stop
  endif

  patomTypesdum = kim_api_get_data_f(pkim, "atomTypes", ier)
  if (ier.le.0) then
     call report_error(__LINE__, "kim_api_get_data_f", ier)
     stop
  endif
  N4 = N
  call toIntegerArrayWithDescriptor1d(atomTypesdum, atomTypes, N4)

  ! Set values
  !
  numberOfAtoms   = N
  numberAtomTypes = ATypes
  atomTypes(:)    = kim_api_get_atypecode_f(pkim, specname, ier)
  if (ier.le.0) then
     call report_error(__LINE__, "kim_api_get_atypecode_f", ier)
     stop
  endif

  return

end subroutine setup_KIM_API_object

!-------------------------------------------------------------------------------
!
! setup_neighborlist_Rij_KIM_access :
!
!    Store necessary pointers in KIM API object to access the neighbor list
!    data and methods.
!
!-------------------------------------------------------------------------------
subroutine setup_neighborlist_Rij_KIM_access(pkim, NLRvecLocs)
  use KIMservice
  implicit none

  !-- Transferred variables
  integer(kind=kim_intptr), intent(in)    :: pkim
  integer,                  intent(inout) :: NLRvecLocs(3)

  !-- Local variables
  integer(kind=kim_intptr), parameter :: SizeOne = 1
  integer,                  external  :: get_neigh_Rij
  integer ier

  ! store pointers to neighbor list object and access function
  !
  
  ier = kim_api_set_data_f(pkim, "neighObject", SizeOne, loc(NLRvecLocs))
  if (ier.le.0) then
     call report_error(__LINE__, "kim_api_set_data_f", ier)
     stop
  endif

  ier = kim_api_set_data_f(pkim, "get_full_neigh", SizeOne, loc(get_neigh_Rij))
  if (ier.le.0) then
     call report_error(__LINE__, "kim_api_set_data_f", ier)
     stop
  endif

  return

end subroutine setup_neighborlist_Rij_KIM_access

!-------------------------------------------------------------------------------
!
! free_KIM_API_object : Deallocate storage and destroy KIM API object
!
!-------------------------------------------------------------------------------
subroutine free_KIM_API_object(pkim)
  use KIMservice
  implicit none

  !-- Transferred variables
  integer(kind=kim_intptr), intent(in)  :: pkim

  !-- Local variables
  integer ier

  ! call the model destroy function
  !
  call kim_api_model_destroy_f(pkim, ier)
  if (ier.le.0) then
     call report_error(__LINE__, "kim_api_model_destroy_f", ier)
     stop
  endif

  ! free all KIM API object storage
  !
  call kim_api_free_f(pkim, ier)
  if (ier.le.0) then
     call report_error(__LINE__, "kim_api_free_f", ier)
     stop
  endif

  return

end subroutine free_KIM_API_object

!-------------------------------------------------------------------------------
!
! NEIGH_RVEC_F_periodic_FCC_neighborlist 
!
!-------------------------------------------------------------------------------
subroutine NEIGH_RVEC_F_periodic_FCC_neighborlist(CellsPerHalfSide, cutoff, FCCspacing, N, NN, neighborList, RijList)
  use KIMservice
  implicit none
  
  !-- Transferred variables
  integer,                               intent(in)  :: CellsPerHalfSide
  double precision,                      intent(in)  :: cutoff
  double precision,                      intent(in)  :: FCCspacing
  integer,                               intent(in)  :: N
  integer,                               intent(in)  :: NN
  integer, dimension(NN+1,N),            intent(out) :: neighborList
  double precision, dimension(3,NN+1,N), intent(out) :: RijList
  
  !-- Local variables
  double precision dx(3)
  double precision cutoff2
  double precision FCCshifts(3,4)
  double precision latVec(3)
  integer a, i, j, k, m

  if (N.ne.1) then ! check assumption that N==1
     print *,"* ERROR: NEIGH_RVEC_F_periodic_FCC_neighborlist called with N.ne.1"
     stop
  endif

  cutoff2 = cutoff**2

  ! Cubic FCC cell positions ----------------------------------------------------------------------
  FCCshifts(1,1) = 0.d0;           FCCshifts(2,1) = 0.d0;           FCCshifts(3,1) = 0.d0
  FCCshifts(1,2) = 0.5*FCCspacing; FCCshifts(2,2) = 0.5*FCCspacing; FCCshifts(3,2) = 0.d0
  FCCshifts(1,3) = 0.5*FCCspacing; FCCshifts(2,3) = 0.d0;           FCCshifts(3,3) = 0.5*FCCspacing
  FCCshifts(1,4) = 0.d0;           FCCshifts(2,4) = 0.5*FCCspacing; FCCshifts(3,4) = 0.5*FCCspacing

  a = 1
  do i=-CellsPerHalfSide,CellsPerHalfSide
     latVec(1) = i*FCCspacing
     do j=-CellsPerHalfSide,CellsPerHalfSide
        latVec(2) = j*FCCspacing
        do k=-CellsPerHalfSide,CellsPerHalfSide
           latVec(3) = k*FCCspacing
           do m=1,4
              dx = latVec + FCCshifts(:,m)
              if (dot_product(dx,dx).lt.cutoff2) then
                 if (.not.( (i.eq.0) .and. (j.eq.0) .and. (k.eq.0) .and. (m.eq.1) )) then
                    ! we have a neighbor
                    a = a+1
                    neighborList(a,1) = 1
                    RijList(:,a-1,1) = dx
                 endif
              endif
           enddo
        enddo
     enddo
  enddo
  ! atom 1 has a-1 neighbors
  neighborList(1,1) = a-1

  return

end subroutine NEIGH_RVEC_F_periodic_FCC_neighborlist

!-------------------------------------------------------------------------------
!
! get_neigh_Rij neighbor list access function 
!
! This function implements Locator and Iterator mode
!
!-------------------------------------------------------------------------------
integer function get_neigh_Rij(pkim,mode,request,atom,numnei,pnei1atom,pRij)
  use KIMservice
  implicit none
  
  !-- Transferred variables
  integer(kind=kim_intptr), intent(in)  :: pkim
  integer,                  intent(in)  :: mode
  integer,                  intent(in)  :: request
  integer,                  intent(out) :: atom
  integer,                  intent(out) :: numnei
  integer nei1atom(1); pointer(pnei1atom, nei1atom) ! actual cray pointer associated with nei1atom
  real*8  Rij(3,1);    pointer(pRij, Rij)
  
  !-- Local variables
  integer, save :: iterVal = 0
  integer atomToReturn
  integer NLRvecLocs(1);       pointer(pNLRvecLocs,NLRvecLocs)
  integer neighborListdum(1);  pointer(pneighborListdum, neighborListdum)
  integer, pointer :: neighborList(:,:)
  double precision RijList(1); pointer(pRijList,RijList)
  integer   ier
  integer*8 numberOfAtoms; pointer(pnAtoms, numberOfAtoms)
  integer   N
  integer   NNeighbors

  ! unpack neighbor list object
  pNLRVecLocs = kim_api_get_data_f(pkim, "neighObject", ier)
  if (ier.le.0) then
     call report_error(__LINE__, "kim_api_get_data_f", ier)
     stop
  endif
  pneighborListdum = NLRvecLocs(1)
  pRijList         = NLRvecLocs(2)
  NNeighbors       = NLRvecLocs(3)
  
  pnAtoms = kim_api_get_data_f(pkim, "numberOfAtoms", ier)
  if (ier.le.0) then
     call report_error(__LINE__, "kim_api_get_data_f", ier)
     stop
  endif
  N = numberOfAtoms
  call toIntegerArrayWithDescriptor2d(neighborListdum, neighborlist, NNeighbors, N)

  ! check mode and request
  if (mode.eq.0) then ! iterator mode
     if (request.eq.0) then ! reset iterator
        iterVal = 0
        get_neigh_Rij = 2
        return
     elseif (request.eq.1) then ! increment iterator
        iterVal = iterVal + 1
        if (iterVal.gt.N) then
           get_neigh_Rij = 0
           return
        else
           atomToReturn = iterVal
        endif
     else
        call report_error(__LINE__, "Invalid request in get_neigh_Rij", -6)
        get_neigh_Rij = -6 ! invalid request value
        return
     endif
  elseif (mode.eq.1) then ! locator mode
     if ( (request.gt.N) .or. (request.lt.1)) then
        call report_error(__LINE__, "Invalid request in get_neigh_Rij", -1)
        get_neigh_Rij = -1
        return
     else
        atomToReturn = request
     endif
  else ! not iterator or locator mode
     call report_error(__LINE__, "Invalid mode in get_neigh_Rij", -2)
     get_neigh_Rij = -2
     return
  endif

  ! set the returned atom
  atom = atomToReturn
  
  ! set the returned number of neighbors for the returned atom
  numnei = neighborList(1,atom)
  
  ! set the location for the returned neighbor list
  pnei1atom = loc(neighborList(2,atom))
  
  ! set pointer to Rij to appropriate value
  pRij = loc(RijList(3*(NNeighbors)*(atom-1) + 1))
  
  get_neigh_Rij = 1
  return
end function get_neigh_Rij

!-------------------------------------------------------------------------------
!
! report_error subroutine
!
!-------------------------------------------------------------------------------
subroutine report_error(line, str, status)
  implicit none
  
  !-- Transferred variables
  integer,          intent(in) :: line
  character(len=*), intent(in) :: str
  integer,          intent(in) :: status
  
  !-- Local variables
  character(len=10000), parameter :: file = __FILE__
  
  !-- print the error message
  print *,'* ERROR at line', line, 'in ',trim(file), ': ', str,'. kimerror =', status

  return
  
end subroutine report_error
