MODULE CRP_C4v_MoleculeSurface
  USE CRP_Constants
  USE CRP_GasPhase
  USE CRP_General
  USE CRP_C4v_AtomSurface
  USE Spline
  USE UnitConversion

  PRIVATE
  PUBLIC :: Initialize_CRP_C4v_MoleculeSurface_Module, &
            Initialize_CRP_C4v_MoleculeSurface_PES, &
            Calculate_CRP_C4v_MoleculeSurface_PES

  INTEGER :: CRP_C4v_MoleculeSurface_Module_SetUp = 0

  INTERFACE Calculate_CRP_C4v_MoleculeSurface_PES
    MODULE PROCEDURE Calculate_CRP_C4v_MoleculeSurface_PES_Scalar, &
                     Calculate_CRP_C4v_MoleculeSurface_PES_Array
  END INTERFACE

CONTAINS

  SUBROUTINE Initialize_CRP_C4v_MoleculeSurface_Module()
    IMPLICIT NONE

    IF ( CRP_C4v_MoleculeSurface_Module_SetUp .LT. 1 ) THEN
      CRP_C4v_MoleculeSurface_Module_SetUp = 1
    END IF
  END SUBROUTINE

  SUBROUTINE Initialize_CRP_C4v_MoleculeSurface_PES( PES )
    IMPLICIT NONE

    TYPE (CRP_MoleculeSurface_PES) :: PES

    PES%ccDef = 0.5

    CALL Read_PES_Info( PES )
    CALL Read_MoleculeSurface_Data( PES )
  END SUBROUTINE

  ! Read_PES_Info
  !   Read information about the PES from disk.
  SUBROUTINE Read_PES_Info( PES )
    IMPLICIT NONE

    INTEGER                          :: i, N
    TYPE ( CRP_MoleculeSurface_PES ) :: PES

    OPEN(87, FILE=TRIM(ADJUSTL(PES%DataSet)) // "/CRPData.6D", STATUS="OLD")
    READ(87, *) N, PES%CutsInterpolation
    PES%NumCuts = N
    ALLOCATE( PES%Cuts(N) )
    PES%Alloced = .TRUE.
    DO i = 1, N
      READ(87, *) PES%Cuts(i)%X, PES%Cuts(i)%Y, PES%Cuts(i)%Theta, PES%Cuts(i)%Phi, PES%Cuts(i)%FileName
    END DO
    CLOSE(87)
  END SUBROUTINE

  SUBROUTINE Calculate_CRP_C4v_MoleculeSurface_PES_Scalar( PES, Xa, Ya, Za, Xb, Yb, Zb, V, Fxa, Fya, Fza, Fxb, Fyb, Fzb, OutUnits )
    IMPLICIT NONE

    TYPE ( CRP_MoleculeSurface_PES ) :: PES
    REAL                             :: Xa, Ya, Za, Xb, Yb, Zb, V, Fxa, Fya, Fza, Fxb, Fyb, Fzb
    TYPE ( Units )                   :: OutUnits
    LOGICAL                          :: switch

    Za = Convert_Length_Units( Za, OutUnits, InternalUnits )
    Xa = Convert_Length_Units( Xa, OutUnits, InternalUnits )
    Ya = Convert_Length_Units( Ya, OutUnits, InternalUnits )
    Zb = Convert_Length_Units( Zb, OutUnits, InternalUnits )
    Xb = Convert_Length_Units( Xb, OutUnits, InternalUnits )
    Yb = Convert_Length_Units( Yb, OutUnits, InternalUnits )
    CALL POT6D( (/ Za, Xa, Ya, Zb, Xb, Yb /), V, Fxa, Fya, Fza, Fxb, Fyb, Fzb, switch, PES )
    V = Convert_Energy_Units( V, InternalUnits, OutUnits )
    Fxa = Convert_Force_Units( Fxa, InternalUnits, OutUnits )
    Fya = Convert_Force_Units( Fya, InternalUnits, OutUnits )
    Fza = Convert_Force_Units( Fza, InternalUnits, OutUnits )
    Fxb = Convert_Force_Units( Fxb, InternalUnits, OutUnits )
    Fyb = Convert_Force_Units( Fyb, InternalUnits, OutUnits )
    Fzb = Convert_Force_Units( Fzb, InternalUnits, OutUnits )
  END SUBROUTINE

  SUBROUTINE Calculate_CRP_C4v_MoleculeSurface_PES_Array( PES, R, V, F, OutUnits )
    IMPLICIT NONE

    TYPE ( CRP_MoleculeSurface_PES ) :: PES
    REAL                             :: R(6), MyR(6), V, F(6)
    LOGICAL                          :: switch
    TYPE ( Units )                   :: OutUnits
    INTEGER                          :: i

    DO i = 1, 6
      MyR(i) = Convert_Length_Units( R(i), OutUnits, InternalUnits )
    END DO
    CALL POT6D( MyR, V, F(1), F(2), F(3), F(4), F(5), F(6), switch, PES )
    V = Convert_Energy_Units( V, InternalUnits, OutUnits )
    DO i = 1, 6
      F(i) = Convert_Force_Units( F(i), InternalUnits, OutUnits )
    END DO
  END SUBROUTINE

  SUBROUTINE Read_MoleculeSurface_Data( PES )
    IMPLICIT NONE

    TYPE (CRP_MoleculeSurface_PES) :: PES
    INTEGER :: i, j, k
    REAL :: xcm, ycm, zcm, r, theta, phi, rab(6), dX, dY, dZ, Va, Vb
    REAL :: Rmin = 0.0, Rmax = 100.0, Zmin = -100.0
    LOGICAL :: lexists

    OPEN(10, FILE=TRIM(ADJUSTL(PES%DataSet)) // "/Molecule/extrapol.dat", STATUS="OLD")
    READ(10, *) PES%GasPhase%ZsoMin
    READ(10, *) PES%GasPhase%ZsoMax
    PES%GasPhase%ZsoMin = Convert_Length_Units( PES%GasPhase%ZsoMin, PES%InputUnits, InternalUnits )
    PES%GasPhase%ZsoMax = Convert_Length_Units( PES%GasPhase%ZsoMax, PES%InputUnits, InternalUnits )
    READ(10, *) PES%GasPhase%Zdep%NX
    CALL Allocate_Spline1D( PES%GasPhase%Zdep, PES%GasPhase%Zdep%NX )
    DO i = 1, PES%GasPhase%Zdep%NX
      READ(10, *) PES%GasPhase%Zdep%X(i),PES%GasPhase%Zdep%F(i)
      PES%GasPhase%Zdep%X(i) = Convert_Length_Units( PES%GasPhase%Zdep%X(i), PES%InputUnits, InternalUnits )
      PES%GasPhase%Zdep%F(i) = Convert_Energy_Units( PES%GasPhase%Zdep%F(i), PES%InputUnits, InternalUnits )
    END DO
    PES%Zasy = PES%GasPhase%Zdep%X(PES%GasPhase%Zdep%NX)
    CLOSE(10)
    CALL Compute_Spline1D( PES%GasPhase%Zdep, 0, 0.0, 2, 0.0 )

    OPEN(10, FILE=TRIM(ADJUSTL(PES%DataSet)) // "/Molecule/VH2.dat", STATUS="OLD")
    READ(10, *) PES%GasPhase%Rdep%NX
    CALL Allocate_Spline1D( PES%GasPhase%Rdep, PES%GasPhase%Rdep%NX )
    DO i = 1, PES%GasPhase%Rdep%NX
      READ(10, *) PES%GasPhase%Rdep%X(i), PES%GasPhase%Rdep%F(i)
      PES%GasPhase%Rdep%X(i) = Convert_Length_Units( PES%GasPhase%Rdep%X(i), PES%InputUnits, InternalUnits )
      PES%GasPhase%Rdep%F(i) = Convert_Energy_Units( PES%GasPhase%Rdep%F(i), PES%InputUnits, InternalUnits )
    END DO
    CLOSE(10)
    CALL Compute_Spline1D( PES%GasPhase%Rdep )

    DO k = 1, SIZE( PES%Cuts )
      INQUIRE( FILE=TRIM(ADJUSTL(PES%DataSet)) // "/Molecule/" // TRIM(ADJUSTL(PES%Cuts(k)%FileName)), EXIST=lexists )
      IF ( lexists ) THEN
      OPEN(10, FILE=TRIM(ADJUSTL(PES%DataSet)) // "/Molecule/" // TRIM(ADJUSTL(PES%Cuts(k)%FileName)), STATUS="OLD")
      READ(10, *) PES%Cuts(k)%Spline%NX
      READ(10, *) PES%Cuts(k)%Spline%NY
      CALL Allocate_Spline2D( PES%Cuts(k)%Spline, PES%Cuts(k)%Spline%NX, PES%Cuts(k)%Spline%NY )
      DO j = 1, PES%Cuts(k)%Spline%NY
        DO i = 1, PES%Cuts(k)%Spline%NX
          READ(10, *) PES%Cuts(k)%Spline%Y(j), PES%Cuts(k)%Spline%X(i), PES%Cuts(k)%Spline%F(i, j)
          PES%Cuts(k)%Spline%Y(j) = Convert_Length_Units( PES%Cuts(k)%Spline%Y(j), PES%InputUnits, InternalUnits )
          PES%Cuts(k)%Spline%X(i) = Convert_Length_Units( PES%Cuts(k)%Spline%X(i), PES%InputUnits, InternalUnits )
          PES%Cuts(k)%Spline%F(i, j) = Convert_Energy_Units( PES%Cuts(k)%Spline%F(i, j), PES%InputUnits, InternalUnits )
          IF (.NOT. PES%CutsInterpolation) THEN
            xcm = PES%Cuts(k)%X * PES%Geometry%LatticeConstant
            ycm = PES%Cuts(k)%Y * PES%Geometry%LatticeConstant
            zcm = PES%Cuts(k)%Spline%Y(j)
            r = PES%Cuts(k)%Spline%X(i)
            theta = PES%Cuts(k)%Theta * CRP_Constants_PI / 180.0
            phi = PES%Cuts(k)%Phi * CRP_Constants_PI / 180.0
            rab(1) = zcm - 0.5 * r * COS(theta)
            rab(4) = zcm + 0.5 * r * COS(theta)
            rab(2) = xcm - 0.5 * r * SIN(theta) * COS(phi)
            rab(5) = xcm + 0.5 * r * SIN(theta) * COS(phi)
            rab(3) = ycm - 0.5 * r * SIN(theta) * SIN(phi)
            rab(6) = ycm + 0.5 * r * SIN(theta) * SIN(phi)
            CALL Calculate_CRP_C4v_AtomSurface_PES( PES%AtomSurface, rab(2), rab(3), rab(1), Va, dX, dY, dZ, InternalUnits )
            CALL Calculate_CRP_C4v_AtomSurface_PES( PES%AtomSurface, rab(5), rab(6), rab(4), Vb, dX, dY, dZ, InternalUnits )
            PES%Cuts(k)%Spline%F(i, j) = PES%Cuts(k)%Spline%F(i, j) - Va - Vb
          END IF
        END DO
      END DO
      IF ( Rmin .LT. PES%Cuts(k)%Spline%X(1) ) THEN
        Rmin = PES%Cuts(k)%Spline%X(1)
      END IF
      IF ( Rmax .GT. PES%Cuts(k)%Spline%X(PES%Cuts(k)%Spline%NX) ) THEN
        Rmax = PES%Cuts(k)%Spline%X(PES%Cuts(k)%Spline%NX)
      END IF
      IF ( Zmin .LT. PES%Cuts(k)%Spline%Y(1) ) THEN
        Zmin = PES%Cuts(k)%Spline%Y(1)
      END IF
      CLOSE(10)
      CALL Compute_Spline2D( PES%Cuts(k)%Spline )
      END IF
    END DO

    PES%Rmin = Rmin
    PES%Rmax = Rmax
    PES%Zmin = Zmin

!   Here the length units of the input data is Angstroems!!!!
!   BEWARE !!!!!!!! rmax and zccmin MUST be given in Angstroems.
!    PES%Rmax = rn(nrn)
!    PES%ZccMin = zn(1)
!   If the PES programs use a.u., we MUST replace the 2 lines above by
!   rmax=rn(nrn)*0.529177249
!   zccmin=zn(1)*0.529177249
  END SUBROUTINE

  SUBROUTINE InterpolateOnTop( Theta, Phi, Vint, Psite )
    IMPLICIT NONE

    REAL    :: Theta, Phi
    REAL    :: V0, V90, dV0dPhi, dV90dPhi
    REAL    :: Vint(3, 3)
    REAL    :: Psite(5)
    INTEGER :: i

    DO i = 1, 3
      V0 = Vint(i, 1)
      V90 = 0.5 * (Vint(i, 2) + Vint(i, 3)) + 0.5 * (Vint(i, 2) - Vint(i, 3)) * COS(4.0 * Phi)
      Psite(i) = 0.5 * (V0 + V90) + 0.5 * (V0 - V90) * COS(2.0 * Theta)
      IF ( i .EQ. 1 ) THEN
        dV0dPhi = 0.0
        dV90dPhi = -4.0 * 0.5 * (Vint(1, 2) - Vint(1, 3)) * SIN(4.0 * Phi)
        Psite(4) = 0.5 * (dV0dPhi + dV90dPhi) + 0.5 * (dV0dPhi - dV90dPhi) * COS(2.0 * Theta)
        Psite(5) = -2.0 * 0.5 * (V0 - V90) * SIN(2.0 * Theta)
      END IF
    END DO
  END SUBROUTINE

  SUBROUTINE InterpolateOnBridge( Theta, Phi, Vint, Psite )
    IMPLICIT NONE

    REAL    :: Theta, Phi
    REAL    :: V0, V90, dV0dPhi, dV90dPhi
    REAL    :: Vint(3, 4)
    REAL    :: Psite(5)
    INTEGER :: i

    DO i = 1, 3
      V0 = Vint(i, 1)
      V90 = (0.25 * Vint(i, 2) + 0.5 * Vint(i, 3) + 0.25 * Vint(i, 4)) + &
             0.5 * (Vint(i, 2) - Vint(i, 4)) * COS(2.0 * Phi) + &
            (0.25 * Vint(i, 2) - 0.5 * Vint(i, 3) + 0.25 * Vint(i, 4)) * COS(4.0 * Phi)
      Psite(i) = 0.5 * (V0 + V90) + 0.5 * (V0 - V90) * COS(2.0 * Theta)
      IF ( i .EQ. 1 ) THEN
        dV0dPhi = 0.0
        dV90dPhi = -2.0 * 0.5 * (Vint(1, 2) - Vint(1, 4)) * SIN(2.0 * Phi) - &
                    4.0 * (0.25 * Vint(1, 2) - 0.5 * Vint(1, 3) + &
                    0.25 * Vint(1, 4)) * SIN(4.0 * Phi)
        Psite(4) = 0.5 * (dV0dPhi + dV90dPhi) + &
                    0.5 * (dV0dPhi - dV90dPhi) * COS(2.0 * Theta)
        Psite(5) = -2.0 * 0.5 * (V0 - V90) * SIN(2.0 * Theta)
      ENDIF
    END DO
  END SUBROUTINE

  SUBROUTINE InterpolateOnHollow( Theta, Phi, Vint, Psite )
    IMPLICIT NONE

    REAL    :: Theta, Phi
    REAL    :: V0, V90, dV0dPhi, dV90dPhi
    REAL    :: Vint(3, 3)
    REAL    :: Psite(5)
    INTEGER :: i

    DO i = 1, 3
      V0 = Vint(i, 1)
      V90 = 0.5 * (Vint(i, 2) + Vint(i, 3)) + 0.5 * (Vint(i, 2) - Vint(i, 3)) * COS(4.0 * Phi)
      Psite(i) = 0.5 * (V0 + V90) + 0.5 * (V0 - V90) * COS(2.0 * Theta)
      IF ( i .EQ. 1 ) THEN
        dV0dPhi = 0.0
        dV90dPhi = -4.0 * 0.5 * (Vint(1, 2) - Vint(1, 3)) * SIN(4.0 * Phi)
        Psite(4) = 0.5 * (dV0dPhi + dV90dPhi) + 0.5 * (dV0dPhi - dV90dPhi) * COS(2.0 * Theta)
        Psite(5) = -2.0 * 0.5 * (V0 - V90) * SIN(2.0 * Theta)
      END IF
    END DO
  END SUBROUTINE

  SUBROUTINE InterpolateOnT2H( Theta, Phi, Vint, Psite )
    IMPLICIT NONE

    REAL    :: Theta, Phi
    REAL    :: V0, V45, V90, V135, dV0dPhi, dV45dPhi, dV90dPhi, dV135dPhi
    REAL    :: Vint(3, 6)
    REAL    :: Psite(5)
    REAL    :: a0, b0, c0
    INTEGER :: i

    DO i = 1, 3
      V0 = Vint(i, 1)
      c0 = 0.25 * (Vint(i, 2) + Vint(i, 3) - 2.0 * Vint(i, 6))
      b0 = -Vint(i, 6) + Vint(i, 3) - 2.0 * c0
      a0 = Vint(i, 3) - b0 - c0
      V45 = a0 + b0 * COS(Phi - CRP_Constants_PI / 4.0) + c0 * COS(2.0 * (Phi - CRP_Constants_PI / 4.0))
      V135 = a0 + b0 * COS(Phi + CRP_Constants_PI - CRP_Constants_PI / 4.0) + &
             c0 * COS(2.0 * (Phi + CRP_Constants_PI - CRP_Constants_PI/4.0))
      V90 = 0.5 * (Vint(i, 4) + Vint(i, 5)) + 0.5 * (Vint(i, 4) - Vint(i, 5)) * COS(2.0 * (Phi - CRP_Constants_PI / 4.0))
      Psite(i) = 0.25 * (V0 + V45 + V90 + V135) + 0.5 * (V0 - V90) * COS(2.0 * Theta) + &
                  0.5 * (V45 - V135) * SIN(2.0 * Theta) + 0.25 * (V0 + V90 - V45 - V135) * COS(4.0 * Theta)
      IF ( i .EQ. 1 ) THEN
        dV0dPhi = 0.0
        dV45dPhi = -b0 * SIN(Phi - CRP_Constants_PI / 4.0) - 2.0 * c0 * SIN(2.0 * (Phi - CRP_Constants_PI / 4.0))
        dV135dPhi = -b0 * SIN(Phi + CRP_Constants_PI - CRP_Constants_PI / 4.0) - &
                    2.0 * c0 * SIN(2.0 * (Phi + CRP_Constants_PI - CRP_Constants_PI / 4.0))
        dV90dPhi = -2.0 * 0.5 * (Vint(1, 4) - Vint(1, 5)) * SIN(2.0 * (Phi - CRP_Constants_PI / 4.0))
        Psite(4) = 0.25 * (dV0dPhi + dV45dPhi + dV90dPhi + dV135dPhi) + 0.5 * (dV0dPhi - dV90dPhi) * COS(2.0 * Theta) + &
                    0.5 * (dV45dPhi - dV135dPhi) * SIN(2.0 * Theta) + 0.25 * (dV0dPhi + dV90dPhi - dV45dPhi - dV135dPhi) * &
                    COS(4.0 * Theta)
        Psite(5) = -2.0 * 0.5 * (V0 - V90) * SIN(2.0 * Theta) + 2.0 * 0.5 * (V45 - V135) * COS(2.0 * Theta) - &
                    4.0 * 0.25 * (V0 + V90 - V45 - V135) * SIN(4.0 * Theta)
      END IF
    END DO
  END SUBROUTINE

!*********************************************************************************************
!*********************************************************************************************
!*********************************************************************************************
!*********************************************************************************************
!*********************************************************************************************
!     ------------------------------------------------------------------
!     Esta subrutina calcula el valor del potencial 6D y sus 6 derivadas
!     parciales para el caso de una molecula diatomica homonuclear sobre
!     una superficie (100) de un cristal FCC con una distancia entre
!     atomos primeros vecinos en la superficie igual a DELTA.
!     El metodo utilizado es la interpolacion de resultados ab-initio
!     obtenidos para ciertas orientaciones particulares de la molecula:
!     I) 3 configuraciones sobre sitio TOP:
!        a) perpendicular a la superficie
!        b) paralela a la superficie con FI=0
!        c) paralela a la superficie con FI=45
!     II) 4 configuraciones sobre sitio BRIDGE:
!        a) perpendicular a la superficie
!C        b) paralela a la superficie con FI=0
!C        c) paralela a la superficie con FI=45
!C        d) paralela a la superficie con FI=90
!C     III) 3 configuraciones sobre sitio HOLLOW:
!C        a) perpendicular a la superficie
!C        b) paralela a la superficie con FI=0
!C        c) paralela a la superficie con FI=45
!C     IV) 6 configuraciones sobre sitio T2H(punto medio entre top y hollow):
!C        a) theta=0
!C        b) theta=3*pi/4; phi=pi/4
!C        c) theta=3*pi/4; phi=pi/4
!C        d) theta=pi/2; phi=pi/4
!C        e) theta=pi/2; phi=3*pi/4
!C        f) theta=pi/4; phi=3*pi/4
!C
!C     y teniendo en cuenta el potencial de cada atomo independientemente
!C     sobre la superficie.
!C     El potencial de atomo-superficie tambien se obtiene por interpolacion
!C     a partir de resultados ab-initio correspondientes a ciertas
!C     configuraciones (ver detalles y comentarios en la subrutina AT100).
!C
!C     Antes de llamar a la subrutina VH2CU100 se deben haber llamado las
!C     subrutinas: LECTATOM (necesario para la subrutina AT100) y LECTMOL.
!C     El vector RAB (variable de entrada de 12 componentes) tiene sus 6
!C     primeras componentes que dan las coordenadas de los dos atomos del
!C     siguiente modo:
!C     RAB(1)=ZA, RAB(2)=XA, RAB(3)=YA, RAB(4)=ZB, RAB(5)=XB, RAB(6)=YB
!C     Las restantes 6 componentes del vector RAB no son utilizadas en esta
!C     subrutina y sus valores de entrada no son alterados
!C
!C     En la presente subrutina se supone que el sistema de ejes coordenados
!C     utilizado por el programa que llama a esta subrutina es el siguiente:
!C
!C          y^
!C           |
!C           *      *
!C           |
!C           |
!C           *------*--->
!C                     x
!C
!C     La variable logica SWITCH sirve para saber a la salida si la
!C     interpolacion pudo realizarse o si no fue posible por encontrar
!C     las coordenadas del punto a calcular, fuera de rango.
!C     Si SWITCH=.TRUE. -> No se pudo interpolar.
!C
!C     La variable IUNIT indica en que unidades esta expresada la variable
!C     de entrada RAB.
!C     IUNIT=1 => RAB enters in a.u. and all the results are given in a.u.
!C     ------------------------------------------------------------------
!C     ------------------------------------------------------------------
  SUBROUTINE POT6D( Rab, PotV, dVdXa, dVdYa, dVdZa, dVdXb, dVdYb, dVdZb, switch, PES )
    IMPLICIT NONE

    TYPE (CRP_MoleculeSurface_PES) :: PES

    LOGICAL          :: switch
    REAL :: Rab(6), PotV, dVdXa, dVdYa, dVdZa, dVdXb, dVdYb, dVdZb, ro, Theta, Phi
    REAL :: Xa, Xb, Ya, Yb, Za, Zb, Xcc, Ycc, Zcc

    switch = .FALSE.

    PotV = 0.0
    dVdXa = 0.0
    dVdYa = 0.0
    dVdZa = 0.0
    dVdXb = 0.0
    dVdYb = 0.0
    dVdZb = 0.0

    Za = Rab(1)
    Zb = Rab(4)
    Xa = Rab(2)
    Ya = Rab(3)
    Xb = Rab(5)
    Yb = Rab(6)

    CALL CAMBCORD( Xa, Ya, Za, Xb, Yb, Zb, Xcc, Ycc, Zcc, ro, Theta, Phi,PES )
    CALL RRINT( Xa, Ya, Za, Xb, Yb, Zb, Xcc, Ycc, Zcc, ro, Theta, Phi, &
                  PotV, dVdXa, dVdYa, dVdZa, dVdXb, dVdYb, dVdZb, switch, PES )
  END SUBROUTINE

  SUBROUTINE RRINT( xa, ya, za, xb, yb, zb, Xcc, Ycc, Zcc, r, Theta, Phi, V, dVdXa, dVdYa, dVdZa, dVdXb, dVdYb, dVdZb, &
                    switch, PES )
    IMPLICIT NONE

    REAL :: Xa, Ya, Za, Xb, Yb, Zb, Xcc, Ycc, Zcc, r, Theta, Phi, V, dVdXa, dVdYa, dVdZa, dVdXb, dVdYb, dVdZb, &
            dPhiXa, dPhiXb, dPhiYa, dPhiYb, dFso, dFsodZa, dFsodZb, drXa, drXb, drYa, drYb, drZa, drZb, &
            dThetaXa, dThetaXb, dThetaYa, dThetaYb, dThetaZa, dThetaZb
    INTEGER :: i
    LOGICAL :: switch

    REAL    :: Vint( 3, 6 ), Psite( 5, 8 )
    !REAL    :: Vint1(3), Vint2(3), Vint3(3), Vint4(3), Vint5(3), Vint6(3)
    REAL    :: Vinter(7)
    !REAL    :: Psite1(5), Psite2(5), Psite3(5), Psite4(5), Psite5(5), Psite6(5), Psite7(5), Psite8(5)
    REAL    :: dV2DinfR, dV2DinfZ, dXa, dXb, dYa, dYb, dZa, dZb, Fso, rho, rho2, Va, Vb, V2D

    TYPE ( CRP_MoleculeSurface_PES ) :: PES
!C     ------------------------------------------------------------------
!      INTEGER, PARAMETER :: idm = 16
!      COMMON/PES6CuVERT1/ZVT(IDM),RVT(IDM),VVT(IDM,IDM),DVVTZ(IDM,IDM),DVVTR(IDM,IDM),DVVTZR(IDM,IDM), &
!                   NRTV,NZTV
!      COMMON/PES6CuVERT2/ZVB(IDM),RVB(IDM),VVB(IDM,IDM),DVVBZ(IDM,IDM),DVVBR(IDM,IDM),DVVBZR(IDM,IDM), &
!                   NRBV,NZBV
!      COMMON/PES6CuVERT3/ZVH(IDM),RVH(IDM),VVH(IDM,IDM),DVVHZ(IDM,IDM),DVVHR(IDM,IDM),DVVHZR(IDM,IDM), &
!                   NRHV,NZHV
!      COMMON/PES6CuHOR10/Z10(IDM),R10(IDM),V10(IDM,IDM),DV10R(IDM,IDM),DV10Z(IDM,IDM),DV10ZR(IDM,IDM), &
!                   NR10,NZ10
!      COMMON/PES6CuHOR145/Z145(IDM),R145(IDM),V145(IDM,IDM),DV145R(IDM,IDM),DV145Z(IDM,IDM), &
!                   DV145ZR(IDM,IDM),NR145,NZ145
!      COMMON/PES6CuHOR20/Z20(IDM),R20(IDM),V20(IDM,IDM),DV20R(IDM,IDM),DV20Z(IDM,IDM), &
!                   DV20ZR(IDM,IDM),NR20,NZ20
!      COMMON/PES6CuHOR245/Z245(IDM),R245(IDM),V245(IDM,IDM),DV245R(IDM,IDM),DV245Z(IDM,IDM), &
!                   DV245ZR(IDM,IDM),NR245,NZ245
!      COMMON/PES6CuHOR290/Z290(IDM),R290(IDM),V290(IDM,IDM),DV290R(IDM,IDM),DV290Z(IDM,IDM), &
!                   DV290ZR(IDM,IDM),NR290,NZ290
!      COMMON/PES6CuHOR30/Z30(IDM),R30(IDM),V30(IDM,IDM),DV30R(IDM,IDM),DV30Z(IDM,IDM), &
!                   DV30ZR(IDM,IDM),NR30,NZ30
!      COMMON/PES6CuHOR345/Z345(IDM),R345(IDM),V345(IDM,IDM),DV345R(IDM,IDM),DV345Z(IDM,IDM), &
!                   DV345ZR(IDM,IDM),NR345,NZ345
!!C     ------------------------------------------------------------------
!      COMMON/PES6CuDAT11/Z11(IDM),R11(IDM),V11(IDM,IDM), DV11R(IDM,IDM),DV11Z(IDM,IDM), &
!                      DV11ZR(IDM,IDM),NR11,NZ11
!      COMMON/PES6CuDAT12/Z12(IDM),R12(IDM),V12(IDM,IDM),DV12R(IDM,IDM),DV12Z(IDM,IDM), &
!                             DV12ZR(IDM,IDM),NR12,NZ12
!      COMMON/PES6CuDAT13/Z13(IDM),R13(IDM),V13(IDM,IDM),  DV13R(IDM,IDM),DV13Z(IDM,IDM), &
!                 DV13ZR(IDM,IDM),NR13,NZ13
!      COMMON/PES6CuDAT14/Z14(IDM),R14(IDM),V14(IDM,IDM),DV14R(IDM,IDM),DV14Z(IDM,IDM), &
!                 DV14ZR(IDM,IDM),NR14,NZ14
!      COMMON/PES6CuDAT15/Z15(IDM),R15(IDM),V15(IDM,IDM), DV15R(IDM,IDM),DV15Z(IDM,IDM), &
!          DV15ZR(IDM,IDM),NR15,NZ15
!      COMMON/PES6CuDAT16/Z16(IDM),R16(IDM),V16(IDM,IDM), DV16R(IDM,IDM),DV16Z(IDM,IDM), &
!         DV16ZR(IDM,IDM),NR16,NZ16
!!C     ------------------------------------------------------------------
!!C     Datos para el switch off del potencial
!      COMMON/PES6CuSWOFF/ZSOMIN,ZSOMAX
!      COMMON/PES6CuH2INFI/RH2(IDM),VH2INFI(IDM),VH2INFI2(IDM),NDATH2

!      INTEGER :: ndath2
!      INTEGER :: nztv, nzbv, nzhv, nz10, nz145, nz20, nz245, nz290, nz30, nz345, nz11, nz12, nz13, nz14, nz15, nz16
!      INTEGER :: nrtv, nrbv, nrhv, nr10, nr145, nr20, nr245, nr290, nr30, nr345, nr11, nr12, nr13, nr14, nr15, nr16

!      INTEGER :: ia, ja

    switch = .FALSE.
    V = 0.0
    Va = 0.0
    Vb = 0.0
    dVdXa = 0.0
    dVdYa = 0.0
    dVdZa = 0.0
    dVdXb = 0.0
    dVdYb = 0.0
    dVdZb = 0.0

    IF (Zcc .LT. PES%GasPhase%ZsoMax) THEN
         !CALL UBICAR(RVT,RO,NRTV,IA,SWITCH)
         !IF (SWITCH) RETURN
         !CALL UBICAR(ZVT,ZCM,NZTV,JA,SWITCH)
         !IF (SWITCH) RETURN
         !     Potential on top
      DO i = 1, 3
        CALL Evaluate_Spline2D_Alt( PES%Cuts(i)%Spline, r, Zcc, Vint(1, i), switch )
        IF (switch) RETURN
      END DO
      CALL InterpolateOnTop( Theta, Phi, Vint, Psite(1, 1) )
!!C     ------------------------------------------------------------------
!!C     Siempre la primera componente es el potencial, luego las derivadas
!!C     respecto a Z, RO, FI, X, Y, TETA en ese orden ! ! ! !
!!C     ------------------------------------------------------------------
!!C     Potential on TOP
!!C      --------------------
!!C     Top theta=0
!      CALL int_PES6CuSPLINT2(RVT,ZVT,NRTV,NZTV,VVT,DVVTR,DVVTZ,DVVTZR,RO,ZCM, &
!             IA,JA,VINT1(1),VINT1(3),VINT1(2),IDM,IDM)
!!C     -----------------------------------------
!!C     Top theta=90;phi=0
!      CALL int_PES6CuSPLINT2(R10,Z10,NR10,NZ10,V10,DV10R,DV10Z,DV10ZR,RO,ZCM, &
!               IA,JA,VINT2(1),VINT2(3),VINT2(2),IDM,IDM)
!!C     -----------------------------------------
!!C     Top theta=90;phi=45
!      CALL int_PES6CuSPLINT2(R145,Z145,NR145,NZ145,V145,DV145R,DV145Z,DV145ZR, &
!           RO,ZCM,IA,JA,VINT3(1),VINT3(3),VINT3(2),IDM,IDM)
!!C     -----------------------------------------
!      CALL InterpolateOnTop(TETA,FI,VINT1,VINT2,VINT3,PSITE1)
!!C     ------------------------------------------------------------------
!C     Interpolacion on BRIDGE
!C     -------------------------------
!C     -------------------------------
!     Potential on bridge
      DO i = 4, 7
        CALL Evaluate_Spline2D_Alt( PES%Cuts(i)%Spline, r, Zcc, Vint(1, i - 3), switch )
        IF (switch) RETURN
      END DO
      CALL InterpolateOnBridge( Theta, Phi, Vint, Psite(1, 2) )
      CALL InterpolateOnBridge( Theta, Phi + CRP_Constants_PI / 2.0, Vint, Psite(1, 5) )

!!C     Potential on Bridge and theta=0
!      CALL int_PES6CuSPLINT2(RVB,ZVB,NRBV,NZBV,VVB,DVVBR,DVVBZ,DVVBZR,RO,ZCM, &
!              IA,JA,VINT1(1),VINT1(3),VINT1(2),IDM,IDM)
!!C     -----------------------
!!C     Bridge theta=90;phi=0
!      CALL int_PES6CuSPLINT2(R20,Z20,NR20,NZ20,V20,DV20R,DV20Z,DV20ZR,RO,ZCM, &
!             IA,JA,VINT2(1),VINT2(3),VINT2(2),IDM,IDM)
!!C     -----------------------
!!C     Bridge theta=90;phi=45
!      CALL int_PES6CuSPLINT2(R245,Z245,NR245,NZ245,V245,DV245R,DV245Z,DV245ZR, &
!         RO,ZCM,IA,JA,VINT3(1),VINT3(3),VINT3(2),IDM,IDM)
!!C     -----------------------
!!C     Bridge theta=90;phi=90
!      CALL int_PES6CuSPLINT2(R290,Z290,NR290,NZ290,V290,DV290R,DV290Z,DV290ZR, &
!                  RO,ZCM,IA,JA,VINT4(1),VINT4(3),VINT4(2),IDM,IDM)
!!C     -------------------------------------------
!      CALL InterpolateOnBridge(TETA,FI,VINT1,VINT2,VINT3,VINT4,PSITE2)
!!C     EL potencial en el punto 2', equivalente a 2! (lo llamo sitio5)
!      CALL InterpolateOnBridge(TETA,FI+CRP_Constants_PI/2.0,VINT1,VINT2,VINT3,VINT4,PSITE5)
!!C     ------------------------------------------------------------------
!C     Interpolacion on HOLLOW
!C     -----------------------
      DO i = 8, 10
        CALL Evaluate_Spline2D_Alt( PES%Cuts(i)%Spline, r, Zcc, Vint(1, i - 7), switch )
        IF (switch) RETURN
      END DO
      CALL InterpolateOnHollow( Theta, Phi, Vint, Psite(1, 3) )

!!C     Hollow theta=0
!      CALL int_PES6CuSPLINT2(RVH,ZVH,NRHV,NZHV,VVH,DVVHR,DVVHZ,DVVHZR,RO,ZCM, &
!              IA,JA,VINT1(1),VINT1(3),VINT1(2),IDM,IDM)
!!C     -----------------------------------------
!!C     Hollow theta=90, phi=0
!      CALL int_PES6CuSPLINT2(R30,Z30,NR30,NZ30,V30,DV30R,DV30Z,DV30ZR,RO,ZCM, &
!                  IA,JA,VINT2(1),VINT2(3),VINT2(2),IDM,IDM)
!!C     -----------------------------------------
!!C     Hollow theta=90, phi=45
!      CALL int_PES6CuSPLINT2(R345,Z345,NR345,NZ345,V345,DV345R,DV345Z, &
!                 DV345ZR,RO,ZCM,IA,JA,VINT3(1),VINT3(3),VINT3(2),IDM,IDM)
!!C     ---------------------------------------------
!      CALL InterpolateOnHollow(TETA,FI,VINT1,VINT2,VINT3,PSITE3)
!!C     ---------------------------------------------------------------
!C     Interpolacion on T2H
!C     ---------------------------------------
      DO i = 11, 16
        CALL Evaluate_Spline2D_Alt( PES%Cuts(i)%Spline, r, Zcc, Vint(1, i - 10), switch )
        IF (switch) RETURN
      END DO
      CALL InterpolateOnT2H( Theta, Phi, Vint, Psite(1, 4) )
      CALL InterpolateOnT2H( Theta, Phi - CRP_Constants_PI / 2.0, Vint, Psite(1, 6) )
      CALL InterpolateOnT2H( Theta, Phi - CRP_Constants_PI, Vint, Psite(1, 7) )
      CALL InterpolateOnT2H( Theta, Phi + CRP_Constants_PI / 2.0, Vint, Psite(1, 8) )

!C     T2H theta=0
!      CALL int_PES6CuSPLINT2(R11,Z11,NR11,NZ11,V11,DV11R,DV11Z,DV11ZR,RO,ZCM, &
!               IA,JA,VINT1(1),VINT1(3),VINT1(2),IDM,IDM)
!!C     -----------------------------------------
!!C     T2H theta=45; phi=225
!      CALL int_PES6CuSPLINT2(R12,Z12,NR12,NZ12,V12,DV12R,DV12Z,DV12ZR,RO,ZCM, &
!             IA,JA,VINT2(1),VINT2(3),VINT2(2),IDM,IDM)
!!C     -----------------------------------------
!!C     T2H theta=45; phi=45
!      CALL int_PES6CuSPLINT2(R13,Z13,NR13,NZ13,V13,DV13R,DV13Z,DV13ZR,RO,ZCM, &
!            IA,JA,VINT3(1),VINT3(3),VINT3(2),IDM,IDM)
!!C     -----------------------------------------
!!C     T2H theta=90; phi=45
!      CALL int_PES6CuSPLINT2(R14,Z14,NR14,NZ14,V14,DV14R,DV14Z,DV14ZR,RO,ZCM, &
!            IA,JA,VINT4(1),VINT4(3),VINT4(2),IDM,IDM)
!!C     ---------------------------------------
!!C     T2H theta=90; phi=135
!      CALL int_PES6CuSPLINT2(R15,Z15,NR15,NZ15,V15,DV15R,DV15Z,DV15ZR,RO,ZCM, &
!             IA,JA,VINT5(1),VINT5(3),VINT5(2),IDM,IDM)
!!C     ---------------------------------------
!!C     T2H theta=45; phi=135
!      CALL int_PES6CuSPLINT2(R16,Z16,NR16,NZ16,V16,DV16R,DV16Z,DV16ZR,RO,ZCM, &
!              IA,JA,VINT6(1),VINT6(3),VINT6(2),IDM,IDM)
!!C     ---------------------------------------
!      CALL InterpolateOnT2H(TETA,FI,VINT1,VINT2,VINT3,VINT4,VINT5,VINT6,PSITE4)
!!C     Los potenciales en el punto 4', 4'' y 4''',
!!C     equivalentes a 4 (los llamo sitio6,7,8 respectivamente)
!      CALL InterpolateOnT2H(TETA,FI-CRP_Constants_PI/2.0,VINT1,VINT2,VINT3,VINT4,VINT5, &
!               VINT6,PSITE6)
!      CALL InterpolateOnT2H(TETA,FI-CRP_Constants_PI,VINT1,VINT2,VINT3,VINT4,VINT5,VINT6,PSITE7)
!      CALL InterpolateOnT2H(TETA,FI+CRP_Constants_PI/2.0,VINT1,VINT2,VINT3,VINT4,VINT5, &
!             VINT6,PSITE8)
!C     ---------------------------------------------------------------
      CALL SIS8x8( Xcc, Ycc, Psite, Vinter, PES )
!C      WRITE(*,*)'Func. de interpolacion (eV)=',VINTER(1)
!C     ------------------------------------------------------------------
!C     Transformacion de coordenadas para pasar de (X,Y,Z,RO,TETA,FI),
!C     las cuales fueron utilizadas en la interpolacion horizontal, a
!C     (XA,YA,ZA,XB,YB,ZB)

      drXa = -(Xb - Xa) / r
      drXb = -drXa
      drYa = -(Yb - Ya) / r
      drYb = -drYa
      drZa = -(Zb - Za) / r
      drZb = -drZa
      IF ( (Xb - Xa)**2.0 + (Yb - Ya)**2.0 .GT. 0.0 ) THEN
         dThetaXa = -(Zb - Za) * (Xb - Xa) / r**2.0 / SQRT((Xb - Xa)**2.0 + (Yb - Ya)**2.0)
         dThetaYa = -(Zb - Za) * (Yb - Ya) / r**2.0 / SQRT((Xb - Xa)**2.0 + (Yb - Ya)**2.0)
         dPhiXa = (YB-YA)/((XB-XA)**2.0+(YB-YA)**2.0)
         dPhiYa = -(XB-XA)/((XB-XA)**2.0+(YB-YA)**2.0)
      ELSE
         dThetaXa = 0.0
         dThetaYa = 0.0
         dPhiXa = 0.0
         dPhiYa = 0.0
      END IF
      dThetaZa = SQRT((Xb - Xa)**2.0 + (Yb - Ya)**2.0) / r**2.0
      dThetaXb = -dThetaXa
      dThetaYb = -dThetaYa
      dThetaZb = -dThetaZa
      dPhiXb = -dPhiXa
      dPhiYb = -dPhiYa
!C     -----------------------------------------------------------------
      CALL Calculate_CRP_C4v_AtomSurface_PES( PES%AtomSurface, XA, YA, ZA, VA, DXA, DYA, DZA, InternalUnits)
      CALL Calculate_CRP_C4v_AtomSurface_PES( PES%AtomSurface, XB, YB, ZB, VB, DXB, DYB, DZB, InternalUnits)
!C      WRITE(*,*)'--------------------------'
!C      WRITE(*,*)'V atomo A (eV)=',VA
!C      WRITE(*,*)'dV/dX atomo A (eV/au)=',DXA
!C      WRITE(*,*)'dV/dY atomo A (eV/au)=',DYA
!C      WRITE(*,*)'dV/dZ atomo A (eV/au)=',DZA
!C      WRITE(*,*)'V atomo B (eV)=',VB
!C      WRITE(*,*)'dV/dX atomo B (eV/au)=',DXB
!C      WRITE(*,*)'dV/dY atomo B (eV/au)=',DYB
!C      WRITE(*,*)'dV/dZ atomo B (eV/au)=',DZB
!C      WRITE(*,*)'V atomico (eV)=',VA+VB
!C      WRITE(*,*)'--------------------------'
!C     ------------------------------------------------------------------
      IF ( Zcc .LE. PES%GasPhase%ZsoMin ) THEN
        V = Va + Vb + Vinter(1)
        dVdXa = dXa + 0.5 * Vinter(6) + drXa * Vinter(3) + dThetaXa * Vinter(5) + dPhiXa * Vinter(4)
        dVdXb = dXb + 0.5 * Vinter(6) + drXb * Vinter(3) + dThetaXb * Vinter(5) + dPhiXb * Vinter(4)
        dVdYa = dYa + 0.5 * Vinter(7) + drYa * Vinter(3) + dThetaYa * Vinter(5) + dPhiYa * Vinter(4)
        dVdYb = dYb + 0.5 * Vinter(7) + drYb * Vinter(3) + dThetaYb * Vinter(5) + dPhiYb * Vinter(4)
        dVdZa = dZa + 0.5 * Vinter(2) + drZa * Vinter(3) + dThetaZa * Vinter(5)
        dVdZb = dZb + 0.5 * Vinter(2) + drZb * Vinter(3) + dThetaZb * Vinter(5)
      ELSE
        CALL Switch_Function( Zcc, Fso, dFso, PES%GasPhase )
        CALL Calculate_CRP_GasPhase_Potential( Zcc, r, V2D, dV2DinfZ, dV2DinfR, PES%GasPhase )
        V = (Va + Vb + Vinter(1)) * Fso + (1.0 - Fso) * V2D
        dFsodZa = 0.5 * dFso
        dFsodZb = 0.5 * dFso
        dVdXa = (dXa + 0.5 * Vinter(6) + drXa * Vinter(3) + dThetaXa * Vinter(5) + &
                 dPhiXa * Vinter(4)) * Fso + (1.0 - Fso) * dV2Dinfr * drXa
        dVdXb = (dXb + 0.5 * Vinter(6) + drXb * Vinter(3) + dThetaXb * Vinter(5) + &
                 dPhiXb * Vinter(4)) * Fso + (1.0 - Fso) * dV2Dinfr * drXb
        dVdYa = (dYa + 0.5 * Vinter(7) + drYa * Vinter(3) + dThetaYa * Vinter(5) + &
                 dPhiYa * Vinter(4)) * Fso + (1.0 - Fso) * dV2Dinfr * drYa
        dVdYb = (dYb + 0.5 * Vinter(7) + drYb * Vinter(3) + dThetaYb * Vinter(5) + &
                 dPhiYb * Vinter(4)) * Fso + (1.0 - Fso) * dV2Dinfr * drYb
        dVdZa = (dZa + 0.5 * Vinter(2) + drZa * Vinter(3) + dThetaZa * Vinter(5)) &
                 * Fso + (Va + Vb + Vinter(1)) * dFsodZa - dFsodZa * V2D + &
                  (1.0 - Fso) * (dV2DinfZ * 0.5 + drZa * dV2DinfR)
        dVdZb = (dZb + 0.5 * Vinter(2) + drZb * Vinter(3) + dThetaZb * Vinter(5)) &
                 * Fso + (Va + Vb + Vinter(1)) * dFsodZb - dFsodZb * V2D + &
                  (1.0 - Fso) * (dV2DinfZ * 0.5 + drZb * dV2DinfR)
      END IF
    ELSE
      IF (r .LT. PES%GasPhase%Rdep%X(1) .OR. r .GT. PES%GasPhase%Rdep%X(PES%GasPhase%Rdep%NX)) THEN
        switch = .TRUE.
        RETURN
      END IF

      CALL Calculate_CRP_GasPhase_Potential( Zcc, r, V, dV2DinfZ, dV2DinfR, PES%GasPhase )
      drXa = -(Xb - Xa) / r
      drXb = -drXa
      drYa = -(Yb - Ya) / r
      drYb = -drYa
      drZa = -(Zb - Za) / r
      drZb = -drZa
      dVdXa = drXa * dV2Dinfr
      dVdXb = drXb * dV2Dinfr
      dVdYa = drYa * dV2Dinfr
      dVdYb = drYb * dV2Dinfr
      dVdZa = 0.5 * dV2DinfZ + drZa * dV2DinfR
      dVdZb = 0.5 * dV2DinfZ + drZb * dV2DinfR
    END IF
  END SUBROUTINE

  SUBROUTINE SIS8x8( Xcm, Ycm, Psite, Vinter, PES )
    IMPLICIT NONE

    REAL :: Xcm, Ycm, Psite(5, 8), Vinter(7)
    REAL :: Fac, F1XY, F2XY, F3XY, F4XY, F5XY, F6XY, F7XY, F8XY, A1, A2, A3, A4, A5, A6, A7, A8
    REAL :: dF1dX, dF1dY, dF2dX, dF2dY, dF3dX, dF3dY, dF4dX, dF4dY, dF5dX, dF5dY, dF6dX, dF6dY, dF7dX, dF7dY, dF8dX, dF8dY
    TYPE (CRP_MoleculeSurface_PES) :: PES
    INTEGER :: i

!   Interpolation with respect to X and Y
    Fac = 2.0 * CRP_Constants_PI / PES%Geometry%LatticeConstant
    F1XY = 1.0
    F2XY = COS(Fac * Xcm)
    F3XY = COS(Fac * Ycm)
    F4XY = SIN(Fac * Xcm)
    F5XY = SIN(Fac * Ycm)
    F6XY = COS(Fac * (Xcm + Ycm))
    F7XY = COS(Fac * (Xcm - Ycm))
    F8XY = COS(Fac * (2.0 * Xcm)) + COS(Fac * (2.0 * Ycm))

    dF1dX = 0.0
    dF1dY = 0.0
    dF2dX = -Fac * SIN(Fac * Xcm)
    dF2dY = 0.0
    dF3dX = 0.0
    dF3dY = -Fac * SIN(Fac * Ycm)
    dF4dX = Fac * COS(Fac * Xcm)
    dF4dY = 0.0
    dF5dX = 0.0
    dF5dY = Fac * COS(Fac * Ycm)
    dF6dX = -Fac * SIN(Fac * (Xcm + Ycm))
    dF6dY = -Fac * SIN(Fac * (Xcm + Ycm))
    dF7dX = -Fac * SIN(Fac * (Xcm - Ycm))
    dF7dY = Fac * SIN(Fac * (Xcm - Ycm))
    dF8dX = -2.0 * Fac * SIN(Fac * (2.0 * Xcm))
    dF8dY = -2.0 * Fac * SIN(Fac * (2.0 * Ycm))

    DO i = 1, 5
      A1 = 1.0 / 8.0 * (Psite(i, 1) + Psite(i, 2) + Psite(i, 5) + Psite(i, 3) + &
                        Psite(i, 4) + Psite(i, 6) + Psite(i, 7) + Psite(i, 8))
      A2 = 1.0 / 4.0 * (Psite(i, 1) - Psite(i, 2) + Psite(i, 5) - Psite(i, 3))
      A3 = 1.0 / 4.0 * (Psite(i, 1) + Psite(i, 2) - Psite(i, 5) - Psite(i, 3))
      A4 = 1.0 / 4.0 * (Psite(i, 4) - Psite(i, 6) - Psite(i, 7) + Psite(i, 8))
      A5 = 1.0 / 4.0 * (Psite(i, 4) + Psite(i, 6) - Psite(i, 7) - Psite(i, 8))
      A6 = 1.0 / 8.0 * (Psite(i, 1) - Psite(i, 2) - Psite(i, 5) + Psite(i, 3) - &
                        Psite(i, 4) + Psite(i, 6) - Psite(i, 7) + Psite(i, 8))
      A7 = 1.0 / 8.0 * (Psite(i, 1) - Psite(i, 2) - Psite(i, 5) + Psite(i, 3) + &
                        Psite(i, 4) - Psite(i, 6) + Psite(i, 7) - Psite(i, 8))
      A8 = 1.0 / 16.0 * (Psite(i, 1) + Psite(i, 2) + Psite(i, 5) + Psite(i, 3) - &
                         Psite(i, 4) - Psite(i, 6) - Psite(i, 7) - Psite(i, 8))

      Vinter(i) = A1 * F1XY + A2 * F2XY + A3 * F3XY + A4 * F4XY + A5 * F5XY + A6 * F6XY + A7 * F7XY + A8 * F8XY
      IF ( i .EQ. 1 ) THEN
        Vinter(6) = A1 * dF1dX + A2 * dF2dX + A3 * dF3dX + A4 * dF4dX + A5 * dF5dX + A6 * dF6dX + A7 * dF7dX + A8 * dF8dX
        Vinter(7) = A1 * dF1dY + A2 * dF2dY + A3 * dF3dY + A4 * dF4dY + A5 * dF5dY + A6 * dF6dY + A7 * dF7dY + A8 * dF8dY
      END IF
    END DO
  END SUBROUTINE
END MODULE
