MODULE CRP_C3v_MoleculeSurface
  USE CRP_Constants
  USE CRP_GasPhase
  USE CRP_General
  USE CRP_C3v_AtomSurface
  USE Spline
  USE UnitConversion

  PRIVATE
  PUBLIC :: Initialize_CRP_C3v_MoleculeSurface_Module, &
            Initialize_CRP_C3v_MoleculeSurface_PES, &
            Calculate_CRP_C3v_MoleculeSurface_PES

  INTEGER, PARAMETER :: idf6 = 12, ids = 6
  REAL   :: fouri6D(idf6,idf6)

  INTEGER :: CRP_C3v_MoleculeSurface_Module_SetUp = 0

  INTERFACE Calculate_CRP_C3v_MoleculeSurface_PES
    MODULE PROCEDURE Calculate_CRP_C3v_MoleculeSurface_PES_Scalar, &
                     Calculate_CRP_C3v_MoleculeSurface_PES_Array
  END INTERFACE

CONTAINS

  SUBROUTINE Initialize_CRP_C3v_MoleculeSurface_Module()
    IMPLICIT NONE

    IF ( CRP_C3v_MoleculeSurface_Module_SetUp .LT. 1 ) THEN
      CRP_C3v_MoleculeSurface_Module_SetUp = 1
      CALL FOUR6D()
    END IF
  END SUBROUTINE

  SUBROUTINE Initialize_CRP_C3v_MoleculeSurface_PES( PES )
    IMPLICIT NONE

    TYPE (CRP_MoleculeSurface_PES) :: PES

    PES%ccDef = 0.500

    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
    ALLOCATE( PES%Cuts(N) )
    PES%Alloced = .TRUE.
    PES%NumCuts = N
    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_C3v_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_C3v_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

!************************ L E C T M O L 2 ****************************
!     READS the Interpolation Function from the file TOUT.DAT prepared
!     by PREPMOL.
!     LECTMOL2 defines the following values:
!       RMAX: maximum internuclear distance for which the potential can
!             be calculated (Angstroems). .
!       ZCCMIN: minimum distance from center of charge to surface
!               in molecular data (Ang.)
!*********************************************************************
  SUBROUTINE Read_MoleculeSurface_Data( PES )
    IMPLICIT NONE

    TYPE (CRP_MoleculeSurface_PES) :: PES
    INTEGER :: i, j, k
    REAL :: ucm, vcm, 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.00, 2, 0.00 )

    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
            ucm = PES%Cuts(k)%X * PES%Geometry%LatticeConstant
            vcm = PES%Cuts(k)%Y * PES%Geometry%LatticeConstant
            xcm = ucm + vcm / 2.0
            ycm = SQRT(3.0) * vcm / 2.0
            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_C3v_AtomSurface_PES( PES%AtomSurface, rab(2), rab(3), rab(1), Va, dX, dY, dZ, InternalUnits )
            CALL Calculate_CRP_C3v_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.52917724900
!   zccmin=zn(1)*0.52917724900
  END SUBROUTINE

!************************ F O U R 6 D ********************************
!     Matrix allowing to calculate the coefficients of the Fourier
!     interpolation for the 6D Interpolation Function.
!*********************************************************************
!  SUBROUTINE FOUR6D
!    IMPLICIT NONE
!
!    REAL, PARAMETER :: zer = 0.00, un = 1.00, mun = -un, deu = 2.00, mdeu = -deu
!    REAL, PARAMETER :: r1 = 1.00 / 12.00, sq3 = 1.732050807568877293500, r2 = sq3 * r1
!    REAL :: tour(idf6,idf6)
!    INTEGER :: i, j
!
!    DATA tour/12*un, &
!              deu, mdeu, deu, mdeu, mun, un, mun, un, mun, 2*un, mun, &
!              2*deu, 2*mdeu, mun, 2*un, mun, 2*un, 2*mun, &
!              deu, 2*mdeu, deu, 2*mun, 3*un, mun, un, mun, &
!              4*zer, 2*un, mun, 2*un, 3*mun, &
!              4*zer, 3*un, 3*mun, un, mun, &
!              4*zer, mun, un, 2*mun, un, mun, 2*un, &
!              2*un, 2*mun, un, 2*mun, un, 2*mun, 2*un, &
!              un, mun, un, mun, un, mun, un, mun, un, 2*mun, un, &
!              un, 2*mun, 3*un, 3*mun, un, mun, un, &
!              4*deu, 8*mun, &
!              4*zer, mun, 3*un, 3*mun, un/
!
!    DO i = 1, idf6
!      DO j = 1, 4
!        fouri6D(i, j) = r1 * tour(i, j)
!      END DO
!      DO j = 5, 7
!        fouri6D(i, j) = r2 * tour(i, j)
!      END DO
!      DO j = 8, 11
!        fouri6D(i, j) = r1 * tour(i, j)
!      END DO
!      DO j = 12, 12
!        fouri6D(i, j) = r2 * tour(i, j)
!      END DO
!    END DO
!  END SUBROUTINE

  SUBROUTINE FOUR6D
    IMPLICIT NONE

    REAL, PARAMETER :: zer = 0.00, un = 1.00, mun = -un, deu = 2.00, mdeu = -deu
    REAL, PARAMETER :: sq3 = 1.732050807568877293500, usq3 = 1.0 / sq3, r1 = usq3 / 4.00, r2 = 1.00 / 36.00
    REAL :: tour(idf6,idf6)
    INTEGER :: i, j

    DATA tour/12*un,                                                  &
         deu, mdeu, mun, un, mdeu, deu, mun, un, mun, un, mun, un,    &
         2*deu, mun, un, 2*mdeu, un, 2*mun, 2*un, mun,                &
         deu, mdeu, 2*mun, deu, mdeu, 2*un, 2*mun, 2*un,              &
         2*zer, 2*un, 2*zer, mun, un, 2*mun, un, mun,                 &
         2*zer, 2*un, 2*zer, un, 4*mun, un,                           &
         2*zer, mun, un, 2*zer, 2*mun, un, mun, 2*un,                 &
         3*un, 4*mun, 2*un, 2*mun, un,                                &
         un, mun, un, 2*mun, 2*un, mun, un, mun, un, mun,             &
         un, mun, 3*un, 3*mun, 2*un, 2*mun,                           &
         2*deu, 2*mun, 2*deu, 6*mun,                                  &
         2*zer, un, mun, 2*zer, 3*mun, 3*un/

    DO i = 1, idf6
      DO j = 1, 4
        fouri6D(i, j) = 3.0 * r2 * tour(i, j)
      END DO
      DO j = 5, 7
        fouri6D(i, j) = r1 * tour(i, j)
      END DO
      DO j = 8, 10
        fouri6D(i, j) = 3.0 * r2 * tour(i, j)
      END DO
      fouri6D(i, 11) = r2 * tour(i, 11)
      fouri6D(i, 12) = r1 / 3.0 * tour(i, 12)
    END DO
  END SUBROUTINE

!************************ R R I N T I I ******************************
  SUBROUTINE RRINTII( xa, ya, za, xb, yb, zb, Xcc, Ycc, Zcc, r, Theta, Phi, V, dVdXa, dVdYa, dVdZa, dVdXb, dVdYb, dVdZb, &
                      switch, PES )
    IMPLICIT NONE

    TYPE (CRP_MoleculeSurface_PES) :: PES

    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
    REAL, PARAMETER :: pis3 = CRP_Constants_PI / 3.00, pi2s3 = 2.00 * pis3
    INTEGER :: i
    LOGICAL :: switch

    REAL :: Vint(3, ids), Psite(5, idf6), Vinter(7)
    REAL :: dV2DinfR, dV2DinfZ, dXa, dXb, dYa, dYb, dZa, dZb, Fso, rho, rho2, va, vb, v2d

    switch = .FALSE.

    IF (Zcc .LT. PES%GasPhase%ZsoMax) THEN
!     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) )

!     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 - pis3, Vint, Psite(1, 6) )!3) ) !!!!!!!!!!!!!!!!!BUG fixed 09/03/2012 !!!!!!!!!!!!!!!!!!
      CALL InterpolateOnBridge( Theta, Phi + pis3, Vint, Psite(1, 5) )!4) ) !!!!!!!!!!!!!!!!!BUG fixed 09/03/2012 !!!!!!!!!!!!!!!!!!

!     Potential on hcp
      DO i = 8, 12
        CALL Evaluate_Spline2D_Alt( PES%Cuts(i)%Spline, r, Zcc, Vint(1, i - 7), switch )
        IF (switch) RETURN
      END DO
      CALL InterpolateOnHCP( Theta, Phi, Vint, Psite(1, 3) )!5) )

!     Potential on t2h
      DO i = 13, 18
        CALL Evaluate_Spline2D_Alt( PES%Cuts(i)%Spline, r, Zcc, Vint(1, i - 12), switch )
        IF (switch) RETURN
      END DO
      CALL InterpolateOnT2H( Theta, Phi, Vint, Psite(1, 4) )!6) )
      CALL InterpolateOnT2H( Theta, Phi - pi2s3, Vint, Psite(1, 7) )
      CALL InterpolateOnT2H( Theta, Phi + pi2s3, Vint, Psite(1, 8) )

!     Potential on t2f
      DO i = 19, 24
        CALL Evaluate_Spline2D_Alt( PES%Cuts(i)%Spline, r, Zcc, Vint(1, i - 18), switch )
        IF (switch) RETURN
      END DO
      CALL InterpolateOnT2F( Theta, Phi, Vint, Psite(1, 11) )!9) )
      CALL InterpolateOnT2F( Theta, Phi + pi2s3, Vint, Psite(1, 10) )!10) )
      CALL InterpolateOnT2F( Theta, Phi - pi2s3, Vint, Psite(1, 12) )!11) )

!     Potential on fcc
      DO i = 25, 29
        CALL Evaluate_Spline2D_Alt( PES%Cuts(i)%Spline, r, Zcc, Vint(1, i - 24), switch )
        IF (switch) RETURN
      END DO
      CALL InterpolateOnHCP( Theta, Phi, Vint, Psite(1, 9) )!12) )

!     Now do the interpolation over X and Y
      CALL SISII( Xcc, Ycc, Psite, Vinter, PES )

!     Transformation from (X, Y, Z, r, Theta, Phi) to atomic coordinates
      drXa = -(Xb - Xa) / r
      drXb = -drXa
      drYa = -(Yb - Ya) / r
      drYb = -drYa
      drZa = -(Zb - Za) / r
      drZb = -drZa
      rho2 = (Xb - Xa)**2 + (Yb - Ya)**2
      rho = SQRT(rho2)
      IF (rho2 .GT. 0.00) THEN
        dThetaXa = -(Zb - Za) * (Xb - Xa) / (r * r * rho)
        dThetaYa = -(Zb - Za) * (Yb - Ya) / (r * r * rho)
        dPhiXa = (Yb - Ya) / rho2
        dPhiYa = -(Xb - Xa) / rho2
      ELSE
        dThetaXa = 0.00
        dThetaYa = 0.00
        dPhiXa = 0.00
        dPhiYa = 0.00
      END IF
      dThetaZa = rho / (r * r)
      dThetaXb = -dThetaXa
      dThetaYb = -dThetaYa
      dThetaZb = -dThetaZa
      dPhiXb = -dPhiXa
      dPhiYb = -dPhiYa

      CALL Calculate_CRP_C3v_AtomSurface_PES( PES%AtomSurface, Xa, Ya, Za, Va, dXa, dYa, dZa, InternalUnits )
      CALL Calculate_CRP_C3v_AtomSurface_PES( PES%AtomSurface, Xb, Yb, Zb, Vb, dXb, dYb, dZb, InternalUnits )

      IF (Zcc .LE. PES%GasPhase%ZsoMin) THEN
        V = Va + Vb + Vinter(1)
!        V = Va 
!EWF
!EWF
!        OPEN( 100, FILE="pot.dat", STATUS="unknown" )
!        WRITE(100, *) Xcc, Ycc, Zcc, r, Theta, Phi, V, Va, Vb, Vinter(1)
!        CLOSE( 100 )
!        PRINT *,"pot", Xcc, Ycc, Zcc, r, Theta, Phi, V, Va, Vb, Vinter(1)
!        PRINT *, "Z= ", Za, Zb, "Zcc=", Zcc, "r=", r

        dVdXa = dXa + 0.500 * Vinter(6) + drXa * Vinter(3) + dThetaXa * Vinter(5) + dPhiXa * Vinter(4)
        dVdXb = dXb + 0.500 * Vinter(6) + drXb * Vinter(3) + dThetaXb * Vinter(5) + dPhiXb * Vinter(4)
        dVdYa = dYa + 0.500 * Vinter(7) + drYa * Vinter(3) + dThetaYa * Vinter(5) + dPhiYa * Vinter(4)
        dVdYb = dYb + 0.500 * Vinter(7) + drYb * Vinter(3) + dThetaYb * Vinter(5) + dPhiYb * Vinter(4)
        dVdZa = dZa + 0.500 * Vinter(2) + drZa * Vinter(3) + dThetaZa * Vinter(5)
        dVdZb = dZb + 0.500 * 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.00 - Fso) * V2D
        dFsodZa = 0.500 * dFso
        dFsodZb = 0.500 * dFso
        dVdXa = (dXa + 0.500 * Vinter(6) + drXa * Vinter(3) + dThetaXa * Vinter(5) + &
                 dPhiXa * Vinter(4)) * Fso + (1.00 - Fso) * dV2Dinfr * drXa
        dVdXb = (dXb + 0.500 * Vinter(6) + drXb * Vinter(3) + dThetaXb * Vinter(5) + &
                 dPhiXb * Vinter(4)) * Fso + (1.00 - Fso) * dV2Dinfr * drXb
        dVdYa = (dYa + 0.500 * Vinter(7) + drYa * Vinter(3) + dThetaYa * Vinter(5) + &
                 dPhiYa * Vinter(4)) * Fso + (1.00 - Fso) * dV2Dinfr * drYa
        dVdYb = (dYb + 0.500 * Vinter(7) + drYb * Vinter(3) + dThetaYb * Vinter(5) + &
                 dPhiYb * Vinter(4)) * Fso + (1.00 - Fso) * dV2Dinfr * drYb
        dVdZa = (dZa + 0.500 * Vinter(2) + drZa * Vinter(3) + dThetaZa * Vinter(5)) &
                 * Fso + (Va + Vb + Vinter(1)) * dFsodZa - dFsodZa * V2D + &
                  (1.00 - Fso) * (dV2DinfZ * 0.500 + drZa * dV2DinfR)
        dVdZb = (dZb + 0.500 * Vinter(2) + drZb * Vinter(3) + dThetaZb * Vinter(5)) &
                 * Fso + (Va + Vb + Vinter(1)) * dFsodZb - dFsodZb * V2D + &
                  (1.00 - Fso) * (dV2DinfZ * 0.500 + 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.500 * dV2DinfZ + drZa * dV2DinfR
      dVdZb = 0.500 * dV2DinfZ + drZb * dV2DinfR
    END IF
  END SUBROUTINE

!************************ S I S I I **********************************
!     Calculation of the 6D interpolation function as well as its
!     first and second derivatives using the Fourier series expansion.
!     The position the molecule center of charge is xcc,ycc.
!     PSITE: input. Contains the function and its derivatives with
!            respect to r,Z,phi and theta (first index up to 5, see
!            below for definition) for various sites labelled with
!            the second index.
!     FOURI6D: comes from the solution of the linear system associated
!              with the Fourier expansion and reference sites. It is
!              calculated in FOUR6D which must be called once before
!              the first call to SISII
!     VINTER is the output.
!     The index corresponds to: 1: function, 2: d/dr, 3: d/dZ,
!     4: d/d(phi), 5: d/d(theta), 6: d/dX, 7: d/dY.
!       Based on SIS12x12 by H.F. Busnengo
!       Version 1.0     A. Salin             07/02/02
!*********************************************************************
  SUBROUTINE SISII( Xcc, Ycc, Psite, Vinter, PES )
    IMPLICIT NONE

    TYPE (CRP_MoleculeSurface_PES) :: PES

    REAL :: a(idf6), Psite(5,idf6), Fxy(idf6), dFdX(idf6), dFdY(idf6)
    REAL :: Vinter(7)
    REAL :: Xcc, Ycc
    INTEGER          :: i, j, ksit

    CALL FOUR6II( Xcc, Ycc, Fxy, dFdX, dFdY, PES )

!   Calculate the potential energy and the first derivatives with respect to X and Y
    Vinter(1) = 0.00
    Vinter(6) = 0.00
    Vinter(7) = 0.00

    DO j = 1, idf6
      a(j) = 0.00
      DO ksit = 1, idf6
        a(j) = a(j) + fouri6D(ksit, j) * Psite(1, ksit)
      END DO

      Vinter(1) = Vinter(1) + a(j) * Fxy(j)
      Vinter(6) = Vinter(6) + a(j) * dFdX(j)
      Vinter(7) = Vinter(7) + a(j) * dFdY(j)
    END DO

!   First order derivatives with respect to r, Z, phi, theta
    DO i = 2, 5
      Vinter(i) = 0.00
      DO j = 1, idf6
        a(j) = 0.00
        DO ksit = 1, idf6
          a(j) = a(j) + fouri6D(ksit, j) * Psite(i, ksit)
        END DO
        Vinter(i) = Vinter(i) + a(j) * Fxy(j)
      END DO
    END DO
  END SUBROUTINE

!************************ F O U R 6 I I ******************************
!     Calculates the basis functions of the Fourier expansion and
!     their derivatives with respect to X and Y.
!*********************************************************************
  SUBROUTINE FOUR6II( Xcc, Ycc, Fxy, dFdX, dFdY, PES )
    IMPLICIT NONE

    TYPE (CRP_MoleculeSurface_PES) :: PES

    REAL :: sq3, usq3
    PARAMETER(sq3=1.732050807568877293500,usq3=1.00/sq3)

    REAL :: Fxy(idf6), dFdX(idf6), dFdY(idf6)
    REAL :: Xcc, Ycc, BigX, BigY, fBigX, fBigY, fac, c2x, c2y, c2xy, s2x, s2y, s2xy
    INTEGER :: i

!   WARNING: check carefully units for delta (interatomic distance)
!   ========

    fac = 2.00 * CRP_Constants_PI / PES%Geometry%LatticeConstant
    BigX = Xcc - Ycc * usq3
    BigY = 2.00 * Ycc * usq3
    fBigX = fac * BigX
    fBigY = fac * BigY

    c2x = COS(2.00 * fBigX)
    c2y = COS(2.00 * fBigY)
    c2xy = COS(2.00 * (fBigX + fBigY))
    s2x = SIN(2.00 * fBigX)
    s2y = SIN(2.00 * fBigY)
    s2xy = SIN(2.00 * (fBigX + fBigY))

!   Basis functions
    Fxy(1) = 1.00
    Fxy(2) = COS(fBigX)
    Fxy(3) = COS(fBigY)
    Fxy(4) = COS(fBigX + fBigY)
    Fxy(5) = SIN(fBigX)
    Fxy(6) = SIN(fBigY)
    Fxy(7) = SIN(fBigX + fBigY)
    Fxy(8) = COS(2.00 * fBigX + fBigY)
    Fxy(9) = COS(fBigX + 2.00 * fBigY)
    Fxy(10) = COS(fBigX - fBigY)
    Fxy(11) = c2x + c2y + c2xy ! was: c2x
    Fxy(12) = -s2x - s2y + s2xy ! was: s2x

!   Derivatives with respect to crystal coordinates
    dFdX(1) = 0.00
    dFdX(2) = -fac * Fxy(5)
    dFdX(3) = 0.00
    dFdX(4) = -fac * Fxy(7)
    dFdX(5) = fac * Fxy(2)
    dFdX(6) = 0.00
    dFdX(7) = fac * Fxy(4)
    dFdX(8) = -2.00 * fac * SIN(2.00 * fBigX + fbigY)
    dFdX(9) = -fac * SIN(fBigX + 2.00 * fBigY)
    dFdX(10) = -fac * SIN(fBigX - fBigY)
    dFdX(11) = -2.0 * fac * (s2x + s2xy) ! was: -2.00 * fac * s2x
    dFdX(12) = 2.0 * fac * (-c2x + c2xy) ! was: 2.00 * fac * c2x

    dFdY(1) = 0.00
    dFdY(2) = 0.00
    dFdY(3) = -fac * Fxy(6)
    dFdY(4) = -fac * Fxy(7)
    dFdY(5) = 0.00
    dFdY(6) = fac * Fxy(3)
    dFdY(7) = fac * Fxy(4)
    dFdY(8) = 0.500 * dFdX(8)
    dFdY(9) = 2.00 * dFdX(9)
    dFdY(10) = -dFdX(10)
    dFdY(11) = -2.0 * fac * (s2y + s2xy) ! was: 0.00
    dFdY(12) = 2.0 * fac * (-c2y + c2xy) ! was: 0.00

!   Derivatives with respect to cartesian coordinates
    DO i = 1, 12
      dFdY(i) = (-dFdX(i) + 2.00 * dFdY(i)) * usq3
    END DO
  END SUBROUTINE

!************************ V T O P I I ********************************
!     VINT: first index= pot, d/dr, d/dZ.
!           second index= top site geometry (teta=0; teta=90,fi=0;
!            theta=90,fi=30)
!     On output, PSITE contains potential and derivatives for
!     the given value of TETA and FI.
!     The index corresponds to: 1: function, 2: d/dr, 3: d/dZ,
!     4: d/d(phi), 5: d/d(theta).
!*********************************************************************
  SUBROUTINE InterpolateOnTop( Theta, Phi, Vint, Psite )
    IMPLICIT NONE

    REAL :: Theta, Phi
    REAL :: Vint(3, 3), Psite(5)
    REAL :: Cos6Phi, Sin6Phi, Cos2The, Sin2The
    REAL :: V0, V90, dV90dPhi
    INTEGER          :: i

    Cos6Phi = COS(6.00 * Phi)
    Sin6Phi = SIN(6.00 * Phi)
    Cos2The = COS(2.00 * Theta)
    Sin2The = SIN(2.00 * Theta)

    DO i = 1, 3
      V0 = Vint(i, 1)
      V90 = 0.500 * ((Vint(i, 2) + Vint(i, 3)) + (Vint(i, 2) - Vint(i, 3)) * Cos6Phi )

      ! Potential and first derivatives over r and Z
      Psite(i) = 0.500 * ((V0 + V90) + (V0 - V90) * Cos2The)

      ! First derivatives over phi and theta
      IF (i .EQ. 1) THEN
        dV90dPhi = -3.00 * (Vint(1, 2) - Vint(1, 3)) * Sin6Phi
        Psite(4) = 0.500 * dV90dPhi * (1.00 - Cos2The)
        Psite(5) = -(V0 - V90) * Sin2The
      END IF
    END DO
  END SUBROUTINE

!********************** V B R I I I **********************************
!     VINT: first index= pot, d/dr, d/dZ.
!        second index= bridge site geometry (theta=0; theta=pi/2,fi=0;
!                      theta=pi/2,fi=pi/3; theta=pi/2,fi=pi/2)
!     On output, PSITE contains potential and derivatives for
!     the given value of TETA and FI.
!     The index corresponds to: 1: function, 2: d/dr, 3: d/dZ,
!     4: d/d(phi), 5: d/d(theta).
!*********************************************************************
  SUBROUTINE InterpolateOnBridge( Theta, Phi, Vint, Psite )
    IMPLICIT NONE

    REAL, PARAMETER :: u3 = 1.00 / 3.00

    REAL :: Theta, Phi
    REAL :: Vint(3, 4), Psite(5)
    REAL :: Cos2Phi, Sin2Phi, Cos4Phi, Sin4Phi, Cos2The, Sin2The
    REAL :: V0, V90, dV90dPhi
    INTEGER          :: i

    Cos2Phi = COS(2.00 * Phi)
    Sin2Phi = SIN(2.00 * Phi)
    Cos4Phi = COS(4.00 * Phi)
    Sin4Phi = SIN(4.00 * Phi)
    Cos2The = COS(2.00 * Theta)
    Sin2The = SIN(2.00 * Theta)

    DO i = 1, 3
      V0 = Vint(i, 1)
      V90 = (Vint(i, 2) + 2.00 * Vint(i, 3)) * u3 - 0.500 * (Vint(i, 4) - Vint(i, 2)) * Cos2Phi + &
            (0.500 * (Vint(i, 4) - Vint(i, 2)) - 2.00 * (Vint(i, 3) - Vint(i, 2)) * u3) * Cos4Phi

      ! Potential and first derivatives over r and Z
      Psite(i) = 0.500 * (V0 * (1.00 + Cos2The) + V90 * (1.00 - Cos2The))

      ! First derivatives over phi and theta
      IF (i .EQ. 1) THEN
        dV90dPhi = (Vint(1, 4) - Vint(1, 2)) * Sin2Phi - (2.00 * (Vint(1, 4) - Vint(1,2)) - &
                   8.00 * (Vint(1, 3) - Vint(1, 2)) * u3) * Sin4Phi
        Psite(4) = 0.500 * dV90dPhi * (1.00 - Cos2The)
        Psite(5) = (V90 - V0) * Sin2The
      END IF
    END DO
  END SUBROUTINE
!************************ V H C P I I ********************************
!     vint: first index= pot, d/dr, d/dZ.
!           second index= fcc site geometry (theta=0; theta=90,fi=0;
!           theta=90,fi=30; theta=45,phi=30;
!           theta=45,phi=210))
!     On output, PSITE contains potential and derivatives for
!     the given value of TETA and FI.
!     The index corresponds to: 1: function, 2: d/dr, 3: d/dZ,
!     4: d/d(phi), 5: d/d(theta).
!*********************************************************************
  SUBROUTINE InterpolateOnHCP( Theta, Phi, Vint, Psite )
    IMPLICIT NONE

    REAL :: Theta, Phi
    REAL :: Vint(3, 5), Psite(5)
    REAL :: Cos3Phi, Sin3Phi, Cos6Phi, Sin6Phi, Cos2The, Sin2The, Cos4The, Sin4The
    REAL :: V0, V45, V90, V135, dV45dPhi, dV90dPhi
    INTEGER          :: i

    Cos3Phi = COS(3.00 * Phi)
    Sin3Phi = SIN(3.00 * Phi)
    Cos6Phi = COS(6.00 * Phi)
    Sin6Phi = SIN(6.00 * Phi)
    Cos2The = COS(2.00 * Theta)
    Sin2The = SIN(2.00 * Theta)
    Cos4The = COS(4.00 * Theta)
    Sin4The = SIN(4.00 * Theta)

    DO i = 1, 3
      V0 = Vint(i, 1)
      V45 = 0.500 * ((Vint(i, 4) + Vint(i, 5)) + (Vint(i, 4) - Vint(i, 5)) * Sin3Phi)
      V135 = 0.500 * ((Vint(i, 4) + Vint(i, 5)) - (Vint(i, 4) - Vint(i, 5)) * Sin3Phi)
      V90 = 0.500 * ((Vint(i, 2) + Vint(i, 3)) + (Vint(i, 2) - Vint(i, 3)) * Cos6Phi)

      ! Potential and first derivatives over r and Z
      Psite(i) = 0.2500 * ((V0 + V45 + V90 + V135) + (V0 + V90 - V45 - V135) * Cos4The ) + &
                 0.500 * ((V0 - V90) * Cos2The + (V45 - V135) * Sin2The)

      ! First derivatives over phi and theta
      IF (i .EQ. 1) THEN
        dV45dPhi = 1.500 * (Vint(i, 4) - Vint(i, 5)) * Cos3Phi
        dV90dPhi = -3.00 * (Vint(i, 2) - Vint(i, 3)) * Sin6Phi
        Psite(4) = dV90dPhi * (0.2500 * (1.00 + Cos4The) - 0.500 * Cos2The) + dV45dPhi * Sin2The
        Psite(5) = -(V0 - V90) * Sin2The + (V45 - V135) * Cos2The - (V0 + V90 - V45 - V135) * Sin4The
      END IF
    END DO
  END SUBROUTINE

!*********************** V T 2 H I I *********************************
!     VINT: first index= pot, d/dr, d/dZ.
!       second index= t2h site geometry (theta=0; theta=pi/2,fi=2pi/3;
!        theta=pi/2,fi=2pi/3; theta=45,fi=30; theta=45,fi=120;
!        theta=45,fi=210)
!     On output, PSITE contains potential and derivatives for
!     the given value of TETA and FI.
!     The index corresponds to: 1: function, 2: d/dr, 3: d/dZ,
!     4: d/d(phi), 5: d/d(theta).
!*********************************************************************
  SUBROUTINE InterpolateOnT2H( Theta, Phi, Vint, Psite )
    IMPLICIT NONE

    REAL, PARAMETER :: pis6 = CRP_Constants_PI / 6.00

    REAL :: Theta, Phi
    REAL :: Vint(3, 6), Psite(5)
    REAL :: Phip6, CosPhi, SinPhi, Cos2Phi, Sin2Phi, Cos2The, Sin2The, Cos4The, Sin4The
    REAL :: V0, V45, V90, V135, dV90dPhi, dV45dPhi, dV135dPhi
    INTEGER          :: i

    Phip6 = Phi - pis6
    CosPhi = COS(Phip6)
    SinPhi = SIN(Phip6)
    Cos2Phi = COS(2.00 * Phip6)
    Sin2Phi = SIN(2.00 * Phip6)
    Cos2The = COS(2.00 * Theta)
    Sin2The = SIN(2.00 * Theta)
    Cos4The = COS(4.00 * Theta)
    Sin4The = SIN(4.00 * Theta)

    DO i = 1, 3
      V0 = Vint(i, 1)
      V45 = 0.2500 * ((Vint(i, 4) + 2.00 * Vint(i, 5) + Vint(i, 6)) &
                  + (Vint(i, 4) - 2.00 * Vint(i, 5) + Vint(i, 6)) * Cos2Phi ) &
                  + 0.500 * (Vint(i, 4) - Vint(i, 6)) * CosPhi
      V135 = 0.2500 * ((Vint(i, 4) + 2.00 * Vint(i, 5) + Vint(i, 6)) &
                  + (Vint(i, 4) - 2.00 * Vint(i, 5) + Vint(i, 6)) * Cos2Phi ) &
                  - 0.500 * (Vint(i, 4) - Vint(i, 6)) * CosPhi
      V90 = 0.500 * ((Vint(i, 2) + Vint(i, 3)) + (Vint(i, 2) - Vint(i, 3)) * Cos2Phi )

      ! Potential and first derivatives over r and Z
      Psite(i) = 0.2500 * ((V0 + V45 + V90 + V135) + (V0 + V90 - V45 - V135) * Cos4The ) + &
                 0.500 * ((V0 - V90) * Cos2The + (V45 - V135) * Sin2The)

      ! First derivatives over phi and theta
      IF (i .EQ. 1) THEN
        dV45dPhi = -0.500 * ((Vint(i, 4) - Vint(i, 6)) * SinPhi + (Vint(i, 4) - 2.00 * Vint(i, 5) + Vint(i, 6)) * Sin2Phi)
        dV135dPhi = 0.500 * ((Vint(i, 4) - Vint(i, 6)) * SinPhi - (Vint(i, 4) - 2.00 * Vint(i, 5) + Vint(i, 6)) * Sin2Phi)
        dV90dPhi = -(Vint(i, 2) - Vint(i, 3)) * Sin2Phi
        Psite(4) = 0.2500 * ((dV45dPhi + dV90dPhi + dV135dPhi) + (dV90dPhi - dV45dPhi - dV135dPhi) * Cos4The) + &
                   0.500 * ((-dV90dPhi) * Cos2The + (dV45dPhi - dV135dPhi) * Sin2The)
        Psite(5) = -(V0 - V90) * Sin2The + (V45 - V135) * Cos2The - (V0 + V90 - V45 - V135) * Sin4The
      END IF
    END DO
  END SUBROUTINE

!*********************** V T 2 F I I *********************************
!     VINT: first index= pot, d/dr, d/dZ.
!       second index= t2f site geometry (theta=0; theta=90,fi=240;
!        theta=90,fi=330; theta=45,fi=150; theta=45,fi=240;
!        theta=45,fi=330)
!     On output, PSITE contains potential and derivatives for
!     the given value of TETA and FI.
!     The index corresponds to: 1: function, 2: d/dr, 3: d/dZ,
!     4: d/d(phi), 5: d/d(theta).
!*********************************************************************
  SUBROUTINE InterpolateOnT2F( Theta, Phi, Vint, Psite )
    IMPLICIT NONE

    REAL, PARAMETER :: pis6 = CRP_Constants_PI / 6.00

    REAL :: Theta, Phi
    REAL :: Vint(3, 6), Psite(5)
    REAL :: Phip6, CosPhi, SinPhi, Cos2Phi, Sin2Phi, Cos2The, Sin2The, Cos4The, Sin4The
    REAL :: V0, V45, V90, V135, dV45dPhi, dV90dPhi, dV135dPhi
    INTEGER          :: i

    Phip6 = Phi - 11.00 * pis6
    CosPhi = COS(Phip6)
    SinPhi = SIN(Phip6)
    Cos2Phi = COS(2.00 * Phip6)
    Sin2Phi = SIN(2.00 * Phip6)
    Cos2The = COS(2.00 * Theta)
    Sin2The = SIN(2.00 * Theta)
    Cos4The = COS(4.00 * Theta)
    Sin4The = SIN(4.00 * Theta)

    DO i = 1, 3
      V0 = Vint(i, 1)
      V45 = 0.2500 * ((Vint(i, 4) + 2.00 * Vint(i, 5) + Vint(i, 6)) &
                  + (Vint(i, 4) - 2.00 * Vint(i, 5) + Vint(i, 6)) * Cos2Phi) &
                  + 0.500 * (-Vint(i, 4) + Vint(i, 6)) * CosPhi
      V135 = 0.2500 * ((Vint(i, 4) + 2.00 * Vint(i, 5) + Vint(i, 6)) &
                  + (Vint(i, 4) - 2.00 * Vint(i, 5) + Vint(i, 6)) * Cos2Phi) &
                  - 0.500 * (-Vint(i, 4) + Vint(i, 6)) * CosPhi
      V90 = 0.500 * ((Vint(i, 2) + Vint(i, 3)) + (-Vint(i, 2) + Vint(i, 3)) * Cos2Phi)

!     Potential and first derivatives over r and Z
      psite(i)= 0.2500 * ((V0 + V45 + V90 + V135) + (V0 + V90 - V45 - V135) * Cos4The) + &
                0.500 * ((V0 - V90) * Cos2The + (V45 - V135) * Sin2The)

!     First derivatives over phi and theta
      IF (i .EQ. 1) THEN
        dv45dPhi = -0.500 * ((-Vint(i, 4) + Vint(i, 6)) * SinPhi + (Vint(i, 4) - 2.00 * Vint(i, 5) + Vint(i, 6)) * Sin2Phi)
        dv135dPhi = 0.500 * ((-Vint(i, 4) + Vint(i, 6)) * SinPhi - (Vint(i, 4) - 2.00 * Vint(i, 5) + Vint(i, 6)) * Sin2Phi)
        dv90dPhi = -(-Vint(i, 2) + Vint(i, 3)) * Sin2Phi
        Psite(4) = 0.2500 * ((dV45dPhi + dV90dPhi + dV135dPhi) + (dV90dPhi - dV45dPhi - dV135dPhi) * Cos4The) + &
                   0.500 * ((-dV90dPhi) * Cos2The + (dV45dPhi - dV135dPhi) * Sin2The)
        Psite(5) = -(V0 - V90) * Sin2The + (V45 - V135) * Cos2The - (V0 + V90 - V45 - V135) * Sin4The
      END IF
    END DO
  END SUBROUTINE

!************************ P O T 6 D ***********************************
!     This routine computes the 6D potential and the corresponding
!     derivatives of the interaction potential of a diatomic homonuclear
!     molecule interacting with the 111 surface of a FCC cristal.
!     The method employed is the interpolation of ab initio data obtained
!     on different 2D (Z,r) regular grids corresponding to various
!     molecular configurations.
!
!     Configurations employed (29)
!
!     The interpolation method uses the Corrugation Reducing Procedure (CRP).
!
!     Before calling this routine, it is necessary to call
!     the routine LECTURE where all input data are read.
!
!     The meaning of the components of RAB is:
!     RAB(1)=Z_A, RAB(2)=X_A, RAB(3)=Y_A,
!     RAB(4)=Z_B, RAB(5)=X_B, RAB(6)=Y_B

!---------------------------------------------------------------------
!     Units
!---------------------------------------------------------------------
!     Calculations in RRINTII are done in Angstroems for distances and
!     eV for energies.

!     IUNIT fixes the units used for the input to POT6D and for the
!     output (potential an derivatives) to the calling program.

!     IUNIT=1
!     RAB is given in Angstroems on input to POT6D. The output is given
!     in Angstroems for distances and eV for energies.

!     IUNIT=2:
!     RAB is given in atomic units on input to POT6D. The output is
!     given in atomic units (energies and distances)

!     Beware that the unit for DELTA is given independently.

!---------------------------------------------------------------------
!
!     In this routine it is supposed that the cartesian coordinate system
!     used by the main program is the following:
!
!          y^
!           |
!           |
!         * | *
!       *   *---*--->
!         *   *     x
!
!     The logical variable SWITCH is used to indicate (on OUTPUT)
!     possible problems in the interpolation.
!     SWITCH=.FALSE.: everything is OK.
!     SWITCH=.TRUE. means that the potential cannot be computed for the
!     given value of RAB. This happens, e.g., when RAB is outside the
!     range in which the interpolation is defined.
!     ------------------------------------------------------------------
  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.00
    dVdXa = 0.00
    dVdYa = 0.00
    dVdZa = 0.00
    dVdXb = 0.00
    dVdYb = 0.00
    dVdZb = 0.00

    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 RRINTII( Xa, Ya, Za, Xb, Yb, Zb, Xcc, Ycc, Zcc, ro, Theta, Phi, &
                  PotV, dVdXa, dVdYa, dVdZa, dVdXb, dVdYb, dVdZb, switch, PES )

!     The potential provided by this routine
!     for the molecule far from the surface and for the H_2 equilibrium
!     distance in the vacuum (r=0.75 Angstroems) is equal to zero.
  END SUBROUTINE
END MODULE

