!
! CDDL HEADER START
!
! The contents of this file are subject to the terms of the Common Development
! and Distribution License Version 1.0 (the "License").
!
! You can obtain a copy of the license at
! http://www.opensource.org/licenses/CDDL-1.0.  See the License for the
! specific language governing permissions and limitations under the License.
!
! When distributing Covered Code, include this CDDL HEADER in each file and
! include the License file in a prominent location with the name LICENSE.CDDL.
! If applicable, add the following below this CDDL HEADER, with the fields
! enclosed by brackets "[]" replaced with your own identifying information:
!
! Portions Copyright (c) [yyyy] [name of copyright owner]. All rights reserved.
!
! CDDL HEADER END
!

!
! Copyright (c) 2012, Regents of the University of Minnesota.  All rights reserved.
!
! Contributors:
!    Ryan S. Elliott
!    Ellad B. Tadmor
!    Valeriu Smirichinski
!


!*******************************************************************************
!**
!**  MODULE ex_model_Ar_P_MLJ_NEIGH_PURE_H_F
!**
!**  Lennard-Jones pair potential model for argon
!**  (modified by adding a quadratic function to have a smooth cutoff)
!**
!**  Release: This file is part of the openkim-api-v1.1.0 package.
!**
!*******************************************************************************

#include "KIM_API_status.h"
#define THIS_FILE_NAME __FILE__

module ex_model_Ar_P_MLJ_NEIGH_PURE_H_F
  use KIM_API
  implicit none

  save
  private
  public Compute_Energy_Forces
  public ReInit
  public Destroy

contains

!-------------------------------------------------------------------------------
!
! Compute energy and forces on atoms from the positions.
!
!-------------------------------------------------------------------------------
  integer function Compute_Energy_Forces(pkim)
    implicit none

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

    !-- Local variables
    integer, parameter :: DIM=3
    double precision r,Rsqij,phi,dphi,d2phi,dEidr
    integer idum
    integer i,j,jj,numnei,atom,atom_ret
    character*64 NBC_Method; pointer(pNBC_Method,NBC_Method)
    integer HalfOrFull                        ! 1 - half, 2 - full
    double precision, dimension(DIM) :: Rij
    
    !-- KIM variables
    integer numberOfParticles;  pointer(pnAtoms,numberOfParticles)
    integer nparticleTypes;     pointer(pnparticleTypes,nparticleTypes)
    integer particleTypes(1);   pointer(pparticleTypes,particleTypes)
    real*8 model_cutoff;        pointer(pcutoff,model_cutoff)
    real*8 model_epsilon;       pointer(pepsilon,model_epsilon)
    real*8 model_sigma;         pointer(psigma,model_sigma)
    real*8 model_cutnorm;       pointer(pcutnorm,model_cutnorm)
    real*8 model_A;             pointer(pA,model_A)
    real*8 model_B;             pointer(pB,model_B)
    real*8 model_C;             pointer(pC,model_C)
    real*8 model_sigmasq;       pointer(psigmasq,model_sigmasq)
    real*8 model_cutsq;         pointer(pcutsq,model_cutsq)
    real*8 energy;              pointer(penergy,energy)
    real*8 coordum(DIM,1);      pointer(pcoor,coordum)
    real*8 forcedum(DIM,1);     pointer(pforce,forcedum)
    real*8 enepotdum(1);        pointer(penepot,enepotdum)
    real*8 virialdum(1);        pointer(pvirial,virialdum)
    real*8, pointer :: coor(:,:),force(:,:),ene_pot(:),virial_global(:)
    integer comp_energy, comp_force, comp_enepot, comp_virial
    integer numContrib;      pointer(pnumContrib,numContrib)
    integer nei1atom(1);     pointer(pnei1atom,nei1atom)
    real*8 Rij_dummy(3,1);   pointer(pRij_dummy,Rij_dummy)
    
    ! Check to see if we have been asked to compute the energy, forces, energyperatom,
    ! and virial
    !
    call kim_api_getm_compute_f(pkim, Compute_Energy_Forces, &
         "energy",         comp_energy, 1, &
         "forces",         comp_force,  1, &
         "particleEnergy", comp_enepot, 1, &
         "virial",         comp_virial, 1)
    if (Compute_Energy_Forces.lt.KIM_STATUS_OK) then
       idum = kim_api_report_error_f(__LINE__, THIS_FILE_NAME, &
                                     "kim_api_getm_compute_f", Compute_Energy_Forces)
       return
    endif

    ! Unpack data from KIM object
    !
    call kim_api_getm_data_f(pkim, Compute_Energy_Forces,     &
         "numberOfParticles",   pnAtoms,         1,           &
         "numberParticleTypes", pnparticleTypes, 1,           &
         "particleTypes",       pparticleTypes,  1,           &
         "cutoff",              pcutoff,         1,           &
         "coordinates",         pcoor,           1,           &
         "energy",              penergy,         comp_energy, &
         "forces",              pforce,          comp_force,  &
         "particleEnergy",      penepot,         comp_enepot, &
         "virial",              pvirial,         comp_virial)
    if (Compute_Energy_Forces.lt.KIM_STATUS_OK) then
       idum = kim_api_report_error_f(__LINE__, THIS_FILE_NAME, &
                                     "kim_api_getm_data_f", Compute_Energy_Forces)
       return
    endif

    call kim_api_getm_data_f(pkim, Compute_Energy_Forces, &
         "PARAM_FREE_epsilon",  pepsilon,      1,         &
         "PARAM_FREE_sigma",    psigma,        1,         &
         "PARAM_FIXED_cutnorm", pcutnorm,      1,         &
         "PARAM_FIXED_A",       pA,            1,         &
         "PARAM_FIXED_B",       pB,            1,         &
         "PARAM_FIXED_C",       pC,            1,         &
         "PARAM_FIXED_sigmasq", psigmasq,      1,         &
         "PARAM_FIXED_cutsq",   pcutsq,        1)
    if (Compute_Energy_Forces.lt.KIM_STATUS_OK) then
       idum = kim_api_report_error_f(__LINE__, THIS_FILE_NAME, &
                                     "kim_api_getm_data_f", Compute_Energy_Forces)
       return
    endif

    ! Cast to F90 arrays
    !
    call KIM_to_F90_real_array_2d(coordum,coor,DIM,numberOfParticles)
    if (comp_force.eq.1) &
       call KIM_to_F90_real_array_2d(forcedum,force,DIM,numberOfParticles)
    if (comp_enepot.eq.1) &
       call KIM_to_F90_real_array_1d(enepotdum,ene_pot,numberOfParticles)
    if (comp_virial.eq.1) &
       call KIM_to_F90_real_array_1d(virialdum,virial_global,6)


    ! Check to be sure that the atom types are correct by comparing
    ! the provided species codes to the value given here (which should
    ! be the same as that given in the .kim file).
    !
    Compute_Energy_Forces = KIM_STATUS_FAIL ! assume an error
    do i = 1,numberOfParticles
       if (.not. (particleTypes(i) .eq. 1)) then
          idum = kim_api_report_error_f(__LINE__, THIS_FILE_NAME, &
                                        "Wrong Atom Type", Compute_Energy_Forces)
          return
       endif
    enddo
    Compute_Energy_Forces = KIM_STATUS_OK ! everything is ok


    ! Initialize potential energies, forces, virial term
    !
    if (comp_enepot.eq.1) ene_pot(1:numberOfParticles) = 0.d0
    if (comp_energy.eq.1) energy = 0.d0
    if (comp_force.eq.1)  force(1:3,1:numberOfParticles) = 0.d0
    if (comp_virial.eq.1) virial_global = 0.d0
    
    
    ! determine whether half or full neighbor lists are being used
    pNBC_Method = kim_api_get_nbc_method_f(pkim, Compute_Energy_Forces)
    if (Compute_Energy_Forces.lt.KIM_STATUS_OK) then
       idum = kim_api_report_error_f(__LINE__, THIS_FILE_NAME,   &
                                     "kim_api_get_nbc_method_f", &
                                     Compute_Energy_Forces)
       return
    endif
    if (index(NBC_Method,"NEIGH_PURE_H").eq.1) then
       HalfOrFull = 1
       ! get numberContributingParticles
       pnumContrib = kim_api_get_data_f(pkim,"numberContributingParticles",Compute_Energy_Forces)
       if (Compute_Energy_Forces.lt.KIM_STATUS_OK) then
          idum = kim_api_report_error_f(__LINE__, THIS_FILE_NAME, &
                                        "kim_api_get_data", Compute_Energy_Forces)
          return
       endif
    elseif (index(NBC_Method,"NEIGH_PURE_F").eq.1) then
       HalfOrFull = 2
    else
       Compute_Energy_Forces = KIM_STATUS_FAIL
       idum = kim_api_report_error_f(__LINE__, THIS_FILE_NAME, &
                                     "Unsupported NBC type", Compute_Energy_Forces)
       return
    endif
    call free(pNBC_Method) ! don't forget to release the memory...

    !  Compute energy and forces
    !
    do i = 1,numberOfParticles

       ! Get neighbors for atom i
       !
       atom = i ! request neighbors for atom i

       Compute_Energy_Forces = kim_api_get_neigh_f(pkim,1,atom,atom_ret,numnei,pnei1atom,pRij_dummy)
       if (Compute_Energy_Forces.lt.KIM_STATUS_OK) then
          idum = kim_api_report_error_f(__LINE__, THIS_FILE_NAME, &
                                        "kim_api_get_neigh", Compute_Energy_Forces)
          return
       endif

       ! Loop over the neighbors of atom i
       !
       do jj = 1, numnei
          j = nei1atom(jj)
          Rij(:) = coor(:,j) - coor(:,i)                ! distance vector between i j
          Rsqij = dot_product(Rij,Rij)                  ! compute square distance
          if ( Rsqij < model_cutsq ) then               ! particles are interacting?
             r = sqrt(Rsqij)                            ! compute distance
             call pair(model_epsilon,model_sigma,model_A,model_B, model_C, &
                  r,phi,dphi,d2phi)                     ! compute pair potential
             if ((HalfOrFull.eq.1) .and. &
                 (j .le. numContrib)) then              ! HALF mode
                dEidr = dphi                            !      double contribution
             else                                       ! FULL mode
                dEidr = 0.5d0*dphi                      !      regular contribution
             endif
             if (comp_enepot.eq.1) then                 !
                ene_pot(i) = ene_pot(i) + 0.5d0*phi     ! accumulate energy
                if ((HalfOrFull.eq.1) .and. &
                     (j .le. numContrib)) then
                   ene_pot(j) = ene_pot(j) + 0.5d0*phi  ! (i and j share it)
                endif                                   !
             endif                                      !
             if (comp_energy.eq.1) then                 !
               if ((HalfOrFull.eq.1) .and. &
                   (j .le. numContrib)) then            ! HALF mode
                   energy = energy + phi                ! half neigh case
                else                                    !
                   energy = energy + 0.5d0*phi          ! full neigh case
                endif                                   !
             endif
             if (comp_virial.eq.1) then                 ! accumul. virial
                virial_global(1) = virial_global(1) + Rij(1)*Rij(1)*dEidr/r
                virial_global(2) = virial_global(2) + Rij(2)*Rij(2)*dEidr/r
                virial_global(3) = virial_global(3) + Rij(3)*Rij(3)*dEidr/r
                virial_global(4) = virial_global(4) + Rij(2)*Rij(3)*dEidr/r
                virial_global(5) = virial_global(5) + Rij(1)*Rij(3)*dEidr/r
                virial_global(6) = virial_global(6) + Rij(1)*Rij(2)*dEidr/r
             endif                                      !
             if (comp_force.eq.1) then                  !
                force(:,i) = force(:,i) + dEidr*Rij/r   ! accumulate forces on i
                force(:,j) = force(:,j) - dEidr*Rij/r   ! accumulate forces on j
             endif
          endif
       enddo
    enddo

  end function Compute_Energy_Forces

!-------------------------------------------------------------------------------
!
! Pair potential: Lennard-Jones with smooth cutoff imposed by Ar^2 + Br + C
!
!-------------------------------------------------------------------------------
  subroutine pair(epsilon,sigma,A,B,C,r,phi,dphi,d2phi)
    implicit none

    !-- Transferred variables
    double precision, intent(in)  :: epsilon, sigma, A, B, C
    double precision, intent(in)  :: r
    double precision, intent(out) :: phi, dphi, d2phi

    !-- Local variables
    double precision rsq,sor,sor6,sor12

    rsq  = r*r             !  r^2
    sor  = sigma/r         !  (sig/r)
    sor6 = sor*sor*sor     !
    sor6 = sor6*sor6       !  (sig/r)^6
    sor12= sor6*sor6       !  (sig/r)^12

    phi   =  4.d0*epsilon*(sor12-sor6) + A*rsq + B*r + C
    dphi  = 24.d0*epsilon*(-2.d0*sor12+sor6)/r  + 2.d0*A*r + B
    d2phi = 24.d0*epsilon*(26.d0*sor12-7.d0*sor6)/rsq + 2.d0*A

  end subroutine pair

!-------------------------------------------------------------------------------
!
! Model reinitialization routine
!
!-------------------------------------------------------------------------------
  integer function ReInit(pkim)
    implicit none

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

    !-- Local variables
    real*8 model_cutoff;  pointer(pcutoff,model_cutoff)
    real*8 model_epsilon; pointer(pepsilon,model_epsilon)
    real*8 model_sigma;   pointer(psigma,model_sigma)
    real*8 model_Pcutoff; pointer(pparamcut,model_Pcutoff)
    real*8 model_cutnorm; pointer(pcutnorm,model_cutnorm)
    real*8 model_A;       pointer(pA,model_A)
    real*8 model_B;       pointer(pB,model_B)
    real*8 model_C;       pointer(pC,model_C)
    real*8 model_sigmasq; pointer(psigmasq,model_sigmasq)
    real*8 model_cutsq;   pointer(pcutsq,model_cutsq)
    integer idum

    ! Get (changed) parameters from KIM object ---------------------------------

    ! get stuff from KIM object
    call kim_api_getm_data_f(pkim, ReInit, &
         "PARAM_FREE_sigma",   psigma,    1, &
         "PARAM_FREE_epsilon", pepsilon,  1, &
         "PARAM_FREE_cutoff",  pparamcut, 1)
    if (ReInit.lt.KIM_STATUS_OK) then
       idum = kim_api_report_error_f(__LINE__, THIS_FILE_NAME, &
                                     "kim_api_getm_data_f", ReInit)
       return
    endif

    ! Set new values in KIM object ---------------------------------------------

    ! Set stuff in KIM object
    call kim_api_getm_data_f(pkim, ReInit, &
         "cutoff",              pcutoff,  1, &
         "PARAM_FIXED_cutnorm", pcutnorm, 1, &
         "PARAM_FIXED_A",       pA,       1, &
         "PARAM_FIXED_B",       pB,       1, &
         "PARAM_FIXED_C",       pC,       1, &
         "PARAM_FIXED_sigmasq", psigmasq, 1, &
         "PARAM_FIXED_cutsq",   pcutsq,   1)
    if (ReInit.lt.KIM_STATUS_OK) then
       idum = kim_api_report_error_f(__LINE__, THIS_FILE_NAME, &
                                     "kim_api_getm_data_f", ReInit)
       return
    endif

    model_cutoff = model_Pcutoff
    model_cutnorm = model_cutoff/model_sigma
    model_A = 12.d0*model_epsilon*(-26.d0 + 7.d0*model_cutnorm**6)/ &
         (model_cutnorm**14*model_sigma**2)
    model_B = 96.d0*model_epsilon*(7.d0-2.d0*model_cutnorm**6)/     &
         (model_cutnorm**13*model_sigma)
    model_C = 28.d0*model_epsilon*(-13.d0+4.d0*model_cutnorm**6)/   &
         (model_cutnorm**12)
    model_sigmasq = model_sigma**2
    model_cutsq = model_cutoff**2

    ReInit = KIM_STATUS_OK
    return

  end function ReInit

!-------------------------------------------------------------------------------
!
! Model destroy routine
!
!-------------------------------------------------------------------------------
  integer function Destroy(pkim)
    use KIM_API
    implicit none

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

    !-- Local variables
    real*8 model_epsilon; pointer(pepsilon,model_epsilon)
    real*8 model_sigma;   pointer(psigma,model_sigma)
    real*8 model_Pcutoff; pointer(pparamcut,model_Pcutoff)
    real*8 model_cutnorm; pointer(pcutnorm,model_cutnorm)
    real*8 model_A;       pointer(pA,model_A)
    real*8 model_B;       pointer(pB,model_B)
    real*8 model_C;       pointer(pC,model_C)
    real*8 model_sigmasq; pointer(psigmasq,model_sigmasq)
    real*8 model_cutsq;   pointer(pcutsq,model_cutsq)
    integer idum


    call kim_api_getm_data_f(pkim, Destroy, &
         "PARAM_FREE_sigma",    psigma,    1, &
         "PARAM_FREE_epsilon",  pepsilon,  1, &
         "PARAM_FREE_cutoff",   pparamcut, 1, &
         "PARAM_FIXED_cutnorm", pcutnorm,  1, &
         "PARAM_FIXED_A",       pA,        1, &
         "PARAM_FIXED_B",       pB,        1, &
         "PARAM_FIXED_C",       pC,        1, &
         "PARAM_FIXED_sigmasq", psigmasq,  1, &
         "PARAM_FIXED_cutsq",   pcutsq,    1)
    if (Destroy.lt.KIM_STATUS_OK) then
       idum = kim_api_report_error_f(__LINE__, THIS_FILE_NAME, &
                                     "kim_api_getm_data_f", Destroy)
       return
    endif
    call free(psigma)
    call free(pepsilon)
    call free(pparamcut)
    call free(pcutnorm)
    call free(pA)
    call free(pB)
    call free(pC)
    call free(psigmasq)
    call free(pcutsq)

    Destroy = KIM_STATUS_OK
    return

  end function Destroy

end module ex_model_Ar_P_MLJ_NEIGH_PURE_H_F


!-------------------------------------------------------------------------------
!
! Model initialization routine (REQUIRED)
!
!-------------------------------------------------------------------------------
integer function ex_model_Ar_P_MLJ_NEIGH_PURE_H_F_init(pkim)
  use ex_model_Ar_P_MLJ_NEIGH_PURE_H_F
  use KIM_API
  implicit none

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

  !-- Local variables
  integer(kind=kim_intptr), parameter :: one=1
  real*8 model_cutoff;  pointer(pcutoff,model_cutoff)
  real*8 model_epsilon; pointer(pepsilon,model_epsilon)
  real*8 model_sigma;   pointer(psigma,model_sigma)
  real*8 model_Pcutoff; pointer(pparamcut,model_Pcutoff)
  real*8 model_cutnorm; pointer(pcutnorm,model_cutnorm)
  real*8 model_A;       pointer(pA,model_A)
  real*8 model_B;       pointer(pB,model_B)
  real*8 model_C;       pointer(pC,model_C)
  real*8 model_sigmasq; pointer(psigmasq,model_sigmasq)
  real*8 model_cutsq;   pointer(pcutsq,model_cutsq)
  integer ier, idum

  ! store pointers in KIM object
  call kim_api_setm_data_f(pkim, ier, &
       "compute", one, loc(Compute_Energy_Forces), 1, &
       "reinit",  one, loc(ReInit),                1, &
       "destroy", one, loc(Destroy),               1)
  if (ier.lt.KIM_STATUS_OK) then
     idum = kim_api_report_error_f(__LINE__, THIS_FILE_NAME, &
                                   "kim_api_setm_data_f", ier)
     goto 42
  endif

  ! store model cutoff in KIM object
  pcutoff =  kim_api_get_data_f(pkim,"cutoff",ier)
  if (ier.lt.KIM_STATUS_OK) then
     idum = kim_api_report_error_f(__LINE__, THIS_FILE_NAME, &
                                   "kim_api_get_data", ier)
     goto 42
  endif
  model_cutoff = 8.15d0 ! cutoff distance in angstroms

  ! Allocate memory for stuff and store values
  psigma = malloc(one*8) ! 8 is the size of a real*8
  model_sigma = 3.40d0 ! LJ Argon sigma in angstroms

  pepsilon = malloc(one*8) ! 8 is the size of a real*8
  model_epsilon = 0.0104d0 ! LJ Argon epsilon in eV

  pparamcut = malloc(one*8) ! 8 is the size of a real*8
  model_Pcutoff = model_cutoff

  pcutnorm = malloc(one*8) ! 8 is the size of a real*8
  model_cutnorm = model_cutoff/model_sigma

  pA = malloc(one*8) ! 8 is the size of a real*8
  model_A = 12.d0*model_epsilon*(-26.d0 + 7.d0*model_cutnorm**6)/ &
       (model_cutnorm**14*model_sigma**2)

  pB = malloc(one*8) ! 8 is the size of a real*8
  model_B = 96.d0*model_epsilon*(7.d0-2.d0*model_cutnorm**6)/     &
       (model_cutnorm**13*model_sigma)

  pC = malloc(one*8) ! 8 is the size of a real*8
  model_C = 28.d0*model_epsilon*(-13.d0+4.d0*model_cutnorm**6)/   &
       (model_cutnorm**12)

  psigmasq = malloc(one*8) ! 8 is the size of a real*8
  model_sigmasq = model_sigma**2

  pcutsq = malloc(one*8) ! 8 is the size of a real*8
  model_cutsq = model_cutoff**2


  call kim_api_setm_data_f(pkim, ier, &
       "PARAM_FREE_sigma",    one, psigma,    1, &
       "PARAM_FREE_epsilon",  one, pepsilon,  1, &
       "PARAM_FREE_cutoff",   one, pparamcut, 1, &
       "PARAM_FIXED_cutnorm", one, pcutnorm,  1, &
       "PARAM_FIXED_A",       one, pA,        1, &
       "PARAM_FIXED_B",       one, pB,        1, &
       "PARAM_FIXED_C",       one, pC,        1, &
       "PARAM_FIXED_sigmasq", one, psigmasq,  1, &
       "PARAM_FIXED_cutsq",   one, pcutsq,    1)
  if (ier.lt.KIM_STATUS_OK) then
     idum = kim_api_report_error_f(__LINE__, THIS_FILE_NAME, &
                                   "kim_api_setm_data_f", ier)
     goto 42
  endif

  ier = KIM_STATUS_OK
42 continue
  ex_model_Ar_P_MLJ_NEIGH_PURE_H_F_init = ier
  return

end function ex_model_Ar_P_MLJ_NEIGH_PURE_H_F_init
