c
c***********************************************************************
c     eecchg
c***********************************************************************
c
      subroutine eecchg(e1,e2,e12,chg1,chg2,chg12)         
c
c     This subroutine combine the three terms in EE-MCMM charges
c     calculation and returns the EE-MCMM charges. 
c     It is a modification of subroutine mccgra
c
      implicit double precision (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      dimension chg1(mcmatm), chg2(mcmatm), chg12(mcmatm)
c 
c If e12=0, then take dxii as the g1 (if e1<e2) or g2 (if e2<e1)
c (this is done to avoid divisions by zero). Thus, if e12=0, dxii is the
c gradient calculated at the surface with a lower energy at that point.
c Supposedly, this could only happen at the molecular mechanics Shepard
c points.
c
      if (abs(e12).lt.1.0d-07) then                                            
         if (abs(e1-e2).lt.1.0D-07) then
c
c If e12=0 and e1=e2 (which I think is impossible, unless the calculation
c is completely screwed up) dxii is the sum of the two gradients, g1 and g2
c
            do 120 i=1,mcnatm
c 1028HL03s
c I think it is the averaged value rather than the sum                  1201HL03
               chgr(i)=0.5d+00*(chg2(i)+chg1(i))                        1201HL03
c 1028HL03e
 120        continue

         else if (e1.lt.e2) then
            do 100 i=1,mcnatm
               chgr(i)=chg1(i)
 100        continue
         else if (e2.lt.e1) then
            do 110 i=1,mcnatm
               chgr(i)=chg2(i)
 110        continue
         endif
      else                            
c
         if(icomplex.eq.0) then
c
c     ----- Hermitian EE-MCSI -----
c
c     If e12 is not 0, calculate dxii using the MCMM formula
c
            fctor1=dsqrt((e1-e2)**2.0D+00+4.0d+00*e12*e12)
c
            do 200 i=1,mcnatm
               sum1=chg1(i)+chg2(i)
               dif1=chg1(i)-chg2(i)
               fctor2=(e1-e2)*dif1+4.0d+00*e12*chg12(i) 
c
c     calculate the charges
c
               chgr(i)=0.5d+00*(sum1-fctor2/fctor1)
 200        continue
c
         else
c
c     ----- Non-Hermitian EE-MCSI -----
c
            ee1=4.d0*e12
            diffe=e1-e2
            diffes=diffe**2.0
            if (e12.lt.0.d0) then
               if (abs(ee1).ge.diffes) then
                  do i=1,mcnatm
                     chgr(i)=0.5d0*(chg1(i)+chg2(i))
                  enddo
               else
                  fctor1=dsqrt(diffes+4.d0*e12)
                  do i=1,mcnatm
                     sum1=chg1(i)+chg2(i)
                     dif1=chg1(i)-chg2(i)
                     fctor2=diffe*dif1+2.d0*chg12(i)
                     chgr(i)=0.5d0*(sum1-fctor2/fctor1)
                  enddo
               endif
            else
               fctor1=dsqrt(diffes+4.d0*e12)
               do i=1,mcnatm
                  sum1=chg1(i)+chg2(i)
                  dif1=chg1(i)-chg2(i)
                  fctor2=diffe*dif1+2.d0*chg12(i)
                  chgr(i)=0.5d0*(sum1-fctor2/fctor1)
               enddo
            endif
         endif
      endif
c
      return
      end
c
c***********************************************************************
c     eecdqr
c***********************************************************************
c
      subroutine eecdqr(e1,e2,e12,g1,g2,g12,chg1,chg2,chg12,dqdr12)
c
c     This subroutine combine the three terms in EE-MCMM DQDR
c     calculation and returns the EE-MCMM DQDR
c     It is a modification of subroutine mcches
c
      implicit double precision (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      dimension g1(mcmcar), g2(mcmcar), g12(mcmcar)
      dimension chg1(mcmatm), chg2(mcmatm), chg12(mcmatm)
      dimension dqdr12(mcmcar,mcmatm)
c
      mcncar=3*mcnatm
c
c If e12=0, then take the hessian as the h1 (if e1<e2) or h2 (if e2<e1)
c (this is done to avoid divisions by zero). Thus, if e12=0, the hessian is 
c the one calculated at the surface with a lower energy at that point.
c Supposedly, this could only happen at the molecular mechanics Shepard
c points.
c
      if (abs(e12).lt.1.0d-07) then                         
         if (abs(e1-e2).lt.1.0d-07) then
c
c although unlikely, just in case e1 = e2 and e12=0 , fmat=h1+h2
c
            do 140 i=1,mcncar
               do 150 j=1,mcnatm
c 1028HL03s    
c I think it is the averaged value rather than the sum                  1201HL03
                  dqdrr(i,j)=0.5d+00*(dqdrr0(i,j,1)+dqdrr0(i,j,2))      1201HL03
c 1028HL03e
 150           continue
 140        continue

         else if (e1.lt.e2) then
            do 100 i=1,mcncar
               do 110 j=1,mcnatm
                  dqdrr(i,j)=dqdrr0(i,j,1)
 110           continue
 100        continue
         else if (e2.lt.e1) then
            do 120 i=1,mcncar
               do 130 j=1,mcnatm
                  dqdrr(i,j)=dqdrr0(i,j,2)
 130           continue
 120        continue
         end if
      else
c
         if (icomplex.eq.0) then
c
c     ----- Hermitian EE-MCSI -----
c
c
c If e12 is not 0, calculate the hessian using the MCMM formula
c     
            dife=e1-e2
            fctor1=dsqrt(dife*dife+4.0d+00*e12*e12)
c
            do 200 i=1,mcncar
               difgi=g1(i)-g2(i)
               fctori=dife*difgi+4.0d+00*e12*g12(i) 
            do 210 j=1,mcnatm
               difgj=chg1(j)-chg2(j)
               fctorj=dife*difgj+4.0d+00*e12*chg12(j) 
               sumh=dqdrr0(i,j,1)+dqdrr0(i,j,2)
               difh=dqdrr0(i,j,1)-dqdrr0(i,j,2)
               dqdrr(i,j)=0.5d+00*(sumh+fctori*fctorj/(fctor1**3.0d+00)
     &                   -(4.0d0*(g12(i)*chg12(j)+e12*dqdr12(i,j))
     &                    +difgi*difgj+dife*difh)/fctor1)
 210        continue
 200        continue
c
         else
c
c     ----- Non-Hermitian EE-MCSI -----
c
            ee1=4.0d+00*e12
            dife=e1-e2
            difes=dife*dife
c
            if ((e12.lt.0.0d+00).and.(difes.lt.abs(ee1))) then
c
               do i=1,mcncar
               do j=1,mcnatm
                  dqdrr(i,j)=0.5d+00*(dqdrr0(i,j,1)+dqdrr0(i,j,2))
               enddo
               enddo
c
            else
c
               fctor1=dsqrt(difes+ee1)
c
               do i=1,mcncar
                  difgi=g1(i)-g2(i)
                  fctori=dife*difgi+2.0d+00*g12(i) 
               do j=1,mcnatm
                  difgj=chg1(j)-chg2(j)
                  fctorj=dife*difgj+2.0d+00*chg12(j) 
                  sumh=dqdrr0(i,j,1)+dqdrr0(i,j,2)
                  difh=dqdrr0(i,j,1)-dqdrr0(i,j,2)
                  dqdrr(i,j)=0.5d+00*(sumh
     &           +fctori*fctorj/(fctor1**3.0d+00)
     &           -(difgi*difgj+dife*difh
     &           +2.0d+00*dqdr12(i,j))/fctor1)
               enddo
               enddo
c
            end if
c
         end if
c
      endif
c          
      return
      end
c
c***********************************************************************
c     eecdqv
c***********************************************************************
c
      subroutine eecdqv(e1,e2,e12,chg1,chg2,chg12,dqdv12)
c
c     This subroutine combine the three terms in EE-MCMM DQDPHI
c     calculation and returns the EE-MCMM DQDPHI. 
c     It is a modification of subroutine mcches
c
      implicit double precision (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      dimension chg1(mcmatm), chg2(mcmatm), chg12(mcmatm)
      dimension dqdv12(mcmatm,mcmatm)
c
c If e12=0, then take the hessian as the h1 (if e1<e2) or h2 (if e2<e1)
c (this is done to avoid divisions by zero). Thus, if e12=0, the hessian is 
c the one calculated at the surface with a lower energy at that point.
c Supposedly, this could only happen at the molecular mechanics Shepard
c points.
c
      if (abs(e12).lt.1.0d-07) then                         
         if (abs(e1-e2).lt.1.0d-07) then
c
c although unlikely, just in case e1 = e2 and e12=0 , fmat=h1+h2
c
            do 140 i=1,mcnatm
               do 150 j=1,mcnatm
c 1028HL03s    
c I think it is the averaged value rather than the sum                  1201HL03
                  dqdvr(i,j)=0.5d+00*(dqdv0(i,j,1)+dqdv0(i,j,2))        1201HL03
c 1028HL03e
 150           continue
 140        continue

         else if (e1.lt.e2) then
            do 100 i=1,mcnatm
               do 110 j=1,mcnatm
                  dqdvr(i,j)=dqdv0(i,j,1)
 110           continue
 100        continue
         else if (e2.lt.e1) then
            do 120 i=1,mcnatm
               do 130 j=1,mcnatm
                  dqdvr(i,j)=dqdv0(i,j,2)
 130           continue
 120        continue
         end if
      else
c
         if (icomplex.eq.0) then
c
c     ----- Hermitian EE-MCSI -----
c
c
c If e12 is not 0, calculate the hessian using the MCMM formula
c
            dife=e1-e2
            fctor1=dsqrt(dife*dife+4.0d+00*e12*e12)
c
            do 200 i=1,mcnatm
               difgi=chg1(i)-chg2(i)
               fctori=dife*difgi+4.0d+00*e12*chg12(i) 
               do 210 j=1,mcnatm
                  difgj=chg1(j)-chg2(j)
                  fctorj=dife*difgj+4.0d+00*e12*chg12(j) 
                  sumh=dqdv0(i,j,1)+dqdv0(i,j,2)
                  difh=dqdv0(i,j,1)-dqdv0(i,j,2)
                  dqdvr(i,j)
     &           =0.5d+00*(sumh+fctori*fctorj/(fctor1**3.0d+00)
     &           -(4.0d0*(chg12(i)*chg12(j)+e12*dqdv12(i,j))
     &           +difgi*difgj+dife*difh)/fctor1)
 210           continue
 200        continue
c
         else
c
c     ----- Non-Hermitian EE-MCSI -----
c
            ee1=4.0d+00*e12
            dife=e1-e2
            difes=dife*dife
c
            if ((e12.lt.0.0d+00).and.(difes.lt.abs(ee1))) then
c
               do i=1,mcnatm
               do j=1,mcnatm
                  dqdvr(i,j)=0.5d+00*(dqdv0(i,j,1)+dqdv0(i,j,2))
               enddo
               enddo
c
            else
c
               fctor1=dsqrt(difes+ee1)
c
               do i=1,mcnatm
                  difgi=chg1(i)-chg2(i)
                  fctori=dife*difgi+2.0d+00*chg12(i) 
               do j=1,mcnatm
                  difgj=chg1(j)-chg2(j)
                  fctorj=dife*difgj+2.0d+00*chg12(j) 
                  sumh=dqdv0(i,j,1)+dqdv0(i,j,2)
                  difh=dqdv0(i,j,1)-dqdv0(i,j,2)
                  dqdvr(i,j)=0.5d+00*(sumh
     &           +fctori*fctorj/(fctor1**3.0d+00)
     &           -(difgi*difgj+dife*difh
     &           +2.0d+00*dqdv12(i,j))/fctor1)
               enddo
               enddo
c
            end if
c
         endif
      end if
c          
      return
      end
c
c***********************************************************************
c     eeehok
c***********************************************************************
c
      subroutine eeehok(xii,phi,v,e1,e2,e12)
c
c     This subroutine is the driver for an energy calculation.
c     This is a modified version of subroutine mehook.
c
      implicit double precision (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      dimension xii(mcmcar), phi(mcmatm)
      dimension g1(mcmcar), h1(mcmcar,mcmcar)
      dimension g2(mcmcar), h2(mcmcar,mcmcar)
      dimension g12(mcmcar), h12(mcmcar,mcmcar)
c
      dimension chg1(mcmatm), chg2(mcmatm), chg12(mcmatm)
      dimension dqdv12(mcmatm,mcmatm), dqdr12(mcmcar,mcmatm)
c
c  Initialize the variables
c
      v=0.d0
      e1=0.d0
      e2=0.d0
      e12=0.d0
      do 10 i=1,mcmcar
        g1(i)=0.d0
        g2(i)=0.d0
        g12(i)=0.d0
 10   continue
      do 20 i=1,mcmcar
        do 30 j=1,mcmcar
          h1(i,j)=0.d0
          h2(i,j)=0.d0
          h12(i,j)=0.d0
 30    continue
 20   continue
c
      do 40 i=1,mcmatm
         chg1(i)=0.0d+00
         chg2(i)=0.0d+00
         chg12(i)=0.0d+00
         do 50 j=1,mcmatm
            dqdv12(j,i)=0.0d+00
 50      continue
         do 60 j=1,mcmcar
            dqdr12(j,i)=0.0d+00
 60      continue
 40   continue
c
c  If a SCMM1 calculation (MM calculation with configuration 1)
c
      if (mciord.eq.1) then
         call mcviic(xii,e1,g1,h1,1,1,1)
c 1106HL03s
c call it again                                                         1201HL03
c         call mcviic(xii,e1,g1,h1,1,1,1)                                  1201HL03
c 1106HL03e
c
         call eeviic(xii,phi,e1,g1,h1,chg1,1,1)
c
         v = e1
c
         do 1 i=1,mcnatm
            chgr(i)=chg1(i)
 1       continue
c
         if(mccdqv.eq.1) then 
            do 3 i=1,mcnatm
               do 5 j=1,mcnatm
                  dqdvr(j,i)=dqdv0(j,i,1)
 5             continue
 3          continue
         end if
c
c  If a SCMM2 calculation (MM calculation with configuration 2)
c
      else if (mciord.eq.2) then
         call mcviic(xii,e2,g2,h2,1,2,1)	 
c 1106HL03s
c call it again                                                         1201HL03
c         call mcviic(xii,e2,g2,h2,1,2,1)                                  1201HL03
c 1106HL03e
c
         call eeviic(xii,phi,e2,g2,h2,chg2,1,2)
         v = e2
c
         do 2 i=1,mcnatm
            chgr(i)=chg2(i)
 2       continue
c
         if(mccdqv.eq.1) then 
            do 4 i=1,mcnatm
               do 6 j=1,mcnatm
                  dqdvr(j,i)=dqdv0(j,i,2)
 6             continue
 4          continue
         end if
c
c  If a MCMM calculation
c
c 1105HL03s
c  for an MCMM calculation, proper initializtion has been 
c  achieved in call of mcsesi
c 1105HL03e
c
      else if (mciord.eq.0) then
c
c     Calculate V11
c
         call mcviic(xii,e1,g1,h1,1,1,1)
         call eeviic(xii,phi,e1,g1,h1,chg1,1,1)
c
c     Calculate V22
c
         call mcviic(xii,e2,g2,h2,1,2,1)
         call eeviic(xii,phi,e2,g2,h2,chg2,1,2)
c
c     Calculate V12
c
         call eev12c(xii,phi,e12,g12,h12,chg12,dqdv12,dqdr12,1)
c
c     Combine energies
c
         call mccene(e1,e2,e12,v,icomplex)
c
c     Combine charges
c
         call eecchg(e1,e2,e12,chg1,chg2,chg12)                                 
c
c     Combine dqdv
c
         if(mccdqv.eq.1) call eecdqv(e1,e2,e12,chg1,chg2,chg12,dqdv12)
c
      endif
c
      return
      end
c
c***********************************************************************
c     eeghok
c***********************************************************************
c
      subroutine eeghok(xii,phi,v,e1,e2,e12,dxii)
c
c     This subroutine is the driver for a gradient calculation.
c     (Titus V Albu January 2002)
c
      implicit double precision (a-h,o-z)
c
CAMBP#ifdef MPI
CAMBPc     =========================== AMBER/MPI ===========================
CAMBP#     ifdef MPI_DOUBLE_PRECISION
CAMBP#       undef MPI_DOUBLE_PRECISION
CAMBP#     endif
CAMBP      include 'mpif.h'
CAMBP#     ifdef CRAY_PVP
CAMBP#       define MPI_DOUBLE_PRECISION MPI_REAL8
CAMBP#     endif
CAMBPc     ========================= END AMBER/MPI =========================
CAMBPc
CAMBP#     include "parallel.h"
CAMBP#     include "extra.h"
CAMBPc
CAMBP      dimension istat(MPI_STATUS_SIZE)
CAMBP#endif
CAMBPc
CAMBP#     include "../sander/def_time.h"
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      dimension xii(mcmcar), dxii(mcmcar), phi(mcmatm)
      dimension g1(mcmcar), h1(mcmcar,mcmcar)
      dimension g2(mcmcar), h2(mcmcar,mcmcar)
      dimension g12(mcmcar), h12(mcmcar,mcmcar)
c
c  Initialize the variables
c
      dimension chg1(mcmatm), chg2(mcmatm), chg12(mcmatm)
      dimension dqdv12(mcmatm,mcmatm), dqdr12(mcmcar,mcmatm)
c
c  If a SCMM1 calculation (MM calculation with configuration 1)
c
      if (mciord.eq.1) then
c
CAMBP         call timer_start(TIME_MCMMDIAG)
c
         call mcviic(xii,e1,g1,h1,2,1,1)
c 1106HL03s
c call it again                                                         1201HL03
c         call mcviic(xii,e1,g1,h1,2,1,1)                                  1201HL03
c 1106HL03e	 
c
         call eeviic(xii,phi,e1,g1,h1,chg1,2,1)
c
         v = e1
         do i=1,mcmcar
            dxii(i) = g1(i)
         enddo
c
         do 101 i=1,mcnatm
            chgr(i)=chg1(i)
 101     continue
c
         if(mccdqv.eq.1) then 
            do 103 i=1,mcnatm
               do 105 j=1,mcnatm
                  dqdvr(j,i)=dqdv0(j,i,1)
 105           continue
 103        continue
         end if
c
         if(mccdqr.eq.1) then 
            do 107 i=1,mcnatm
               do 109 j=1,3*mcnatm
                  dqdrr(j,i)=dqdrr0(j,i,1)
 109           continue
 107        continue
         end if
c
CAMBP         call timer_stop(TIME_MCMMDIAG)
c
c  If a SCMM2 calculation (MM calculation with configuration 2)
c
      else if (mciord.eq.2) then
c
CAMBP         call timer_start(TIME_MCMMDIAG)
c
         call mcviic(xii,e2,g2,h2,2,2,1)
c 1106HL03s
c call it again                                                         1201HL03
c         call mcviic(xii,e2,g2,h2,2,2,1)                                  1201HL03
c 1106HL03e
c
         call eeviic(xii,phi,e2,g2,h2,chg2,2,2)
c
         v = e2
         do i=1,mcmcar
            dxii(i) = g2(i)
         enddo
c
         do 102 i=1,mcnatm
            chgr(i)=chg2(i)
 102       continue
c
         if(mccdqv.eq.1) then 
            do 104 i=1,mcnatm
               do 106 j=1,mcnatm
                  dqdvr(j,i)=dqdv0(j,i,2)
 106           continue
 104        continue
         end if
c
         if(mccdqr.eq.1) then 
            do 108 i=1,mcnatm
               do 110 j=1,3*mcnatm
                  dqdrr(j,i)=dqdrr0(j,i,2)
 110           continue
 108        continue
         end if
c
CAMBP         call timer_stop(TIME_MCMMDIAG)
c
c  If a MCMM calculation
c
      else if (mciord.eq.0) then
c
CAMBP         call timer_start(TIME_MCMMDIAG)
CAMBPc
CAMBP#ifdef MPI
CAMBPc
CAMBPc     parallel job
CAMBPc
CAMBP         if(numtasks.eq.1) then
CAMBPc
CAMBPc     Calculate V11
CAMBPc
CAMBP            call mcviic(xii,e1,g1,h1,2,1,1)
CAMBP            call eeviic(xii,phi,e1,g1,h1,chg1,2,1)
CAMBPc
CAMBPc     Calculate V22
CAMBPc
CAMBP            call mcviic(xii,e2,g2,h2,2,2,1)
CAMBP            call eeviic(xii,phi,e2,g2,h2,chg2,2,2)
CAMBPc
CAMBP         else
CAMBPc
CAMBP            if(mod(mytaskid,2).eq.0) then
CAMBPc
CAMBP               call mcviic(xii,e1,g1,h1,2,1,1)
CAMBP               call eeviic(xii,phi,e1,g1,h1,chg1,2,1)
CAMBPc
CAMBP               n2=mytaskid/2
CAMBP               n2=2*n2+1
CAMBP               call mpi_send(e1,1,mpi_double_precision,n2,
CAMBP     &                       10,commsander,ier)
CAMBP               call mpi_send(g1,3*mcnatm,mpi_double_precision,n2,
CAMBP     &                       10,commsander,ier)
CAMBP               call mpi_send(chg1,mcnatm,mpi_double_precision,n2,
CAMBP     &                       10,commsander,ier)
CAMBPc
CAMBP               call mpi_recv(e2,1,mpi_double_precision,n2,
CAMBP     &                       20,commsander,istat,ier)
CAMBP               call mpi_recv(g2,3*mcnatm,mpi_double_precision,n2,
CAMBP     &                       20,commsander,istat,ier)
CAMBP               call mpi_recv(chg2,mcnatm,mpi_double_precision,n2,
CAMBP     &                       20,commsander,istat,ier)
CAMBPc
CAMBP            else
CAMBPc
CAMBP               call mcviic(xii,e2,g2,h2,2,2,1)
CAMBP               call eeviic(xii,phi,e2,g2,h2,chg2,2,2)
CAMBPc
CAMBP               n2=mytaskid/2
CAMBP               n2=2*n2
CAMBP               call mpi_recv(e1,1,mpi_double_precision,n2,
CAMBP     &                       10,commsander,istat,ier)
CAMBP               call mpi_recv(g1,3*mcnatm,mpi_double_precision,n2,
CAMBP     &                       10,commsander,istat,ier)
CAMBP               call mpi_recv(chg1,mcnatm,mpi_double_precision,n2,
CAMBP     &                       10,commsander,istat,ier)
CAMBPc
CAMBP               call mpi_send(e2,1,mpi_double_precision,n2,
CAMBP     &                       20,commsander,ier)
CAMBP               call mpi_send(g2,3*mcnatm,mpi_double_precision,n2,
CAMBP     &                       20,commsander,ier)
CAMBP               call mpi_send(chg2,mcnatm,mpi_double_precision,n2,
CAMBP     &                       20,commsander,ier)
CAMBP
CAMBPc
CAMBP            end if
CAMBP         end if
CAMBP#else
c
c  Calculate V11
c
         call mcviic(xii,e1,g1,h1,2,1,1)
         call eeviic(xii,phi,e1,g1,h1,chg1,2,1)
c
c  Calculate V22
c
         call mcviic(xii,e2,g2,h2,2,2,1)
         call eeviic(xii,phi,e2,g2,h2,chg2,2,2)
CAMBP#endif
c
CAMBP         call timer_stop(TIME_MCMMDIAG)
c
c     Calculate V12
c
CAMBP         call timer_start(TIME_MCMMRESO)
         call eev12c(xii,phi,e12,g12,h12,chg12,dqdv12,dqdr12,2)
CAMBP         call timer_stop(TIME_MCMMRESO)
c
c  Combine energies
c
CAMBP         call timer_start(TIME_MCMMFORCE)
         call mccene(e1,e2,e12,v,icomplex) 
c
c  Combine gradients
c
         call mccgra(e1,e2,e12,g1,g2,g12,dxii,mcmcar,icomplex) 
c
c     Combine charges
c
         call eecchg(e1,e2,e12,chg1,chg2,chg12)         
c
c     Combine dqdv
c
         if(mccdqv.eq.1) call eecdqv(e1,e2,e12,chg1,chg2,chg12,dqdv12)
c
c     Combine dqdr
c
         if(mccdqr.eq.1) call eecdqr(e1,e2,e12,g1,g2,g12,
     &                               chg1,chg2,chg12,dqdr12)
c
CAMBP         call timer_stop(TIME_MCMMFORCE)
c
      endif
c
      return
      end
c
c***********************************************************************
c     eehhok
c***********************************************************************
c
      subroutine eehhok(xii,phi,v,e1,e2,e12,dxii,fmat)
c
c     This subroutine is the driver for a Hessian calculation.
c     (Titus V Albu January 2002)
c
      implicit double precision (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      dimension xii(mcmcar), dxii(mcmcar), fmat(mcmcar,mcmcar)
      dimension g1(mcmcar), h1(mcmcar,mcmcar)
      dimension g2(mcmcar), h2(mcmcar,mcmcar)
      dimension g12(mcmcar), h12(mcmcar,mcmcar)
      dimension phi(mcmatm)
      dimension chg1(mcmatm), chg2(mcmatm), chg12(mcmatm)
      dimension dqdv12(mcmatm,mcmatm), dqdr12(mcmcar,mcmatm)
c
c  Initialize the variables
c
      v=0.d0
      e12=0.d0
      e1=0.d0
      e2=0.d0
      do 10 i=1,mcmcar
        g1(i)=0.d0
        g2(i)=0.d0
        g12(i)=0.d0
 10   continue
      do 20 i=1,mcmcar
        do 30 j=1,mcmcar
          h1(i,j)=0.d0
          h2(i,j)=0.d0
          h12(i,j)=0.d0
 30    continue
 20   continue
c
      do 40 i=1,mcmatm
         chg1(i)=0.0d+00
         chg2(i)=0.0d+00
         chg12(i)=0.0d+00
         do 50 j=1,mcmatm
            dqdv12(j,i)=0.0d+00
 50      continue
         do 60 j=1,mcmcar
            dqdr12(j,i)=0.0d+00
 60      continue
 40   continue
c
c  If a SCMM1 calculation (MM calculation with configuration 1)
c
      if (mciord.eq.1) then
         call mcviic(xii,e1,g1,h1,3,1,1)
c 1106HL03s
c call it again                                                         1201HL03
c         call mcviic(xii,e1,g1,h1,3,1,1)                                  1201HL03
c 1106HL03e
c	 
         call eeviic(xii,phi,e1,g1,h1,chg1,3,1)
c
         v = e1
         do i=1,mcmcar
            dxii(i) = g1(i)
         enddo
         do i=1,mcmcar
           do j=1,mcmcar
             fmat(i,j) = h1(i,j)
           enddo
         enddo
c
         do 101 i=1,mcnatm
            chgr(i)=chg1(i)
 101     continue
c
         if(mccdqv.eq.1) then 
            do 103 i=1,mcnatm
               do 105 j=1,mcnatm
                  dqdvr(j,i)=dqdv0(j,i,1)
 105           continue
 103        continue
         end if
c
         if(mccdqr.eq.1) then 
            do 107 i=1,mcnatm
               do 109 j=1,3*mcnatm
                  dqdrr(j,i)=dqdrr0(j,i,1)
 109           continue
 107        continue
         end if
c
c  If a SCMM2 calculation (MM calculation with configuration 2)
c
      else if (mciord.eq.2) then
         call mcviic(xii,e2,g2,h2,3,2,1)
c 1106HL03s
c call it again                                                         1201HL03
c         call mcviic(xii,e2,g2,h2,3,2,1)                                  1201HL03
c 1106HL03e
c	 
         call eeviic(xii,phi,e2,g2,h2,chg2,3,2)
c
         v = e2
         do i=1,mcmcar
            dxii(i) = g2(i)
         enddo
         do i=1,mcmcar
           do j=1,mcmcar
             fmat(i,j) = h2(i,j)
           enddo
         enddo
c
         do 102 i=1,mcnatm
            chgr(i)=chg2(i)
 102       continue
c
         if(mccdqv.eq.1) then 
            do 104 i=1,mcnatm
               do 106 j=1,mcnatm
                  dqdvr(j,i)=dqdv0(j,i,2)
 106           continue
 104        continue
         end if
c
         if(mccdqr.eq.1) then 
            do 108 i=1,mcnatm
               do 110 j=1,3*mcnatm
                  dqdrr(j,i)=dqdrr0(j,i,2)
 110           continue
 108        continue
         end if
c
c  If a MCMM calculation
c
      else if (mciord.eq.0) then
c
c  Calculate V11
c
         call mcviic(xii,e1,g1,h1,3,1,1)
         call eeviic(xii,phi,e1,g1,h1,chg1,3,1)
c
c  Calculate V22
c
         call mcviic(xii,e2,g2,h2,3,2,1)
         call eeviic(xii,phi,e2,g2,h2,chg2,3,2)
c
c  Calculate V12
c
         call eev12c(xii,phi,e12,g12,h12,chg12,dqdv12,dqdr12,3)
c
c  Combine energies
c
         call mccene(e1,e2,e12,v,icomplex) 
c
c  Combine gradients
c
         call mccgra(e1,e2,e12,g1,g2,g12,dxii,mcmcar,icomplex) 
c
c  Combine hessians
c
         call mcches(e1,e2,e12,g1,g2,g12,h1,h2,h12,fmat,mcmcar,
     &               icomplex) 
c
c     Combine charges
c
         call eecchg(e1,e2,e12,chg1,chg2,chg12)         
c
c     Combine dqdv
c
         if(mccdqv.eq.1) call eecdqv(e1,e2,e12,chg1,chg2,chg12,dqdv12)
c
c     Combine dqdr
c
         if(mccdqr.eq.1) call eecdqr(e1,e2,e12,g1,g2,g12,
     &                               chg1,chg2,chg12,dqdr12)
c
      endif
c
      return
      end
c
c***********************************************************************
c     eeprez
c***********************************************************************
      subroutine eeprez(phi,v)
c
c     Subroutine to write out EE-MCMM results.
c
      implicit real*8 (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      dimension phi(mcmatm)
c
      character*2 asymb(103)
c
c     array of atomic symbols
c
      data (asymb(i),i=1,103)  /
     *   'H ','He','Li','Be','B ','C ','N ','O ','F ','Ne',
     *   'Na','Mg','Al','Si','P ','S ','Cl','Ar',
     *   'K ','Ca','Sc','Ti','V ','Cr','Mn','Fe','Co','Ni','Cu',
     *        'Zn','Ga','Ge','As','Se','Br','Kr',
     *   'Rb','Sr','Y ','Zr','Nb','Mo','Tc','Ru','Rh','Pd','Ag',
     *        'Cd','In','Sn','Sb','Te','I ','Xe',
     *   'Cs','Ba','La','Ce','Pr','Nd','Pm','Sm','Eu','Gd','Tb',
     *        'Dy','Ho','Er','Tm','Yb','Lu','Hf','Ta','W ','Re',
     *        'Os','Ir','Pt','Au','Hg','Tl','Pb','Bi','Po','At','Rn',
     *   'Fr','Ra','Ac','Th','Pa','U','Np','Pu','Am','Cm','Bk',
     *        'Cf','Es','Fm','Md','No','Lr'/
c
      write(fu6,9999) 
 9999 format (/1x,30('-'),2x,'EE-MCMM Results',2x,30('-'))
c
c     print out potentials and charges.
c
      write(fu6,9998)
c      csum=0.0D+00
      do 100 inum=1,mcnatm
         ilab = labmc(inum)
         write(fu6,9997) inum,asymb(ilab),
     &                   phi(inum),phi(inum)*fhaev,chgr(inum)
c         csum=csum+chgr(inum)
 100  continue
c      write(fu6,*) 'chgsum=',csum
 9998 format(/1x,'Atom Number',3x,'Atomic Symbol',8x,'Phi(a.u.)',
     *   7x,'Phi(V) ',7x,'Charge(a.u.)')
c
 9997 format(3x,i3,15x,a2,7x,f15.8,1x,f15.8,1x,f15.8)
c
c     calculate electrostatic contribution
c
      eqmm=0.0d+00
c
      do 200 i=1,mcnatm
c
         chi=chgr(i)
         eqmm=eqmm+chi*phi(i)
c
 200  continue
c
      eqm=v-eqmm
c
c
c
      write(fu6,9996)
      write(fu6,9995) eqm,eqm*fhaev,eqm*fhacm,eqm*fhakc
      write(fu6,9994) eqmm,eqmm*fhaev,eqmm*fhacm,eqmm*fhakc
      write(fu6,9993) v,v*fhaev,v*fhacm,v*fhakc
c
 9996 format(/31x,'hartree',9x,'eV',8x,'cm**-1',6x,'kcal/mol')
 9995 format(2x,'V(QM)          energy',4x,f11.7,2x,f11.6,2x,f11.3,
     *       2x,f11.5)
 9994 format(2x,'V(QM/MM)       energy',4x,f11.7,2x,f11.6,2x,f11.3,
     *       2x,f11.5)
 9993 format(2x,'V(QM)+V(QM/MM) energy',4x,f11.7,2x,f11.6,2x,f11.3,
     *       2x,f11.5)
c
c     print out DQDPHI
c
      if (mccdqv.eq.1) then
         write(fu6,9899)
 9899    format(/,' ** DQDPHI (a.u.):')
c
         do 300 i=1,mcnatm
            imax=0
            ic=0
 310        continue
            imin=imax+1
            imax=imax+5
            ic=ic+1
            if(imax .gt. mcnatm) imax=mcnatm
            write(fu6,9898) i,ic,(dqdvr(i,j),j=imin,imax)
 9898       format(i2,i3,1p,5e15.8)
            if(imax .lt. mcnatm) go to 310
 300     continue
c
      end if
c
c     print out DQDR
c
      if (mccdqr.eq.1) then
c
         write(fu6,9799)
 9799    format(/,' ** DQDR (a.u.):')
         do 400 i=1,mcnatm
            imax=0
            ic=0
 410        continue
            imin=imax+1
            imax=imax+5
            ic=ic+1
            if(imax .gt. 3*mcnatm) imax=3*mcnatm
            write(fu6,9798) i,ic,(dqdrr(j,i),j=imin,imax)
 9798       format(i2,i3,1p,5e15.8)
            if(imax .lt. 3*mcnatm) go to 410
 400     continue
c
c         do 400 i=1,3*mcnatm
c            imax=0
c            ic=0
c 410        continue
c            imin=imax+1
c            imax=imax+5
c            ic=ic+1
c            if(imax .gt. mcnatm) imax=mcnatm
c            write(fu6,9798) i,ic,(dqdrr(i,j),j=imin,imax)
c 9798       format(i2,i3,1p,5e15.8)
c            if(imax .lt. mcnatm) go to 410
c 400     continue
c
      end if
c
      return
      end
c
c***********************************************************************
c     eetesi
c***********************************************************************
c
      subroutine eetesi(redun)
c
c     Subroutine to tranformed the information from the input file esp.fu83
c     into internal coordinates for EE-MCMM calculation.
c     This is a modified version of subroutine mctesi.
c
      implicit double precision (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      parameter (zero   = 0.0d0 )  
      parameter (mcmca2=mcmcar*(mcmcar+1)/2)
      parameter (mcmic2=mcmics*(mcmics+1)/2)
c
      dimension x0(mcmcar)
      dimension d0(mcmcar),d1(mcmcar),d2(mcmcar)
      dimension dxint0(mcmics),dxint1(mcmics),dxint2(mcmics)
c
      double precision k0(mcmcar,mcmcar),
     *                 k1(mcmcar,mcmcar),
     *                 k2(mcmcar,mcmcar)
      double precision kxint0(mcmics,mcmics),
     *                 kxint1(mcmics,mcmics),
     *                 kxint2(mcmics,mcmics)
c
      dimension dics(mcmics)
      dimension dicd(mcmicd)
      dimension xc(mcmatm),yc(mcmatm),zc(mcmatm)
      dimension amatb(mcmics,mcmcar)
      dimension amatbi(mcmcar,mcmics)
      dimension amatbt(mcmics,mcmic2)
      dimension amatc(mcmic2)
      dimension egnm(mcmics,mcmics)
      dimension ggi(mcmics,mcmics)
      dimension gm(mcmics,mcmics)
      dimension amasin(mcmcar,mcmcar)
      dimension flgm(mcmics)
      dimension scr(mcmcar,mcmics)
      dimension scr3(mcmic2)
      dimension fl(mcmca2)
c
      dimension chg1(mcmatm),chg2(mcmatm),chg(mcmatm),phi(mcmatm)
      dimension dqdv1(mcmatm,mcmatm),dqdv2(mcmatm,mcmatm)
      dimension dqdv(mcmatm,mcmatm)
      dimension dqdri1(mcmics,mcmatm),dqdri2(mcmics,mcmatm)
      dimension dqdr(mcmcar,mcmatm),dqdri(mcmics,mcmatm)
      dimension dqr(mcmcar),dqri(mcmics)
c
      logical redun
c
c     Define some variables
c
      mcncar = 3*mcnatm
c
c 1030HL03s
c initialization                                                        1201HL03
        v1=zero                                                         1201HL03
        v2=zero                                                         1201HL03
        do 10 ihai=1,mcmcar                                             1201HL03
          x0(ihai)=zero                                                 1201HL03
          d0(ihai)=zero                                                 1201HL03
          d1(ihai)=zero                                                 1201HL03
          d2(ihai)=zero                                                 1201HL03
          do 20 jhai=1,mcmcar                                           1201HL03
            k0(ihai,jhai)=zero                                          1201HL03
            k1(ihai,jhai)=zero                                          1201HL03
            k2(ihai,jhai)=zero                                          1201HL03
 20      continue                                                       1201HL03
 10   continue                                                          1201HL03
c 1030HL03e                                                             1201HL03
c
c     Start a loop over the mcnesp (electronic structure theory Shepard points)
c
      do 1000 mciesp=1,mcnesp
c
c     Put the Shepard point information into the working arrays
c
         v0=vsh(mciesp)
         do 100 i=1,mcncar
            x0(i)=xsh(i,mciesp)
            d0(i)=dsh(i,mciesp)
            do 110 j=1,mcncar
               k0(i,j)=hsh(i,j,mciesp)
 110        continue
 100     continue
c
         do 150 i=1,mcnatm
            phi(i)=phis(i,mciesp)
            chg(i)=chgs(i,mciesp)
            do 160 j=1,mcnatm
               dqdv(j,i)=dqdvs(j,i,mciesp)
 160        continue
            do 170 j=1,3*mcnatm
               dqdr(j,i)=dqdrs(j,i,mciesp)
 170        continue
 150     continue
c
c     Now transform the information into internal coordinates
c
c
c     Calculate v1, d1 and k1 by means of a mcviic call.
c
         call mcviic(x0,v1,d1,k1,3,1,1)
         call eeviic(x0,phi,v1,d1,k1,chg1,3,1)
c
c     And now, the same for v2, d2, and k2:
c
         call mcviic(x0,v2,d2,k2,3,2,1)
         call eeviic(x0,phi,v2,d2,k2,chg2,3,2)
c
c 1031HL03s
c     Recalculate v1, d1 and k1 by means of a mcviic call.              1201HL03
c     
c         call mcviic(x0,v1,d1,k1,3,1,1)                                   1201HL03
c 1031HL03e
c
c     Rearrange the Cartesian coordinates:
c
         do 200 j = 1, mcnatm
            xc(j) = x0(3*j-2)
            yc(j) = x0(3*j-1)
            zc(j) = x0(3*j)
 200     continue
c
c     Transform the cartesian coordinates of the electronic structure
c     theory Shepard points into the internal coordinates used for
c     generalized distances. These values will be used later in
c     determining the weights.
c
         call mctcic(mcndid,mcnand,mcnadd,mcndad,
     *               mcidid,mciand,mciadd,mcidad,
     *               mcmicd,mcmatm,xc,yc,zc,dicd)
         do 300 i = 1, mcnicd
            qd0(i,mciesp) = dicd(i)
 300     continue
c
c     Transform Shepard points information from Cartesian coordinates
c     to internal coordinates used in Shepard interpolation. For doing so:
c
c  1) compute the B matrix for the current x0 and then use it with d1, d2,
c     k1 and k2
c
         call mctcic(mcndis,mcnans,mcnads,mcndas,
     *               mcidis,mcians,mciads,mcidas,
     *               mcmics,mcmatm,xc,yc,zc,dics)
         do 310 i = 1, mcnics
            qs0(i,mciesp) = dics(i)
 310     continue
c
         call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,
     *                 mcidas,mciads,xc,yc,zc,mcnatm,mcnics,
     *                 amatb,t,mcmatm,mcmics,mcmcar)
c
c  2) compute the A matrix
c
         if (redun) then
            call mcybimat2 (amatb,amatbi,cmmc,amasin,gm,ggi,flgm,
     *                      egnm,smmc,mcnatm,mcnics,mcmics,mcmcar)
         else
            call mcybimat (amatb,amatbi,cmmc,amasin,gm,smmc,
     *                     mcnatm,mcnics,mcmics,mcmcar)
         end if
c
c  4) transform the gradient
c
         call trangj (dxint0,amatbi,d0,mcnics,mcncar,mcmics,mcmcar)
         call trangj (dxint1,amatbi,d1,mcnics,mcncar,mcmics,mcmcar)
         call trangj (dxint2,amatbi,d2,mcnics,mcncar,mcmics,mcmcar)
c
c  4.1)  transform the d(chg)/dr
c
         do 400 j=1,mcnatm
c
            do 410 i=1,mcncar
               dqr(i)=dqdr(i,j)
 410        continue
c
            call trangj(dqri,amatbi,dqr,mcnics,mcncar,mcmics,mcmcar)
c
            do 420 i=1,mcnics
               dqdri(i,j)=dqri(i)
 420        continue
c
 400     continue
c
         if(mcihfr.eq.0)  goto 2000
c
c  5) transform the hessians: first, compute AtCA and then multiply
c                 it by the gradient components in K10 and K20
c
c     Calculate the tensor
c
         do 500 i = 1, mcmic2
            do 510 j=1, mcmics
               amatbt(j,i) = zero
 510        continue
 500     continue
         call ybtens (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,
     *                mcidas,mciads,xc,yc,zc,mcnatm,amatbi,
     *                amatbt,mcnics,mcncar,mcmics,mcmic2,mcmatm,t)
c
c     K0
c
         do 600 i = 1, mcmic2
            amatc(i) = zero
 600     continue
         call formf2ij (amatc,amatbt,dxint0,mcmics,mcmic2,mcnics)
         do 610 i = 1, mcmic2
            scr3(i) = zero
 610     continue
         call tranlfj (fl,k0,mcncar,mcmca2,mcmcar)
         call ytranfc (fl,amatbi,scr,scr3,amatc,mcnatm,
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)
         call yexpnd (scr3,kxint0,mcmic2,mcmics,mcnics,0)
c
c     K1
c
         do 601 i = 1, mcmic2
            amatc(i) = zero
 601     continue
         call formf2ij (amatc,amatbt,dxint1,mcmics,mcmic2,mcnics)
         do 611 i = 1, mcmic2
            scr3(i) = zero
 611     continue
         call tranlfj (fl,k1,mcncar,mcmca2,mcmcar)
         call ytranfc (fl,amatbi,scr,scr3,amatc,mcnatm,
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)
         call yexpnd (scr3,kxint1,mcmic2,mcmics,mcnics,0)
c
c     K2
c
         do 602 i = 1, mcmic2
            amatc(i) = zero
 602     continue
         call formf2ij (amatc,amatbt,dxint2,mcmics,mcmic2,mcnics)
         do 612 i = 1, mcmic2
            scr3(i) = zero
 612     continue
         call tranlfj (fl,k2,mcncar,mcmca2,mcmcar)
         call ytranfc (fl,amatbi,scr,scr3,amatc,mcnatm,
     *                 mcmics,mcmcar,mcmic2,mcmca2,mcnics)
         call yexpnd (scr3,kxint2,mcmic2,mcmics,mcnics,0)
c
 2000    continue
c
c     Now calculated the differences: g-gk and f-fk : 6/9/99 by Y. Kim
c
         do 700 i=1,mcnics
            dxint1(i) = dxint1(i) - dxint0(i)
            dxint2(i) = dxint2(i) - dxint0(i)
            do 710 j=1,mcnics
               kxint1(j,i) = kxint1(j,i) - kxint0(j,i)
               kxint2(j,i) = kxint2(j,i) - kxint0(j,i)
 710        continue
 700     continue
c
         do 750 i=1,mcnatm
            chg1(i)=chg1(i)-chg(i)
            chg2(i)=chg2(i)-chg(i)
            do 760 j=1,mcnatm
               dqdv1(j,i)=dqdv0(j,i,1)-dqdv(j,i)
               dqdv2(j,i)=dqdv0(j,i,2)-dqdv(j,i)
 760        continue
            do 770 j=1,mcnics
               dqdri1(j,i)=dqdri0(j,i,1)-dqdri(j,i)
               dqdri2(j,i)=dqdri0(j,i,2)-dqdri(j,i)
 770        continue
 750     continue
c
c     Calculation of A (scalar)
c
         va = (v1-v0)
         vb = (v2-v0)
         aevbm(mciesp) = va*vb
c
c     Calculation of B (vector)
c
         do 800 i=1,mcnics
            bevbm(i,mciesp) = dxint1(i)/va + dxint2(i)/vb
 800     continue
c
         do 850 i=1,mcnatm
            bee(i,mciesp)=chg1(i)/va+chg2(i)/vb
 850     continue
c
c     Calculation of C (matrix). Two options: mcifre=1 (discarded in the
c     latest versions of the method):
c
        if (mcifre.eq.1) then
           do 900 j=1,mcnics
              do 910 i= 1,j
                 cevbm(i,j,mciesp) = (dxint1(i)*dxint1(j))/(va*va) +             1106OT06
     *                               (dxint2(i)*dxint2(j))/(vb*vb) -             1106OT06
     *                               kxint1(i,j)/va  -
     *                               kxint2(i,j)/vb
                 cevbm(j,i,mciesp) = cevbm(i,j,mciesp)
 910          continue
 900       continue
c
c     and mcifre=2
c
        else if (mcifre.eq.2)then
c
           if(mcihfr.ne.0) then
              do 901 j=1,mcnics
                 do 911 i=1,mcnics
                    cevbm(i,j,mciesp)=(dxint1(i)*dxint2(j))/(va*vb)
     *                               +(dxint2(i)*dxint1(j))/(va*vb)
     *                               +kxint1(i,j)/va+kxint2(i,j)/vb
c
c     These lines limit the value of cevbm. This makes te code to work
c     a little better, although it is an artificial fix and the
c     frequencies are not exactly the same as the high level freqs.
c
c       if (cevbm(i,j,mciesp).gt.1.d0) cevbm(i,j,mciesp)=1.d0 
c       if (cevbm(i,j,mciesp).lt.-1.d0) cevbm(i,j,mciesp)=-1.d0 
c
 911             continue
 901          continue
c     
           else
c
              do 902 j=1,mcnics
                 do 912 i=1,mcnics
                    cevbm(i,j,mciesp)=0.0d+00
 912             continue
 902          continue
c
           end if
c
c
           if(mcifqv.ne.0) then
c
              do 951 j=1,mcnatm
                 do 961 i=1,mcnatm
                    ceevv(i,j,mciesp)=(chg1(i)*chg2(j))/(va*vb)
     *                               +(chg2(i)*chg1(j))/(va*vb)
     *                              +dqdv1(i,j)/va+dqdv2(i,j)/vb
 961             continue
 951          continue
c
           else
c
              do 952 j=1,mcnatm
                 do 962 i=1,mcnatm
                    ceevv(i,j,mciesp)=0.0d+00
 962             continue
 952          continue
c
           end if
c
           if(mcifqr.ne.0) then
c
              do 971 j=1,mcnatm
                 do 981 i=1,mcnics
                    ceerv(i,j,mciesp)=(dxint1(i)*chg2(j))/(va*vb)
     *                               +(dxint2(i)*chg1(j))/(va*vb)
     *                               +dqdri1(i,j)/va+dqdri2(i,j)/vb
 981             continue
 971          continue
c
           else
c
              do 972 j=1,mcnatm
                 do 982 i=1,mcnics
                    ceerv(i,j,mciesp)=0.0d+00
 982             continue
 972          continue
c
           end if
c
        endif
c
c     End of the loop over the mcnesp points
c
 1000 continue
c>>>>                                                                   0601MH10
c     Set some coefficients of Taylor expasion zero
c
      call mcv12z
c
c     Print Taylor coefficients if required
c
      if(mcpcoe.ne.0) call mcprcf
c<<<<                                                                   0601MH10
      return
      end
c***********************************************************************
c     eerd83
c***********************************************************************
c
      subroutine eerd83
c
c     Subroutine to read in the EEGEN83 section of the input file 
c     containing the electronic structure information.
c
      implicit double precision (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'                                              0305MH08 
c
      character*80 word(40)
      logical lsec,leof
c
c     Define some variables
c
      lsec = .false.
      leof = .false.
c
c     Find the EEGEN83 section
c
 10   call readln(fu83,word,nword,lsec,leof)
      if (leof) then
         write (fu6,100)
 100     format (1x,'Error: the esp.fu83 file is empty')
         stop 'eerd83 1'
      endif
      if (.not. lsec .or. word(1) .ne. 'EEGEN83') goto 10
c
c     Read the keywords
c
 20   call readln(fu83,word,nword,lsec,leof)
      if (.not. lsec .and. .not. leof) then
c
c     UNITELP
c
         if (word(1) .eq. 'UNITELP') then
            if (nword .eq. 2) then
               if (word(2) .eq. 'AU') then
                  mciups = 1
               elseif (word(2) .eq. 'VOLT') then
                  mciups = 2
               else
                  write (fu6,9999)
                  stop 'eerd83 2'
               endif
            else
               write (fu6,9999)
               stop 'eerd83 3'
            endif
 9999 format (1x,'Error in the argument of UNITELP keyword')
c
c     UNITDQDPHI
c
         elseif (word(1) .eq. 'UNITDQDPHI') then
            if (nword .eq. 2) then
               if (word(2) .eq. 'AU') then
                  mciuvs = 1
               elseif (word(2) .eq. 'VOLT') then
                  mciuvs = 2
               else
                  write (fu6,9998)
                  stop 'eerd83 4'
               endif
            else
               write (fu6,9998)
               stop 'eerd83 5'
            endif
 9998 format (1x,'Error in the argument of UNITDQDPHI keyword')
c
c     UNITDQDR
c
         elseif (word(1) .eq. 'UNITDQDR') then
            if (nword .eq. 2) then
               if (word(2) .eq. 'BOHR') then
                  mciurs = 1
               elseif (word(2) .eq. 'ANG') then
                  mciurs = 2
               else
                  write (fu6,9997)
                  stop 'eerd83 6'
               endif
            else
               write (fu6,9997)
               stop 'eerd83 7'
            endif
 9997 format (1x,'Error in the argument of UNITDQDR keyword')
c
c     FORMQPHI
c
         elseif (word(1) .eq. 'FORMQPHI') then
            if (nword .eq. 2) then
               if (word(2) .eq. '1') then
                  mcifqs = 1
               elseif (word(2) .eq. '2') then
                  mcifqs = 2
               else
                  write (fu6,9996)
                  stop 'eerd83 8'
               endif
            else
               write (fu6,9996)
               stop 'eerd83 9'
            endif
 9996 format (1x,'Error in the argument of FORMQPHI keyword')
c
c     FORMDQDPHI
c
         elseif (word(1) .eq. 'FORMDQDPHI') then
            if (nword .eq. 2) then
               if (word(2) .eq. 'PACKED') then
                  mcifqv = 1
               elseif (word(2) .eq. 'FULL') then
                  mcifqv = 2
               elseif (word(2) .eq. 'GAMESS') then
                  mcifqv = 3
               elseif (word(2) .eq. 'ZERO') then
                  mcifqv = 0
               else
                  write (fu6,9995)
                  stop 'eerd83 10'
               endif
            else
               write (fu6,9995)
               stop 'eerd83 11'
            endif
 9995 format (1x,'Error in the argument of FORMDQDPHI keyword')
c
c     FORMDQDR
c
         elseif (word(1) .eq. 'FORMDQDR') then
            if (nword .eq. 2) then
               if (word(2) .eq. 'FULL') then
                  mcifqr = 2
               elseif (word(2) .eq. 'GAMESS') then
                  mcifqr = 3
               elseif (word(2) .eq. 'ZERO') then
                  mcifqr = 0
               else
                  write (fu6,9994)
                  stop 'eerd83 12'
               endif
            else
               write (fu6,9994)
               stop 'eerd83 13'
            endif
 9994 format (1x,'Error in the argument of FORMDQDR keyword')
c
c     Stop if the keyword is not recognized
c
         else
            write(fu6,900) word(1)
            stop 'eerd83 14'
         endif
 900  format (1x,'Error: The following keyword is not recognized',/a80)
c
c     Read in another keyword
c
         goto 20
      endif
c
      return
      end
c***********************************************************************
c     eerd85
c***********************************************************************
c
      subroutine eerd85(string,iend,istrt)
c
c     subroutine to read in the input in the EEMCMM section of 
c     esp.fu85.
c
      implicit double precision (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      character * 80 string
      dimension mepdum(mcmics)
c
      menicz = 0
c
c     read in first keyword in this section
c
      call mcrlin(fu5,string,istrt,isect,iend)
c
      do while (isect.eq.0.and.iend.eq.0)
c
c     EECALC
c
         if (string(istrt:istrt+5).eq.'eecalc') then
            call rword(string,istrt,ierr)
            if (ierr.ne.1) then
               if (string(istrt:istrt+4).eq.'false') then
                  mciee  = 0
               elseif (string(istrt:istrt+3).eq.'true') then
                  mciee  = 1
               else
                  write(fu6,1600)
                  stop 'eerd85 1'
               endif
            else
               write(fu6,1610)
               stop 'eerd85 2'
            endif
 1600 format (1x,'Error: Keyword EECALC has a wrong argument.')
 1610 format (1x,'Error: Keyword EECALC must have an argument.')
c
c     UNITELPIN
c
         else if (string(istrt:istrt+8).eq.'unitelpin') then
            call rword(string,istrt,ierr)
            if (ierr.ne.1) then
               if (string(istrt:istrt+1).eq.'au') then
                  mciuph = 0
               elseif (string(istrt:istrt+3).eq.'volt') then
                  mciuph = 1
               else
                  write(fu6,1700)
                  stop 'eerd85 3'
               endif
            else
               write(fu6,1710)
               stop 'eerd85 4'
            endif
 1700 format (1x,'Error: Keyword UNITELPIN has a wrong argument.')
 1710 format (1x,'Error: Keyword UNITELPIN must have an argument.')
c
c     EETYPE
c
         else if (string(istrt:istrt+5).eq.'eetype') then
            call rword(string,istrt,ierr)
            if (ierr.ne.1) then
               if (string(istrt:istrt+5).eq.'charge') then
                  mccdqv = 0
                  mccdqr = 0
               elseif (string(istrt:istrt+5).eq.'dqdphi') then
                  mccdqv = 1
                  mccdqr = 0
               elseif (string(istrt:istrt+3).eq.'dqdr') then
                  if (mcityp.eq.1) then
                     write(fu6,1820)
                     stop 'eerd85 5'
                  end if
                  mccdqv = 0
                  mccdqr = 1
               elseif (string(istrt:istrt+3).eq.'all') then
                  if (mcityp.eq.1) then
                     write(fu6,1820)
                     stop 'eerd85 6'
                  end if
                  mccdqv = 1
                  mccdqr = 1
               else
                  write(fu6,1800)
                  stop 'eerd85 7'
               endif
            else
               write(fu6,1810)
               stop 'eerd85 8'
            endif
 1800 format (1x,'Error: Keyword EETYPE has a wrong argument.')
 1810 format (1x,'Error: Keyword EETYPE must have an argument.')
 1820 format (1x,'Error: gradient or hessian in TYPECALC option ',
     &        'must be selected in DQDR calculation')
c>>>>                                                                    0529MH10
c ICEEZERO
c
         else if (string(istrt:istrt+7).eq.'iceezero') then
            call mcrkic(fu5,fu6,mcmatm,mcmics,menicz,
     *                  mendiz,menanz,menadz,mendaz,
     *                  meidiz,meianz,meiadz,meidaz,
     *                  mesdum,mepdum)                                  
c<<<<                                                                    0529MH10
         else
            write(fu6,2000) string(istrt:80)
            stop 'eerd85 11'
         end if
         call mcrlin(fu5,string,istrt,isect,iend)
      end do
c
 2000 format(1x,'Error: the following is not a valid keyword in ',
     *          'the EEMCMM section of MC-TINKER',/A80)
c
c
      return
      end
c
c ************************************************************************
c     eeread
c ************************************************************************
      subroutine eeread(iunitr,itp)
c
c     This subroutine reads charges, reference potentials, d(chg)/d(phi) 
c     and d(chg)/dR from units 81-82 and store the information.
c
      implicit real*8 (a-h,o-z)
c
c
CAMBP#ifdef MPI
CAMBPc     =========================== AMBER/MPI ===========================
CAMBP#     ifdef MPI_DOUBLE_PRECISION
CAMBP#       undef MPI_DOUBLE_PRECISION
CAMBP#     endif
CAMBP      include 'mpif.h'
CAMBP#     ifdef CRAY_PVP
CAMBP#       define MPI_DOUBLE_PRECISION MPI_REAL8
CAMBP#     endif
CAMBPc     ========================= END AMBER/MPI =========================
CAMBP#     include "parallel.h"
CAMBP#     include "extra.h"
CAMBP#endif
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      character*80 word(40)
      logical lsec,leof
c
c     Set default values
c
      iuphi=1
      iudqdv=0
      iudqdr=0
      ifrmqv=1
      ifmdqv=3
      ifmdqr=3
c
c     Define some variables
c
      lsec = .false.
      leof = .false.
c
c     Find the CRKFMT section
c
CAMBP#ifdef MPI
CAMBP      if(master) rewind iunitr
CAMBP#else
      rewind iunitr
CAMBP#endif
 100  call readln(iunitr,word,nword,lsec,leof)
      if (leof) then
         write (fu6,9999) iunitr
 9999    format (1x,'Error: the esp.fu',i2,' file does not',
     &           'contain the CRKFMT section')
         stop 'eeread 1'
      endif
      if (.not. lsec .or. word(1) .ne. 'CRKFMT') goto 100
c
c     Read the keywords
c
 200  call readln(iunitr,word,nword,lsec,leof)
      if (.not. lsec .and. .not. leof) then
c
c     UNITELP
c
         if (word(1) .eq. 'UNITELP') then
            if (nword .eq. 2) then
               if (word(2) .eq. 'AU') then
                  iuphi=0
               elseif (word(2) .eq. 'VOLT') then
                  iuphi=1
               else
                  write (fu6,9998)
                  stop 'eeread 2'
               endif
            else
               write (fu6,9998)
               stop 'eeread 3'
            endif
 9998       format (1x,'Error in the argument of UNITELP keyword')
c
c     UNITDQDPHI
c
         elseif (word(1) .eq. 'UNITDQDPHI') then
            if (nword .eq. 2) then
               if (word(2) .eq. 'AU') then
                  iudqdv=0
               elseif (word(2) .eq. 'VOLT') then
                  iudqdv=1
               else
                  write (fu6,9997)
                  stop 'eeread 4'
               endif
            else
               write (fu6,9997)
               stop 'eeread 5'
            endif
 9997       format (1x,'Error in the argument of UNITDQDPHI keyword')
c
c     UNITDQDR
c
         elseif (word(1) .eq. 'UNITDQDR') then
            if (nword .eq. 2) then
               if (word(2) .eq. 'BOHR') then
                  iudqdr=0
               elseif (word(2) .eq. 'ANG') then
                  iudqdr=1
               else
                  write (fu6,9996)
                  stop 'eeread 6'
               endif
            else
               write (fu6,9996)
               stop 'eeread 7'
            endif
 9996       format (1x,'Error in the argument of UNITDQDR keyword')
c
c     FORMQPHI
c
         elseif (word(1) .eq. 'FORMQPHI') then
            if (nword .eq. 2) then
               if (word(2) .eq. '1') then
                  ifrmqv=1
               elseif (word(2) .eq. '2') then
                  ifrmqv=2
               else
                  write (fu6,9995)
                  stop 'eeread 8'
               endif
            else
               write (fu6,9995)
               stop 'eeread 9'
            endif
 9995       format (1x,'Error in the argument of FORMQPHI keyword')
c
c     FORMDQDPHI
c
         elseif (word(1) .eq. 'FORMDQDPHI') then
            if (nword .eq. 2) then
               if (word(2) .eq. 'PACKED') then
                  ifmdqv = 1
               elseif (word(2) .eq. 'FULL') then
                  ifmdqv = 2
               elseif (word(2) .eq. 'GAMESS') then
                  ifmdqv = 3
               elseif (word(2) .eq. 'ZERO') then
                  ifmdqv = 0
                  do 605 i=1,mcnatm
                     do 606 j=1,mcnatm
                        dqdv0(j,i,itp)=0.0d+00
 606                 continue
 605              continue
               else
                  write (fu6,9994)
                  stop 'eeread 10'
               endif
            else
               write (fu6,9994)
               stop 'eeread 11'
            endif
 9994       format (1x,'Error in the argument of FORMDQDPHI keyword')
c
c     FORMDQDR
c
         elseif (word(1) .eq. 'FORMDQDR') then
            if (nword .eq. 2) then
               if (word(2) .eq. 'FULL') then
                  ifmdqr = 2
               elseif (word(2) .eq. 'GAMESS') then
                  ifmdqr = 3
               elseif (word(2) .eq. 'ZERO') then
                  ifmdqr = 0
                  do 705 i=1,mcnatm
                     do 706 j=1,mcnatm*3
                        dqdr0(j,i,itp)=0.0d+00
 706                 continue
 705              continue
               else
                  write (fu6,9993)
                  stop 'eeread 12'
               endif
            else
               write (fu6,9993)
               stop 'eeread 13'
            endif
 9993       format (1x,'Error in the argument of FORMDQDPHI keyword')
c
c     Stop if the keyword is not recognized
c
         else
c
            write(fu6,9900) word(1)
            stop 'eeread 14'
 9900       format (1x,'Error: The following keyword',
     &              ' is not recognized',/a80)
c
         endif
c
c     Read in another keyword
c
         goto 200
c
      endif
c
c     Find the CRK section
c
CAMBP#ifdef MPI
CAMBP      if(master) rewind iunitr
CAMBP#else
      rewind iunitr
CAMBP#endif
 300  call readln(iunitr,word,nword,lsec,leof)
      if (leof) then
         write (fu6,9899) iunitr
 9899    format (1x,'Error: the esp.fu',i2,' file does not',
     &           'contain the CRK section')
         stop 'eeread 15'
      endif
      if (.not. lsec .or. word(1) .ne. 'CRK') goto 300
c
c     Read the keywords
c
 400  call readln(iunitr,word,nword,lsec,leof)
      if (.not. lsec .and. .not. leof) then
c
c     QPHI
c
         if (word(1) .eq. 'QPHI') then
c
CAMBP#ifdef MPI
CAMBP            if(master) then
CAMBP#endif
            if (ifrmqv .eq. 1) then
c
               do 500 i=1,mcnatm
                  read(iunitr,*) chg0(i,itp),phi0(i,itp)
 500           continue
c
            else 
c
               do 510 i=1,mcnatm
                  read(iunitr,*) itmp,chg0(i,itp),phi0(i,itp)
 510           continue
c               
            endif
CAMBP#ifdef MPI
CAMBP            end if
CAMBPc
CAMBP            call mpi_bcast(chg0,2*mcmatm,mpi_double_precision,
CAMBP     &           0,commsander,ier) 
CAMBP            call mpi_bcast(phi0,2*mcmatm,mpi_double_precision,
CAMBP     &           0,commsander,ier) 
CAMBP#endif
c
            call readln(iunitr,word,nword,lsec,leof)
            if (word(1) .ne. 'END') then
               write(fu6,9898)
               stop 'eeread 16'
 9898          format (1x,'Error in reading QPHI keyword')
            end if
c
            if(iuphi .eq. 1) then
               do 520 i=1,mcnatm
                  phi0(i,itp)=phi0(i,itp)/fhaev
 520           continue
            endif
c
c     DQDPHI
c
         elseif (word(1) .eq. 'DQDPHI') then
c
            if((ifmdqv.eq.1).or.(ifmdqv.eq.2)) then
c
               lsec=.false.
               leof=.false.
c
               nk=0
               nj=1
c
 610           call readln(iunitr,word,nword,lsec,leof)
c
               if (word(1).ne.'END') then
c
                  do 620 ni=1,nword
                     nk=nk+1
c
c     If the dQ/d(phi) is in packed form
c
                     if(ifmdqv .eq. 1) then
                        if(nk .gt. nj) then
                           nj=nj+1
                           nk=1
                        end if
                        if(nj .gt. mcnatm) then
                           write(fu6,699) iunitr
                           stop 'eeread 17'
                        end if
                        dqdv0(nj,nk,itp)=cfmct(word(ni))
                        dqdv0(nk,nj,itp)=dqdv0(nj,nk,itp)
c
c     If the dQ/d(phi) is in full form
c
                     else if(ifmdqv .eq. 2) then
                        if(nk .gt. mcnatm) then
                           nj=nj+1
                           nk=1
                        end if
                        if(nj .gt. mcnatm) then
                           write(fu6,699) iunitr
                           stop 'eeread 18'
                        end if
                        dqdv0(nj,nk,itp)=cfmct(word(ni))
                     end if
 620              continue
               else
                  if(nj.ne.mcnatm.or.nk.ne.mcnatm) then
                     write(fu6,698) iunitr
                     stop 'eeread 19'
                  else
                     goto 650
                  endif
               endif
c
               goto 610
c
 698           format(1x,'Error: Not enough numbers entered for the ',
     *                'DQDPHI in the esp.fu',i2)
 699           format(1x,'Error: Too many numbers entered for the ',
     *                'DQDPHI in the esp.fu',i2)
c
 650           continue
c
            elseif (ifmdqv .eq. 3) then
c
c     gamess format
c
CAMBP#ifdef MPI
CAMBP               if(master) then
CAMBP#endif
               do 600 i=1,mcnatm
                  imax=0
 601              continue
                  imin=imax+1
                  imax=imax+5
                  if(imax .gt. mcnatm) imax=mcnatm
                  read(iunitr,9000) ii,ic,(dqdv0(i,j,itp),j=imin,imax)
 9000             format(i2,i3,5e15.8)
                  if(imax .lt. mcnatm) go to 601
 600           continue
CAMBP#ifdef MPI
CAMBP               end if
CAMBP               call mpi_bcast(dqdv0,2*mcmatm*mcmatm,
CAMBP     &                        mpi_double_precision,0,commsander,ier) 
CAMBP#endif
c
               call readln(iunitr,word,nword,lsec,leof)
               if (word(1) .ne. 'END') then
                  write(fu6,9897)
                  stop 'eeread 20'
 9897             format (1x,'Error in reading DQDPHI keyword')
               endif
c
            elseif (ifmdqv .eq. 0) then
c
c     do not read d(chg)/d(phi)
c
c     skip DQDPHI-END section
c
               word(1)=''
               do while (word(1).ne.'END')
                  call readln(iunitr,word,nword,lsec,leof)
               end do
c
            endif
c
            if(iudqdv .eq. 1) then
               do 602 i=1,mcnatm
               do 603 j=1,mcnatm
                  dqdv0(i,j,itp)=dqdv0(i,j,itp)*fhaev
 603           continue
 602           continue
            endif
c
c     DQDR
c
         elseif (word(1) .eq. 'DQDR') then
c
            if(ifmdqr .eq. 2) then
c
               lsec=.false.
               leof=.false.
c
               nk=0
               nj=1
c
 710           call readln(iunitr,word,nword,lsec,leof)
c
               if (word(1).ne.'END') then
c
                  do 720 ni=1,nword
                     nk=nk+1
                     if(nk .gt. 3*mcnatm) then
                        nj=nj+1
                        nk=1
                     end if
                     if(nj .gt. mcnatm) then
                        write(fu6,799) iunitr
                        stop 'eeread 21'
                     end if
                     dqdr0(nk,nj,itp)=cfmct(word(ni))
 720              continue
               else
                  if(nj.ne.mcnatm .or. nk.ne.3*mcnatm) then
                     write(fu6,798) iunitr
                     stop 'eeread 22'
                  else
                     goto 750
                  endif
               endif
c
               goto 710
c
 798           format(1x,'Error: Not enough numbers entered for the ',
     *                'DQDR in the esp.fu',i2)
 799           format(1x,'Error: Too many numbers entered for the ',
     *                'DQDR in the esp.fu',i2)
c
 750           continue
c
            elseif (ifmdqr .eq. 3) then
c
c     gamess format
c
CAMBP#ifdef MPI
CAMBP               if(master) then
CAMBP#endif
               do 700 i=1,mcnatm
                  imax=0
 701              continue
                  imin=imax+1
                  imax=imax+5
                  if(imax .gt. 3*mcnatm) imax=3*mcnatm
                  read(iunitr,9001) ii,ic,(dqdr0(j,i,itp),j=imin,imax)
 9001             format(i2,i3,5e15.8)
                  if(imax .lt. 3*mcnatm) go to 701
 700           continue
c
c               do 700 i=1,3*mcnatm
c                  imax=0
c 710              continue
c                  imin=imax+1
c                  imax=imax+5
c                  if(imax .gt. mcnatm) imax=mcnatm
c                  read(iunitr,9001) ii,ic,(dqdr0(i,j,itp),j=imin,imax)
c 9001             format(i2,i3,5e15.8)
c                  if(imax .lt. mcnatm) go to 710
c 700           continue
c
CAMBP#ifdef MPI
CAMBP               end if
CAMBP               call mpi_bcast(dqdr0,2*mcmcar*mcmatm,
CAMBP     &                        mpi_double_precision,0,commsander,ier) 
CAMBP#endif
               call readln(iunitr,word,nword,lsec,leof)
               if (word(1) .ne. 'END') then
                  write(fu6,9896)
                  stop 'eeread 23'
 9896             format (1x,'Error in reading DQDR keyword')
               endif
c
            elseif (ifmdqr .eq. 0) then
c
c     do not read d(chg)/dR
c
c     skip DQDR-END section
c
               word(1)=''
               do while (word(1).ne.'END')
                  call readln(iunitr,word,nword,lsec,leof)
               end do
c
            endif
c
            if(iudqdr .eq. 1) then
c
               do 702 j=1,mcnatm
               do 703 i=1,3*mcnatm
                  dqdr0(i,j,itp)=dqdr0(i,j,itp)*fboan
 703           continue
 702           continue
c
            endif
c
         else
c
            write(fu6,9800) word(1)
            stop 'eeread 24'
 9800       format (1x,'Error: The following keyword',
     &              ' is not recognized',/a80)
c
         endif
c
c     Read in another keyword
c
         goto 400
c
      endif
c
      return
      end
c
c ************************************************************************
c     eerdps
c ************************************************************************
      subroutine eerdps(mciesp)
c
c     This subroutine reads d(chg)/d(phi) at each Shepard points.
c
      implicit real*8 (a-h,o-z)
c
CAMBP#ifdef MPI
CAMBPc     =========================== AMBER/MPI ===========================
CAMBP#     ifdef MPI_DOUBLE_PRECISION
CAMBP#       undef MPI_DOUBLE_PRECISION
CAMBP#     endif
CAMBP      include 'mpif.h'
CAMBP#     ifdef CRAY_PVP
CAMBP#       define MPI_DOUBLE_PRECISION MPI_REAL8
CAMBP#     endif
CAMBPc     ========================= END AMBER/MPI =========================
CAMBP#     include "parallel.h"
CAMBP#     include "extra.h"
CAMBP#endif
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      character*80 word(40)
      logical lsec,leof
c
      lsec=.false.
      leof=.false.
c
      if((mcifqv.eq.1).or.(mcifqv.eq.2)) then
c
         nk=0
         nj=1
c
 10      call readln(fu83,word,nword,lsec,leof)
c
         if (word(1).ne.'END') then
c
            do 20 ni=1,nword
               nk=nk+1
c
c     If the dQ/d(phi) is in packed form
c
               if(mcifqv .eq. 1) then
                  if(nk .gt. nj) then
                     nj=nj+1
                     nk=1
                  end if
                  if(nj .gt. mcnatm) then
                     write(fu6,99) mciesp
                     stop 'eerdps 1'
                  end if
                  dqdvs(nj,nk,mciesp)=cfmct(word(ni))
                  dqdvs(nk,nj,mciesp)=dqdvs(nj,nk,mciesp)
c
c     If the dQ/d(phi) is in full form
c
               else if(mcifqv .eq. 2) then
                  if(nk .gt. mcnatm) then
                     nj=nj+1
                     nk=1
                  end if
                  if(nj .gt. mcnatm) then
                     write(fu6,99) mciesp
                     stop 'eerdps 2'
                  end if
                  dqdvs(nj,nk,mciesp)=cfmct(word(ni))
               end if
c
 20         continue
c
         else
c
            if(nj.ne.mcnatm.or.nk.ne.mcnatm) then
               write(fu6,98) mciesp
               stop 'eerdps 3'
            else
               goto 50
            end if
c
         end if
c
         goto 10
c
 98      format (1x,'Error: Not enough numbers entered for the ',
     *           'DQDPHI of the Shepard point ',i3)
 99      format (1x,'Error: Too many numbers entered for the ',
     *           'DQDPHI of the Shepard point ',i3)
c
 50      continue
c
      else if (mcifqv .eq. 3) then
c
CAMBP#ifdef MPI
CAMBP         if(master) then
CAMBP#endif
         do 100 i=1,mcnatm
            imax=0
 110        continue
            imin=imax+1
            imax=imax+5
            if(imax .gt. mcnatm) imax=mcnatm
            read(fu83,9000) ii,ic,(dqdvs(i,j,mciesp),j=imin,imax)
 9000       format(i2,i3,5e15.8)
            if(imax .lt. mcnatm) go to 110
 100     continue
CAMBP#ifdef MPI
CAMBP         end if
CAMBP         call mpi_bcast(dqdvs,mcmatm*mcmatm*mcmesp,
CAMBP     &                  mpi_double_precision,0,commsander,ier) 
CAMBP#endif
c
         call readln(fu83,word,nword,lsec,leof)
         if (word(1) .ne. 'END') then
            write(fu6,9999) mciesp
            stop 'eerdps 4'
 9999       format (1x,'Error in reading DQDPHI keyword of ',
     &              'the Shepard point ',i3,' in esp.fu83')
         endif
c
      else if (mcifqv .eq. 0) then
c
c     do not read d(chg)/d(phi)
c
c     skip DQDPHI-END section
c
         word(1)=''
         do while (word(1).ne.'END')
            call readln(fu83,word,nword,lsec,leof)
         end do
         return
c
      endif
c
      if(mciuvs .eq. 2) then
         do 200 i=1,mcnatm
            do 210 j=1,mcnatm
               dqdvs(i,j,mciesp)=dqdvs(i,j,mciesp)*fhaev
 210        continue
 200     continue
      endif
c
      return
      end
c
c ************************************************************************
c     eerdrs
c ************************************************************************
      subroutine eerdrs(mciesp)
c
c     This subroutine reads d(chg)/dR at each Shepard points.
c
      implicit real*8 (a-h,o-z)
CAMBP#ifdef MPI
CAMBPc     =========================== AMBER/MPI ===========================
CAMBP#     ifdef MPI_DOUBLE_PRECISION
CAMBP#       undef MPI_DOUBLE_PRECISION
CAMBP#     endif
CAMBP      include 'mpif.h'
CAMBP#     ifdef CRAY_PVP
CAMBP#       define MPI_DOUBLE_PRECISION MPI_REAL8
CAMBP#     endif
CAMBPc     ========================= END AMBER/MPI =========================
CAMBP#     include "parallel.h"
CAMBP#     include "extra.h"
CAMBP#endif
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      character*80 word(40)
      logical lsec,leof
c
      lsec=.false.
      leof=.false.
c
c
      if(mcifqr .eq. 2) then
c
c     full format
c
         nk=0
         nj=1
c
 10      call readln(fu83,word,nword,lsec,leof)
c
         if (word(1).ne.'END') then
c
            do 20 ni=1,nword
               nk=nk+1
               if(nk .gt. 3*mcnatm) then
                  nj=nj+1
                  nk=1
               end if
               if(nj .gt. mcnatm) then
                  write(fu6,99) mciesp
                  stop 'eerdrs 1'
               end if
               dqdrs(nk,nj,mciesp)=cfmct(word(ni))
 20         continue
c
         else
c
            if(nj.ne.mcnatm .or. nk.ne.3*mcnatm) then
               write(fu6,98) mciesp
               stop 'eerdrs 2'
            else
               goto 50
            end if
c
         end if
c
         goto 10
c
 98      format (1x,'Error: Not enough numbers entered for the ',
     *           'DQDR of the Shepard point ',i3)
 99      format (1x,'Error: Too many numbers entered for the ',
     *           'DQDR of the Shepard point ',i3)
c
 50      continue
c
      else if (mcifqr .eq. 3) then
c
c     gamess format
c
CAMBP#ifdef MPI
CAMBP         if(master) then
CAMBP#endif
         do 100 i=1,mcnatm
            imax=0
 110        continue
            imin=imax+1
            imax=imax+5
            if(imax .gt. 3*mcnatm) imax=3*mcnatm
            read(fu83,9000) ii,ic,(dqdrs(j,i,mciesp),j=imin,imax)
 9000       format(i2,i3,5e15.8)
            if(imax .lt. 3*mcnatm) go to 110
 100     continue
c
c         do 100 i=1,3*mcnatm
c            imax=0
c 110        continue
c            imin=imax+1
c            imax=imax+5
c            if(imax .gt. mcnatm) imax=mcnatm
c            read(fu83,9000) ii,ic,(dqdrs(i,j,mciesp),j=imin,imax)
c 9000       format(i2,i3,5e15.8)
c            if(imax .lt. mcnatm) go to 110
c 100     continue
c
CAMBP#ifdef MPI
CAMBP         end if
CAMBP         call mpi_bcast(dqdrs,mcmcar*mcmatm*mcmesp,
CAMBP     &                  mpi_double_precision,0,commsander,ier) 
CAMBP#endif
         call readln(fu83,word,nword,lsec,leof)
         if (word(1) .ne. 'END') then
            write(fu6,9999) mciesp
            stop 'eerdrs 3'
 9999       format (1x,'Error in reading DQDR keyword of ',
     &              'the Shepard point ',i3,' in esp.fu83')
         endif
c
      else if (mcifqr .eq. 0) then
c
c     do not read d(chg)/dr
c
c     skip DQDR-END section
c
         word(1)=''
         do while (word(1).ne.'END')
            call readln(fu83,word,nword,lsec,leof)
         end do
c
      endif
c
      if(mciurs .eq. 2) then
c
         do 200 j=1,mcnatm
            do 210 i=1,3*mcnatm
               dqdrs(i,j,mciesp)=dqdrs(i,j,mciesp)*fboan
 210        continue
 200     continue
c
      endif
c
      return
      end
c
c ************************************************************************
c     eerqps
c ************************************************************************
      subroutine eerqps(mciesp)
c
c     This subroutine reads charges and potentials at each Shepard points.
c
      implicit real*8 (a-h,o-z)
c
CAMBP#ifdef MPI
CAMBPc     =========================== AMBER/MPI ===========================
CAMBP#     ifdef MPI_DOUBLE_PRECISION
CAMBP#       undef MPI_DOUBLE_PRECISION
CAMBP#     endif
CAMBP      include 'mpif.h'
CAMBP#     ifdef CRAY_PVP
CAMBP#       define MPI_DOUBLE_PRECISION MPI_REAL8
CAMBP#     endif
CAMBPc     ========================= END AMBER/MPI =========================
CAMBP#     include "parallel.h"
CAMBP#     include "extra.h"
CAMBP#endif
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      character*80 word(40)
      logical lsec,leof
c
c
CAMBP#ifdef MPI
CAMBP      if(master) then
CAMBP#endif
      if (mcifqs .eq. 1) then
c
         do 100 i=1,mcnatm
            read(fu83,*) chgs(i,mciesp),phis(i,mciesp)
 100     continue
c
      else 
c
         do 110 i=1,mcnatm
            read(fu83,*) itmp,chgs(i,mciesp),phis(i,mciesp)
 110     continue
c               
      endif
c
CAMBP#ifdef MPI
CAMBP      end if
CAMBP      call mpi_bcast(chgs,mcmatm*mcmesp,mpi_double_precision,
CAMBP     &           0,commsander,ier) 
CAMBP      call mpi_bcast(phis,mcmatm*mcmesp,mpi_double_precision,
CAMBP     &           0,commsander,ier) 
CAMBP#endif
c
      call readln(fu83,word,nword,lsec,leof)
      if (word(1) .ne. 'END') then
         write(fu6,9999)
         stop 'eerqps 1'
 9999    format (1x,'Error in reading QPHI keyword in esp.fu83')
      end if
c
      if(mciups .eq. 2) then
         do 200 i=1,mcnatm
            phis(i,mciesp)=phis(i,mciesp)/fhaev
 200     continue
      endif
c
      return
      end
c>>>>                                                                    0529MH10
c***********************************************************************
c     eestiz
c***********************************************************************
c
      subroutine eestiz
c
c     This subroutine specifies which internal coordinates
c     the diagonal EE-MM calculations are independent of. 
c
      implicit double precision (a-h, o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      icz=0
c
c     bond
c
      if (mendiz.ne.0) then
c
         do 100 iz=1,mendiz
c
            do 110 is=1,mcndis
               if((meidiz(1,iz).eq.mcidis(1,is)).and.
     &            (meidiz(2,iz).eq.mcidis(2,is))) then
                  icz=icz+1
                  meiczr(icz)=is
                  goto 150
               end if
 110        continue
c
            write(fu6,9001) meidiz(1,iz),meidiz(2,iz)
            stop 'eestiz 1'
c
 150        continue
c
 100     continue
c
      end if
c
c     angle
c
      if (menanz.ne.0) then
c
         do 200 iz=1,menanz
c
            do 210 is=1,mcnans
               if (meianz(1,iz).eq.mcians(1,is)) then
               if (meianz(2,iz).eq.mcians(2,is)) then
               if (meianz(3,iz).eq.mcians(3,is)) then
                  icz=icz+1
                  meiczr(icz)=mcndis+is
                  goto 250
               end if
               end if
               end if
 210        continue
c
            write(fu6,9002) meianz(1,iz),meianz(2,iz),meianz(3,iz)
            stop 'eestiz 2'
c
 250        continue
c
 200     continue
c
      end if
c
c     dihedral angle
c
      if (mendaz.ne.0) then
c
         do 300 iz=1,mendaz
c
            do 310 is=1,mcndas
               if (meidaz(1,iz).eq.mcidas(1,is)) then
               if (meidaz(2,iz).eq.mcidas(2,is)) then
               if (meidaz(3,iz).eq.mcidas(3,is)) then
               if (meidaz(4,iz).eq.mcidas(4,is)) then
                  icz=icz+1
                  meiczr(icz)=mcndis+mcnans+is
                  goto 350
               end if
               end if
               end if
               end if
 310        continue
c
            write(fu6,9003) meidaz(1,iz),meidaz(2,iz),
     &                      meidaz(3,iz),meidaz(4,iz)
            stop 'eestiz 3'
c
 350        continue
c
 300     continue
c
      end if
c
c     linear bend
c
      if (menadz.ne.0) then
c
         do 400 iz=1,menadz
c
            do 410 is=1,mcnads
               if (meiadz(1,iz).eq.mciads(1,is)) then
               if (meiadz(2,iz).eq.mciads(2,is)) then
               if (meiadz(3,iz).eq.mciads(3,is)) then
                  icz=icz+1
                  meiczr(icz)=mcndis+mcnans+mcndas+is
                  goto 450
               end if
               end if
               end if
 410        continue
c
            write(fu6,9004) meiadz(1,iz),meiadz(2,iz),meiadz(3,iz)
            stop 'eestiz 4'
c
 450        continue
c
 400     continue
c
      end if
c
c$$$      write(*,*) 'menicz=',menicz
c$$$      write(*,*) 'mendiz=',mendiz
c$$$      write(*,*) 'menanz=',menanz
c$$$      write(*,*) 'menadz=',menadz
c$$$      write(*,*) 'mendaz=',mendaz
c$$$      write(*,*) 'meiczr',(meiczr(i),i=1,menicz)
c
c
c
      return
c
 9001 format(3x,'Error: the internal coordinate of distance ',
     &       i3,'-',i3,' in ICEEZERO is not included in ICSHEPARD.')
 9002 format(3x,'Error: the internal coordinate of angle ',i3,'-',
     &       i3,'-',i3,' in ICEEZERO is not included in ICSHEPARD.')
 9003 format(3x,'Error: the internal coordinate of dihedral angle ',
     &       i3,'-',i3,'-',i3,'-',i3,' in ICEEZERO is not included ',
     &       'in ICSHEPARD.')
 9004 format(3x,'Error: the internal coordinate of digenerate angle ',
     &       i3,'=',i3,'=',i3,' in ICEEZERO is not included ',
     &       'in ICSHEPARD.')
c
      end
c<<<<                                                                    0529MH10
c***********************************************************************
c     eetiqr
c***********************************************************************
c
      subroutine eetiqr(itp)
c
c     Subroutine to tranformed d(chg)/dr into internal coordinates.
c     This is a modified version of subroutine mctesi.
c
      implicit double precision (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      dimension d0(mcmcar),dxint0(mcmics)
      dimension xc(mcmatm),yc(mcmatm),zc(mcmatm)
      dimension amatb(mcmics,mcmcar),amatbi(mcmcar,mcmics)
      dimension amasin(mcmcar,mcmcar),egnm(mcmics,mcmics)
      dimension flgm(mcmics),ggi(mcmics,mcmics),gm(mcmics,mcmics)
c
      logical redun
c
c     Assign the number of vibrational degree of fredom which is diferent
c     depending if the system is linear or not. Similar determinations
c     were done in subroutine redgeo in Polyrate. Check for redundant 
c     internal coordinates (curv3 option in Polyrate) or for nonredundant
c     internal coordinates (curv2 option in Polyrate) where the number should
c     be 3N-5 or 3N-6 (N = no of atoms in the system) depending if the system
c     is linear or not.
c
      if (mcilin.eq.1) then
         mcnvdf = 3*mcnatm - 5
         if (mcnics.eq.mcnvdf) then
            redun = .false.
         elseif (mcnics.gt.mcnvdf) then
            redun = .true.
         else
            write (fu6,9999) mcnics, mcnvdf
            stop 'eetiqr 1'
         endif
      elseif (mcilin.eq.0) then
         mcnvdf = 3*mcnatm - 6
         if (mcnics.eq.mcnvdf) then
            redun = .false.
         elseif (mcnics.gt.mcnvdf) then
            redun = .true.
         else
            write (fu6,9999) mcnics, mcnvdf
            stop 'eetiqr 2'
         endif
      endif
c
 9999 format (1x,'ERROR: ',i5,' internal coordinates are not ',
     *           'enough to properly span',
     *       /1x,'the vibrational space. Consider increasing the ',
     *           'number of internal coordinates to',i5,'.')
c
c
c
      mcncar = 3*mcnatm
c
      do 100 i = 1, mcnatm
         xc(i) = xrc(3*i-2,itp)
         yc(i) = xrc(3*i-1,itp)
         zc(i) = xrc(3*i,itp)
 100  continue
c
c
c
      do 1000 ichg=1,mcnatm
c
         do 200 i=1,mcncar
            d0(i)=dqdr0(i,ichg,itp)
 200     continue
c
c     calculate B-matrix
c
         call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,
     *                 mcidas,mciads,xc,yc,zc,mcnatm,mcnics,
     *                 amatb,t,mcmatm,mcmics,mcmcar)
c
c     calculate A-matrix (B-inverse matrix)
c
         if (redun) then
            call mcybimat2 (amatb,amatbi,cmmc,amasin,gm,ggi,flgm,
     *                      egnm,smmc,mcnatm,mcnics,mcmics,mcmcar)
         else
            call mcybimat (amatb,amatbi,cmmc,amasin,gm,smmc,
     *                     mcnatm,mcnics,mcmics,mcmcar)
         end if
c
c
c     transform the d(chg)/dr
c
         call trangj (dxint0,amatbi,d0,mcnics,mcncar,mcmics,mcmcar)
c
         do 300 i=1,mcnics
            dqdri0(i,ichg,itp)=dxint0(i)
 300     continue
c
 1000 continue
c>>>>                                                                    0529MH10
c     set zero according to ICEEZERO
c
      if (menicz.ne.0) then
c
         do 500 iz=1,menicz
            icz=meiczr(iz)
            do 510 ichg=1,mcnatm
               dqdri0(icz,ichg,itp)=0.0d+00
 510        continue
 500     continue
c
      end if
c<<<<                                                                    0529MH10
      return
      end
c
c***********************************************************************
c     eetmmg
c***********************************************************************
c
      subroutine eetmmg(itp)
c
c     This subroutine transform the coordinates read from units 81 and 82
c     into internal coordinates
C     This is a slightly modified version of subroutine mctmmg.
c
      implicit double precision (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      dimension dics(mcmics)
      dimension xc(mcmatm),yc(mcmatm),zc(mcmatm)
c
      do 100 i = 1, mcnatm
         xc(i) = xrc(3*i-2,itp)
         yc(i) = xrc(3*i-1,itp)
         zc(i) = xrc(3*i,itp)
 100  continue
c
c     Transform molecular mechanics units 81 or 82 geometry into the
c     internal coordinates used for Shepard interpolation
c
      call mctcic(mcndis,mcnans,mcnads,mcndas,
     *            mcidis,mcians,mciads,mcidas,
     *            mcmics,mcmatm,xc,yc,zc,dics)
c

      do 200 i = 1, mcnics
         qii0(i,itp) = dics(i)
 200  continue
c
      return
      end
c
c***********************************************************************
c     eev12c
c***********************************************************************
c
      subroutine eev12c(xii,phi,e12,g12,h12,chg12,dqdv12,dqdr12,itypec)     
c
c     This subroutine calculates the resonance function and its derivative
c     in Cartesian coordinates. It is a modified version of subroutine mcv12c.
c
      implicit double precision (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      parameter (mcmca2=mcmcar*(mcmcar+1)/2)
      parameter (mcmic2=mcmics*(mcmics+1)/2)
      parameter (zero=0.d0)
c
      dimension xii(mcmcar),phi(mcmatm)
      dimension g12(mcmcar),h12(mcmcar,mcmcar) 
      dimension gi12(mcmics),hi12(mcmics,mcmics) 
      dimension chg12(mcmatm),dqdv12(mcmatm,mcmatm)
      dimension dqdr12(mcmcar,mcmatm),dqdri12(mcmics,mcmatm)
      dimension xc(mcmatm),yc(mcmatm),zc(mcmatm)
c
c     Dimension main matrices
c
      dimension amatb(mcmics,mcmcar)
      dimension amatbtc(mcmics,mcmca2)
      dimension amat2(mcmca2)
      dimension amat2i(mcmic2)
      dimension amat3(mcmca2)
      dimension scr4(mcmcar,mcmcar)
      dimension scr5(mcmics,mcmcar)
c
      dimension grv(mcmcar),grvi(mcmcar)
c
c     Store the orientation of the coordinate system for L bend
c
      dimension t(3,3)
c
c     Set number of internal and cartesian coordinates
c
      mcncar = 3*mcnatm
c
c     Zero out the gradient and Hessian elements and initialize
c     some variables.
c
      e12 = zero
      do i = 1, mcnics
         gi12(i) = zero
         do j = 1, mcnics
            hi12(i,j) = zero
         end do
      end do
      do i= 1, mcnatm
         chg12(i) = zero
         do j = 1, mcnatm
            dqdv12(j,i) = zero
         end do
         do j = 1, mcnics
            dqdri12(j,i) = zero
         end do
      end do
c
c  If Resonance integral is constant then e12 is read in and gradient
c  and Hessian elements are all zero as they were initialized.
c
      if (mcimre.eq.0) then
         e12 = e12ct
c
c  If Resonance integral is not constant
c
      else if (mcimre.gt.0) then
c
c  Tranform from Cartesian coordinates into the internal coordinates
c  used for Shepard interpolation
c
         do j = 1, mcmatm
            xc(j) = xii(3*j-2)
            yc(j) = xii(3*j-1)
            zc(j) = xii(3*j)
         end do
         call mctcic(mcndis,mcnans,mcnads,mcndas,
     *               mcidis,mcians,mciads,mcidas,
     *               mcmics,mcmatm,xc,yc,zc,qs)
c
c  Transform from Cartesian coordinates into the internal coordinates
c  used for generalized distances
c
         call mctcic(mcndid,mcnand,mcnadd,mcndad,
     *               mcidid,mciand,mciadd,mcidad,
     *               mcmicd,mcmatm,xc,yc,zc,qd)
c
c  if gradients are calculated, get B
c
         if (itypec.gt.1) then
            call mcybmat (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,
     *                    mcidas,mciads,xc,yc,zc,mcnatm,mcnics,
     *                    amatb,t,mcmatm,mcmics,mcmcar)
         endif
c
c
c  if hessian are calculated get the tensor C
c
         if (itypec.gt.2) then                
            do i = 1, mcmca2
               do j=1,mcmics
                  amatbtc(j,i) = zero
               enddo 
            end do
            call btenscj (mcndis,mcnans,mcndas,mcnads,mcidis,mcians,
     *                    mcidas,mciads,xc,yc,zc,mcnatm,scr4,
     *                    amatbtc,mcnics,mcncar,mcmics,mcmca2,
     *                    mcmatm,mcmcar,t)
         endif
c
c**********************************************************************
         if (icomplex.eq.1) then
            call eev12i(phi,e12,gi12,hi12,chg12,dqdv12,dqdri12,
     &                  itypec)

         else
            call eev12iold(phi,e12,gi12,hi12,chg12,dqdv12,dqdri12,
     &                     itypec)
         end if
c**********************************************************************
c
c  after this, the gradient and the hessian must be
c  retransformed to cartesian coordinates in order to add it
c  to the gradients and hessians obtained for E1 and E2
c 
         if (itypec .gt. 1) then
            call trangj (g12,amatb,gi12,mcncar,mcnics,mcmcar,mcmics)
            if (itypec .gt. 2) then
               call formf2cj (amat2,amatbtc,
     *                    gi12,mcmics,mcmca2,mcnics,mcncar)
               call tranlfj (amat2i,hi12,mcnics,mcmic2,mcmics)
               call tranfcj (amat3,amatb,scr5,amat2i,amat2,
     *               mcnatm,mcmics,mcmcar,mcmic2,mcmca2,mcnics)
c
               indic = 1
               do i = 1, mcncar
                  do j = 1, i
                     h12(i,j) = amat3(indic)
                     h12(j,i) = h12(i,j)
                     indic = indic + 1
                  end do
               end do
            end if
         end if
c
c     transform from the internal coordinates to Cartesian coordinates
c
         if(mccdqr.eq.1) then
c
            do 100 i=1,mcnatm
c
               do 110 j=1,mcnics
                  grvi(j)=dqdri12(j,i)
 110           continue
               call trangj(grv,amatb,grvi,mcncar,mcnics,mcmcar,mcmics)
               do 120 j=1,mcncar
                  dqdr12(j,i)=grv(j)
 120           continue
c
 100        continue
c
         end if
c
      endif
c
c
c
      return
      end
c
c***********************************************************************
c     eev12i
c***********************************************************************
c
      subroutine eev12i(phi,e12,gi12,hi12,chg12,dqdv12,dqdri12,itypec)
c
c     This subroutine is a modified version of subroutine h12egh in Tinkerate.
c     This subroutine calculates e12, gradients (gi12), and Hessian (hi12)
c     using the weighting function.
c     (Titus V Albu January 2002). Modified by O.T. (May 2007, Dec. 2008).
c
      implicit double precision (a-h, o-z)
c
CAMBP#ifdef MPI
CAMBPc     =========================== AMBER/MPI ===========================
CAMBP#     ifdef MPI_DOUBLE_PRECISION
CAMBP#       undef MPI_DOUBLE_PRECISION
CAMBP#     endif
CAMBP      include 'mpif.h'
CAMBP#     ifdef CRAY_PVP
CAMBP#       define MPI_DOUBLE_PRECISION MPI_REAL8
CAMBP#     endif
CAMBPc     ========================= END AMBER/MPI =========================
CAMBP#     include "parallel.h"
CAMBP#     include "extra.h"
CAMBPc
CAMBP      dimension gi12tmp(mcnics),chg12tmp(mcnatm)
CAMBP#endif
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      dimension dqs(mcmics,mcmesp+2),dqd(mcmicd,mcmesp+2)
      dimension w(mcmesp*6+12)
c      dimension d2wf(mcmicd,mcmicd,mcmesp+2)
      dimension d2wf(mcmicd,mcmicd,mcmesp*6+12)
c
      dimension e12p(mcmesp)
      dimension gi12pnt(mcmics),gi12(mcmics),hi12(mcmics,mcmics)
      dimension wrk(mcmics),wrk1(mcmics),gi12a(mcmics),gi12b(mcmics)
      dimension dwf(mcmesp*6+12,mcmics)
c      dimension dwf(mcmesp+2,mcmics)
c
      dimension phi(mcmatm),dphi(mcmatm,mcmesp+2)
      dimension chg12(mcmatm),chg12pnt(mcmatm)
      dimension dqdv12(mcmatm,mcmatm),dqdri12(mcmics,mcmatm)
      dimension wrkv(mcmatm),wrkr(mcmatm)
      dimension wrk1v(mcmatm),wrk1r(mcmics)
c
      dimension dqs2(mcmics,mcmesp+2),ddqs2(mcmics,mcmesp+2)             0527MH10
      dimension d2dqs2(mcmics,mcmesp+2)                                  0527MH10
c 
c     zero out Shepard variables
c
      do i=1,mcnics
        gi12a(i)  = 0.d0
        gi12b(i)  = 0.d0
      enddo
c
c     calculate the displacement in internal coordinates used for
c     Shepard interpolation
c
c       write (*,*) "QD",qd(1),qs(2)
c       qd(1)=qd(1)-0.001
c       qs(2)=qs(2)-0.001
c       write (*,*) "QD'",qd(1)
c       write (*,*) "QD'",qs(2)
c
      do j=1,mcnesp+2
         do i=1,mcnics
            dqs(i,j)=qs(i)-qs0(i,j)
         enddo
         if (mcndas.gt.0) then
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas
               if (dqs(i,j).lt.-fpi) then
                   dqs(i,j) = dqs(i,j)+2.0d0*fpi
               elseif (dqs(i,j).gt.fpi) then
                   dqs(i,j) = dqs(i,j)-2.0d0*fpi
               endif
            enddo
         endif
      enddo
c
      do 100 j=1,mcnesp
         do 110 i=1,mcnatm
            dphi(i,j)=phi(i)-phis(i,j)
 110     continue
 100  continue
c
      do 120 i=1,mcnatm
         dphi(i,mcnesp+1)=phi(i)-phi0(i,1)
         dphi(i,mcnesp+2)=phi(i)-phi0(i,2)
 120  continue
c
c     call the mcswts subroutine that determines the weights function and 
c     its derivatives with respect to the internal coordinates used for 
c     both Shepard interpolation and generalized distances.
c
       if (ijacob.eq.0) then                                             0108OT09
          call mcswtsnum(w,dwf,d2wf,itypec)                              0505OT07
       else                                                              0108OT09
          call mcswtsnum1(w,dwf,d2wf,itypec)                             0108OT09
       endif                                                             0108OT09
c
c     for every interpolation point with weight larger than zero
c     calculate first and second derivatives
c
c     for molecular mechanics Shepard points (which are listed as the next
c     to the last and the last),e12=0.d0 since we assume that Molecular 
c     Mechanics force field can describe them correctly.
c
c
CAMBP#ifdef MPI
CAMBP      ipcount=mytaskid+1
CAMBP#endif
      if (mcsins.ne.0) goto 2000                                         0527MH10
c
      do 1000 mciesp=1,mcnesp
        if (w(mciesp).gt.0.d0) then
CAMBP#ifdef MPI
CAMBP           ipcount=ipcount+1
CAMBP           if(mod(ipcount,numtasks).ne.0) goto 1000
CAMBP#endif
c
c     Form of V12:  mcifre = 1  generalized gaussian (not used anymore)
c                   mcifre = 2  simple quadratic
c
c------------------- calculate e12 --------------------------------
c
          btrm=0.d0
          ctrm=0.d0
          qtrm=0.d0
c
          do i=1,mcnics
            wrk(i) =0.d0
            btrm=btrm+bevbm(i,mciesp)*dqs(i,mciesp)
            do j=1,mcnics
              wrk(i)=wrk(i)+dqs(j,mciesp)*cevbm(i,j,mciesp)
            enddo
            ctrm=ctrm+dqs(i,mciesp)*wrk(i)
          enddo
c
          do 200 i=1,mcnatm
             wrkv(i)=0.0d+00
             wrkr(i)=0.0d+00
             btrm=btrm+bee(i,mciesp)*dphi(i,mciesp)
             do 210 j=1,mcnatm
                wrkv(i)=wrkv(i)+dphi(j,mciesp)*ceevv(i,j,mciesp)
 210         continue
             do 220 j=1,mcnics
                wrkr(i)=wrkr(i)+dqs(j,mciesp)*ceerv(j,i,mciesp)
 220         continue
             ctrm=ctrm+dphi(i,mciesp)*(wrkv(i)+2.0d+00*wrkr(i))
 200      continue
c
          be12 = 1.d0+btrm+0.5d0*ctrm
          e12p(mciesp) = aevbm(mciesp)*be12
c |V12|^2=          
          e12 = e12+w(mciesp)**1.d0*e12p(mciesp)                         0108OT09
c
c          write (6,*) "WW", w(mciesp),mciesp
c
c------------------end of e12------------------------------------
c
c------------------ begin calculating the charges -----
c
          do 300 k=1,mcnatm
             chg12pnt(k)=aevbm(mciesp)
     &                  *(bee(k,mciesp)+wrkv(k)+wrkr(k))
 300      continue
c
c     weight the gradient
c
          do 310 k=1,mcnatm
             chg12(k)=chg12(k)+chg12pnt(k)*w(mciesp)                     0505OT07
 310      continue
c
c------------------ begin calculating the dqdv12 -----
c
         if (mccdqv.eq.1) then
            do 400 ik=1,mcnatm
            do 410 is=ik,mcnatm
               dqdv12(is,ik)=dqdv12(is,ik)
     &        +w(mciesp)*aevbm(mciesp)
     &        *0.5d+00*(ceevv(is,ik,mciesp)+ceevv(ik,is,mciesp))
               dqdv12(ik,is)=dqdv12(is,ik)
 410        continue
 400        continue
         endif
c
c------------------ begin calculating the first derivatives -----
c
c     first check if it is necessary (itypec >= 1)
c
          if (itypec .eq. 1) goto 1000
          do k=1,mcnics
            wrk1s = 0.d0
              do k1 = 1,mcnics
                wrk1s = wrk1s+cevbm(k1,k,mciesp)*dqs(k1,mciesp)
              enddo
            wrk1(k) = wrk1s
          enddo
c
          do 500 i=1,mcnics
             wrk1r(i)=0.0d+00
             do 510 j=1,mcnatm
                wrk1r(i)=wrk1r(i)+dphi(j,mciesp)*ceerv(i,j,mciesp)
 510         continue
 500      continue
c
          do k=1,mcnics
                gi12pnt(k)=aevbm(mciesp)*(bevbm(k,mciesp)               0108OT09
     *                    +0.5d0*(wrk(k)+wrk1(k))+wrk1r(k))             0108OT09
          enddo
c
c     weight the gradient
c
c 
          do k=1,mcnics
            gi12b(k) = gi12b(k) + gi12pnt(k)*w(mciesp)                   0505OT07
          enddo
c
c     if shepard interpolation is used, calculate (dw_k/dr)*V12(r;k)^2
c
          if (mcimre.eq.2) then
            do kw=1,mcnics
             gi12a(kw)=gi12a(kw)+dwf(mciesp,kw)*e12p(mciesp)             0108OT09
            enddo
             do k=1,mcnics
              gi12(k)=gi12a(k)+gi12b(k)                                  0505OT07
            enddo
           else if (mcimre.eq.1) then                                    0505OT07
            do k=1,mcnics                                                0505OT07
             gi12(k)=gi12b(k)                                            0505OT07
            enddo
          endif
c
c----------------- end of first derivative calculations ------
c
c
c------------------ begin calculating the dqdri12 -----
c
         if (mccdqr.eq.1) then
c
            do 600 ik=1,mcnatm
            do 610 is=1,mcnics
               dqdri12(is,ik)=dqdri12(is,ik)
     &        +w(mciesp)*aevbm(mciesp)*ceerv(is,ik,mciesp)
 610        continue
 600        continue
c
            if (mcimre.eq.2) then
               do 650 ik=1,mcnicb
                  iwk=mciicb(ik)
               do 660 j=1,mcnatm
                  dqdri12(iwk,j)=dqdri12(iwk,j)
     &                          +dwf(mciesp,iwk)*chg12pnt(j)
 660           continue
 650           continue
            endif
c
         end if
c
c------------------ begin calculating the hessian -----
c
c     first check if it is necessary (itypec = 2)
c
          if (itypec .eq. 2) goto 1000
c
c   1. calculate dd(e12(i))/(dqs(k)dqs(s))*w(i))                              0505OT07
c
            do ik=1,mcnics
              do is=ik,mcnics
                  hi12(is,ik)=hi12(is,ik)+aevbm(mciesp)*                      0108OT09
     *            0.5d0*(cevbm(is,ik,mciesp)+                                 0108OT09
     *            cevbm(ik,is,mciesp))*w(mciesp)                              0108OT09
                  hi12(ik,is)=hi12(is,ik)                           
              enddo
            enddo
c
c     if shepard interpolation is on, calculate the second term:
c   2. e12(i)*ddW(i)/(dqs(k)dqs(s))
c
          if (mcimre.eq.2) then
                do iwk=1,mcnics
                do iws=iwk,mcnics
               hi12(iws,iwk)=hi12(iws,iwk)+                          
     *         d2wf(iws,iwk,mciesp)*e12p(mciesp)                               0108OT09   
                hi12(iwk,iws)=hi12(iws,iwk)                            
              enddo
c
c   3. calculate cross terms
c
              do j=1,mcnics
               hi12(iwk,j)=hi12(iwk,j)+dwf(mciesp,iwk)*gi12pnt(j)             
               hi12(j,iwk)=hi12(j,iwk)+dwf(mciesp,iwk)*gi12pnt(j)             
              enddo
            enddo
          endif
        endif
c
c     end of loop over number of shepard points
c
 1000 continue
c
CAMBP#ifdef MPI
CAMBPc
CAMBPc     sum up
CAMBPc
CAMBP      call mpi_allreduce(e12,e12tmp,1,
CAMBP     &     mpi_double_precision,mpi_sum,commsander,ierr)
CAMBP      e12=e12tmp
CAMBPc
CAMBP      call mpi_allreduce(gi12,gi12tmp,mcnics,
CAMBP     &     mpi_double_precision,mpi_sum,commsander,ierr)
CAMBP      do i=1,mcnics
CAMBP         gi12(i)=gi12tmp(i)
CAMBP      end do
CAMBPc
CAMBP      call mpi_allreduce(chg12,chg12tmp,mcnatm,
CAMBP     &     mpi_double_precision,mpi_sum,commsander,ierr)
CAMBP      do i=1,mcnatm
CAMBP         chg12(i)=chg12tmp(i)
CAMBP      end do
CAMBPc
CAMBP#endif
c
      return
c>>>>                                                                    0527MH10
 2000 continue
c
c     ----- use sin(pn*d(dihedral))/pn for dihedral angles -----
c
      do 1001 mciesp=1,mcnesp
        if (w(mciesp).gt.0.d0) then
c
CAMBP#ifdef MPI
CAMBP           ipcount=ipcount+1
CAMBP           if(mod(ipcount,numtasks).ne.0) goto 1001
CAMBP#endif
c
c     Form of V12:  mcifre = 1  generalized gaussian (not used anymore)
c                   mcifre = 2  simple quadratic
c
c------------------- calculate e12 --------------------------------
c
          btrm=0.d0
          ctrm=0.d0
          qtrm=0.d0
c
          do i=1,mcndis+mcnans
             dqs2(i,mciesp)=dqs(i,mciesp)
          end do
          do i=mcndis+mcnans+1,mcndis+mcnans+mcndas
             pn=dble(mcpnds(i-mcndis-mcnans))
             dqs2(i,mciesp)=sin(pn*dqs(i,mciesp))/pn
          end do
          do i=mcndis+mcnans+mcndas+1,mcnics
             dqs2(i,mciesp)=dqs(i,mciesp)
          end do
c
          do i=1,mcnics
            wrk(i) =0.d0
            btrm=btrm+bevbm(i,mciesp)*dqs2(i,mciesp)
            do j=1,mcnics
              wrk(i)=wrk(i)+dqs2(j,mciesp)*cevbm(i,j,mciesp)
            enddo
            ctrm=ctrm+dqs2(i,mciesp)*wrk(i)
          enddo
c
          do 201 i=1,mcnatm
             wrkv(i)=0.0d+00
             wrkr(i)=0.0d+00
             btrm=btrm+bee(i,mciesp)*dphi(i,mciesp)
             do 211 j=1,mcnatm
                wrkv(i)=wrkv(i)+dphi(j,mciesp)*ceevv(i,j,mciesp)
 211         continue
             do 221 j=1,mcnics
                wrkr(i)=wrkr(i)+dqs2(j,mciesp)*ceerv(j,i,mciesp)
 221         continue
             ctrm=ctrm+dphi(i,mciesp)*(wrkv(i)+2.0d+00*wrkr(i))
 201      continue
c
          be12 = 1.d0+btrm+0.5d0*ctrm
          e12p(mciesp) = aevbm(mciesp)*be12
c |V12|^2=          
          e12 = e12+w(mciesp)**1.d0*e12p(mciesp)                         0108OT09
c
c          write (6,*) "WW", w(mciesp),mciesp
c
c------------------end of e12------------------------------------
c
c------------------ begin calculating the charges -----
c
          do 301 k=1,mcnatm
             chg12pnt(k)=aevbm(mciesp)
     &                  *(bee(k,mciesp)+wrkv(k)+wrkr(k))
 301      continue
c
c     weight the gradient
c
          do 311 k=1,mcnatm
             chg12(k)=chg12(k)+chg12pnt(k)*w(mciesp)                     0505OT07
 311      continue
c
c------------------ begin calculating the dqdv12 -----
c
         if (mccdqv.eq.1) then
            do 401 ik=1,mcnatm
            do 411 is=ik,mcnatm
               dqdv12(is,ik)=dqdv12(is,ik)
     &        +w(mciesp)*aevbm(mciesp)
     &        *0.5d+00*(ceevv(is,ik,mciesp)+ceevv(ik,is,mciesp))
               dqdv12(ik,is)=dqdv12(is,ik)
 411        continue
 401        continue
         endif
c
c------------------ begin calculating the first derivatives -----
c
c     first check if it is necessary (itypec >= 1)
c
          if (itypec .eq. 1) goto 1001
c
          do i=1,mcndis+mcnans
             ddqs2(i,mciesp)=1.0d+00
          end do
          do i=mcndis+mcnans+1,mcndis+mcnans+mcndas
             pn=dble(mcpnds(i-mcndis-mcnans))
             ddqs2(i,mciesp)=cos(pn*dqs(i,mciesp))
          end do
          do i=mcndis+mcnans+mcndas+1,mcnics
             ddqs2(i,mciesp)=1.0d+00
          end do
c
          do k=1,mcnics
            wrk1s = 0.d0
              do k1 = 1,mcnics
                wrk1s = wrk1s+cevbm(k1,k,mciesp)*dqs2(k1,mciesp)
              enddo
            wrk1(k) = wrk1s
          enddo
c
          do 501 i=1,mcnics
             wrk1r(i)=0.0d+00
             do 511 j=1,mcnatm
                wrk1r(i)=wrk1r(i)+dphi(j,mciesp)*ceerv(i,j,mciesp)
 511         continue
 501      continue
c
          do k=1,mcnics
                gi12pnt(k)=aevbm(mciesp)*(bevbm(k,mciesp)               0108OT09
     *                    +0.5d0*(wrk(k)+wrk1(k))+wrk1r(k))             0108OT09
     *                    *ddqs2(k,mciesp)
          enddo
c
c     weight the gradient
c
          do k=1,mcnics
            gi12b(k) = gi12b(k) + gi12pnt(k)*w(mciesp)                   0505OT07
          enddo
c
c     if shepard interpolation is used, calculate (dw_k/dr)*V12(r;k)^2
c
          if (mcimre.eq.2) then
            do kw=1,mcnics
             gi12a(kw)=gi12a(kw)+dwf(mciesp,kw)*e12p(mciesp)             0108OT09
            enddo
             do k=1,mcnics
              gi12(k)=gi12a(k)+gi12b(k)                                  0505OT07
            enddo
           else if (mcimre.eq.1) then                                    0505OT07
            do k=1,mcnics                                                0505OT07
             gi12(k)=gi12b(k)                                            0505OT07
            enddo
          endif
c
c----------------- end of first derivative calculations ------
c
c
c------------------ begin calculating the dqdri12 -----
c
         if (mccdqr.eq.1) then
c
            do 601 ik=1,mcnatm
            do 611 is=1,mcnics
               dqdri12(is,ik)=dqdri12(is,ik)
     &        +w(mciesp)*aevbm(mciesp)*ceerv(is,ik,mciesp)
     &        *ddqs2(is,mciesp)
 611        continue
 601        continue
c
            if (mcimre.eq.2) then
               do 651 ik=1,mcnicb
                  iwk=mciicb(ik)
               do 661 j=1,mcnatm
                  dqdri12(iwk,j)=dqdri12(iwk,j)
     &                          +dwf(mciesp,iwk)*chg12pnt(j)
 661           continue
 651           continue
            endif
c
         end if
c
c------------------ begin calculating the hessian -----
c
c     first check if it is necessary (itypec = 2)
c
          if (itypec .eq. 2) goto 1001
c
          do i=1,mcndis+mcnans
             d2dqs2(i,mciesp)=0.0d+00
          end do
          do i=mcndis+mcnans+1,mcndis+mcnans+mcndas
             pn=dble(mcpnds(i-mcndis-mcnans))
             d2dqs2(i,mciesp)=-pn*sin(pn*dqs(i,mciesp))
          end do
          do i=mcndis+mcnans+mcndas+1,mcnics
             d2dqs2(i,mciesp)=0.0d+00
          end do
c
c   1. calculate dd(e12(i))/(dqs(k)dqs(s))*w(i))                              0505OT07
c
          do ik=1,mcnics
c
             hi12(ik,ik)=hi12(ik,ik)+w(mciesp)*aevbm(mciesp)
     &                  *(bevbm(ik,mciesp)+0.5d0*(wrk(ik)+wrk1(ik))
     &                  +wrk1r(ik))*d2dqs2(ik,mciesp)
c
             do is=ik,mcnics
                hi12(is,ik)=hi12(is,ik)+w(mciesp)*aevbm(mciesp)      
     &         *0.5d0*(cevbm(is,ik,mciesp)+cevbm(ik,is,mciesp))
     &         *ddqs2(ik,mciesp)*ddqs2(is,mciesp)
                hi12(ik,is)=hi12(is,ik)                           
             enddo
          enddo
c
c     if shepard interpolation is on, calculate the second term:
c   2. e12(i)*ddW(i)/(dqs(k)dqs(s))
c
          if (mcimre.eq.2) then
                do iwk=1,mcnics
                do iws=iwk,mcnics
               hi12(iws,iwk)=hi12(iws,iwk)+                          
     *         d2wf(iws,iwk,mciesp)*e12p(mciesp)                               0108OT09   
                hi12(iwk,iws)=hi12(iws,iwk)                            
              enddo
c
c   3. calculate cross terms
c
              do j=1,mcnics
               hi12(iwk,j)=hi12(iwk,j)+dwf(mciesp,iwk)*gi12pnt(j)             
               hi12(j,iwk)=hi12(j,iwk)+dwf(mciesp,iwk)*gi12pnt(j)             
              enddo
            enddo
          endif
        endif
c
c     end of loop over number of shepard points
c
 1001 continue
c
CAMBP#ifdef MPI
CAMBPc
CAMBPc     sum up
CAMBPc
CAMBP      call mpi_allreduce(e12,e12tmp,1,
CAMBP     &     mpi_double_precision,mpi_sum,commsander,ierr)
CAMBP      e12=e12tmp
CAMBPc
CAMBP      call mpi_allreduce(gi12,gi12tmp,mcnics,
CAMBP     &     mpi_double_precision,mpi_sum,commsander,ierr)
CAMBP      do i=1,mcnics
CAMBP         gi12(i)=gi12tmp(i)
CAMBP      end do
CAMBPc
CAMBP      call mpi_allreduce(chg12,chg12tmp,mcnatm,
CAMBP     &     mpi_double_precision,mpi_sum,commsander,ierr)
CAMBP      do i=1,mcnatm
CAMBP         chg12(i)=chg12tmp(i)
CAMBP      end do
CAMBPc
CAMBP#endif
c
      return
c<<<<                                                                    0527MH10
      end
c
c***********************************************************************
c     eev12iold
c***********************************************************************
c
      subroutine eev12iold(phi,e12,gi12,hi12,chg12,dqdv12,dqdri12,
     &                     itypec)
c
c     This subroutine is a modified version of subroutine mcv12i
c     This subroutine calculates e12, gradients (gi12), and Hessian (hi12)
c     using the weighting function.
c     (Titus V Albu January 2002). Modified by OT (May 2007).
c
      implicit double precision (a-h, o-z)
c
CAMBP#ifdef MPI
CAMBPc     =========================== AMBER/MPI ===========================
CAMBP#     ifdef MPI_DOUBLE_PRECISION
CAMBP#       undef MPI_DOUBLE_PRECISION
CAMBP#     endif
CAMBP      include 'mpif.h'
CAMBP#     ifdef CRAY_PVP
CAMBP#       define MPI_DOUBLE_PRECISION MPI_REAL8
CAMBP#     endif
CAMBPc     ========================= END AMBER/MPI =========================
CAMBP#     include "parallel.h"
CAMBP#     include "extra.h"
CAMBPc
CAMBP      dimension gi12tmp(mcnics),chg12tmp(mcnatm)
CAMBP#endif
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'
c
      dimension dqs(mcmics,mcmesp+2),dqd(mcmicd,mcmesp+2)
      dimension w(mcmesp*6+12),dwf(mcmesp*6+12,mcmics)
      dimension d2wf(mcmicd,mcmicd,mcmesp*6+12)
c      dimension dw(mcmesp+2),ddw1(mcmesp+2),ddw2(mcmesp+2)
c      dimension sdw(mcmics),sddw1(mcmics,mcmics)
c
      dimension e12pnt(mcmesp+2),e12pf(mcmesp+2),e12p(mcmesp+2)
      dimension gi12pnt(mcmics),gi12(mcmics),hi12(mcmics,mcmics)
      dimension wrk(mcmics),wrk1(mcmics),gi12a(mcmics),gi12b(mcmics)
c
      dimension phi(mcmatm),dphi(mcmatm,mcmesp+2)
      dimension chg12(mcmatm),chg12pnt(mcmatm)
      dimension dqdv12(mcmatm,mcmatm),dqdri12(mcmics,mcmatm)
      dimension wrkv(mcmatm),wrkr(mcmatm)
      dimension wrk1v(mcmatm),wrk1r(mcmics)
      dimension uterm(mcmesp)
c
      dimension dqs2(mcmics,mcmesp+2),ddqs2(mcmics,mcmesp+2)             0527MH10
      dimension d2dqs2(mcmics,mcmesp+2)                                  0527MH10
c 
c     zero out Shepard variables
c
      do i=1,mcmics
        do j=1,mcmesp+2
          dqs(i,j) =  0.d0
        enddo
      enddo
      do i=1,mcmicd
        do j=1,mcmesp+2
          dqd(i,j) =  0.d0
        enddo
      enddo
      do i=1,mcnesp+2
        w(i)   =  0.d0
c        dw(i)  =  0.d0
c        ddw1(i)=  0.d0
c        ddw2(i)=  0.d0
        e12pnt(i) = 0.0d0
        e12pf(i) = 0.0d0
        e12p(i) = 0.0d0
          do j=1,mcnics
            dwf(i,j)  = 0.d0
          enddo
      enddo
      do i=1,mcmics
c        sdw(i)  = 0.d0
        gi12(i)  = 0.d0
        gi12a(i)  = 0.d0
        gi12b(i)  = 0.d0
        wrk1(i)  = 0.d0
c        do j=1,mcmics
c          sddw1(i,j) = 0.d0
c        enddo
      enddo
      wsum = 0.d0
c      sddw2= 0.d0
c
c     calculate the displacement in internal coordinates used for
c     Shepard interpolation
c
      do j=1,mcnesp+2
         do i=1,mcnics
            dqs(i,j)=qs(i)-qs0(i,j)
         enddo
         if (mcndas.gt.0) then
            do i = mcndis+mcnans+1,mcndis+mcnans+mcndas
               if (dqs(i,j).lt.-fpi) then
                   dqs(i,j) = dqs(i,j)+2.0d0*fpi
               elseif (dqs(i,j).gt.fpi) then
                   dqs(i,j) = dqs(i,j)-2.0d0*fpi
               endif
            enddo
         endif
      enddo
c
      do 100 j=1,mcnesp
         do 110 i=1,mcnatm
            dphi(i,j)=phi(i)-phis(i,j)
 110     continue
 100  continue
c
      do 120 i=1,mcnatm
         dphi(i,mcnesp+1)=phi(i)-phi0(i,1)
         dphi(i,mcnesp+2)=phi(i)-phi0(i,2)
 120  continue
c
c     calculate the displacement in internal coordinates used for
c     generalized distances. This part is moved to the mcswts subroutine (0505OT07)
c
c      do j=1,mcnesp+2
c         do i=1,mcnicd
c            dqd(i,j)=qd(i)-qd0(i,j)
c         enddo
c         if (mcndad.gt.0) then
c            do i = mcndid+mcnand+1,mcndid+mcnand+mcndad
c               if (dqd(i,j).lt.-fpi) then
c                   dqd(i,j) = dqd(i,j)+2.0d0*fpi
c               elseif (dqd(i,j).gt.fpi) then
c                   dqd(i,j) = dqd(i,j)-2.0d0*fpi
c               endif
c            enddo
c         endif
c      enddo
c
c     call the mcswts subroutine that determines the weights function and 
c     its derivatives with respect to the internal coordinates used for 
c     both Shepard interpolation and generalized distances.
c
       if (ijacob.eq.0) then                                             0108OT09
          call mcswtsnum(w,dwf,d2wf,itypec)                              0505OT07
       else                                                              0108OT09
          call mcswtsnum1(w,dwf,d2wf,itypec)                             0108OT09
       endif                                                             0108OT09
c      call mcswts(dqs,dqd,w,wsum,dw,ddw1,ddw2,
c     *            sdw,sddw1,sddw2,dwf,itypec)
c
c     output weights  modified by M. Higashi
c
      if(mcprwg.eq.1) then
         write(fu6,9999)
         do mciesp=1,mcnesp
            write(fu6,9998) mciesp,w(mciesp)
         end do
         write(fu6,9997) w(mcnesp+1)
         write(fu6,9996) w(mcnesp+2)
      end if
c
 9999 format(/,80(1H-)/,3x,'Shepard       Weight')
 9998 format(3x,i5,6x,f12.8)
 9997 format(3x,'Reactant   ',f12.8)
 9996 format(3x,'Product    ',f12.8)
c
c     for every interpolation point with weight larger than zero
c     calculate first and second derivatives
c
c     for molecular mechanics Shepard points (which are listed as the next
c     to the last and the last),e12=0.d0 since we assume that Molecular 
c     Mechanics force field can describe them correctly.
c
CAMBP#ifdef MPI
CAMBP      ipcount=mytaskid+1
CAMBP#endif
      if (mcsins.ne.0) goto 2000                                         0527MH10
c
      do 1000 mciesp=1,mcnesp
        if (w(mciesp).gt.0.d0) then
c
CAMBP#ifdef MPI
CAMBP           ipcount=ipcount+1
CAMBP           if(mod(ipcount,numtasks).ne.0) goto 1000
CAMBP#endif
c
c     Form of V12:  mcifre = 1  generalized gaussian (not used anymore)
c                   mcifre = 2  simple quadratic
c
c------------------- calculate e12 --------------------------------
c
          btrm=0.d0
          ctrm=0.d0
c
          do i=1,mcnics
            wrk(i) =0.d0
            btrm=btrm+bevbm(i,mciesp)*dqs(i,mciesp)
            do j=1,mcnics
              wrk(i)=wrk(i)+dqs(j,mciesp)*cevbm(i,j,mciesp)
            enddo
            ctrm=ctrm+dqs(i,mciesp)*wrk(i)
          enddo
c
          do 200 i=1,mcnatm
             wrkv(i)=0.0d+00
             wrkr(i)=0.0d+00
             btrm=btrm+bee(i,mciesp)*dphi(i,mciesp)
             do 210 j=1,mcnatm
                wrkv(i)=wrkv(i)+dphi(j,mciesp)*ceevv(i,j,mciesp)
 210         continue
             do 220 j=1,mcnics
                wrkr(i)=wrkr(i)+dqs(j,mciesp)*ceerv(j,i,mciesp)
 220         continue
             ctrm=ctrm+dphi(i,mciesp)*(wrkv(i)+2.0d+00*wrkr(i))
 200      continue

c
c     Added to avoid negative values for V12**2 term, 4/14/99 by Y. Kim
c
c          delta = 0.00000001d+00
          be12 = 1.d0+btrm+0.5d0*ctrm
          e12p(mciesp) = aevbm(mciesp)*be12
          if (e12p(mciesp).gt.0.0d0) then
c             fixf = dexp(-delta/e12p(mciesp))
             uterm(mciesp)=udelta/e12p(mciesp)                          1206OT08
             fixf = 1.d0/(1.d0+(uterm(mciesp))**unn)                    1206OT08
          else
            fixf = 0.0d0
          endif
          e12pf(mciesp) = e12p(mciesp)*fixf
c
          e12pnt(mciesp) = dsqrt(e12pf(mciesp))
c
          e12 = e12+w(mciesp)*e12pnt(mciesp)                            0505OT07
c
c------------------end of e12------------------------------------
c
c
c------------------ begin calculating the charges -----
c
          do 300 k=1,mcnatm
            if (e12p(mciesp).gt.0.0d+00) then
c               chg12pnt(k)=0.5d+00*aevbm(mciesp)/e12pnt(mciesp)
c     &                    *(bee(k,mciesp)+wrkv(k)+wrkr(k))*fixf
c     &                    *(1.0D+00+delta/(aevbm(mciesp)*be12))
                chg12pnt(k)=0.5d0*aevbm(mciesp)*(bee(k,mciesp)
     *          +wrkv(k)+wrkr(k))*fixf/e12pnt(mciesp)*        
     *          (1.d0+fixf*unn*(uterm(mciesp))**unn)          
            else
               chg12pnt(k)=0.0d+00
            endif
 300     continue
c
c     weight the gradient
c
         do 310 k=1,mcnatm
            chg12(k)=chg12(k)+chg12pnt(k)*w(mciesp)                     0505OT07
 310     continue
c
c------------------ begin calculating the dqdv12 -----
c
         if (mccdqv.eq.1) then
          if (e12p(mciesp).gt.0.0d+00) then
             do 400 ik=1,mcnatm
             do 410 is=ik,mcnatm
c                dqdv12(is,ik)=dqdv12(is,ik)
c     &           +w(mciesp)/e12pnt(mciesp)*(-chg12pnt(is)*chg12pnt(ik)
c     &           +0.5d+00*fixf*(aevbm(mciesp)*ceevv(is,ik,mciesp)
c     &           +delta*delta/(aevbm(mciesp)*(be12**3))
c     &           *(bee(is,mciesp)+wrkv(is)+wrkr(is))
c     &           *(bee(ik,mciesp)+wrkv(ik)+wrkr(ik))    
c     &           +ceevv(is,ik,mciesp)*delta/be12))
                dqdv12(is,ik)=dqdv12(is,ik)
     &           +(-chg12pnt(is)*chg12pnt(ik)
     &           +aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf*fixf
     &           *(bee(is,mciesp)+wrkv(is)+wrkr(is))
     &           *(bee(ik,mciesp)+wrkv(ik)+wrkr(ik))/e12p(mciesp)
     &           *uterm(mciesp)**unn
     &           *(unn*fixf*uterm(mciesp)**unn-unn+1.0d+00)
     &           +0.5d+00*aevbm(mciesp)*ceevv(is,ik,mciesp)*fixf
     &           *(unn*fixf*uterm(mciesp)**unn+1.d0))/e12pnt(mciesp)
     &           *w(mciesp)
                dqdv12(ik,is)=dqdv12(is,ik)
 410         continue
 400         continue
          endif
         endif
c
c------------------ begin calculating the first derivatives -----
c
c     first check if it is necessary (itypec >= 1)
c
          if (itypec .eq. 1) goto 1000
          do k=1,mcnics
            wrk1s = 0.d0
              do k1 = 1,mcnics
                wrk1s = wrk1s+cevbm(k1,k,mciesp)*dqs(k1,mciesp)
              enddo
            wrk1(k) = wrk1s
          enddo
c
          do 500 i=1,mcnics
             wrk1r(i)=0.0d+00
             do 510 j=1,mcnatm
                wrk1r(i)=wrk1r(i)+dphi(j,mciesp)*ceerv(i,j,mciesp)
 510         continue
 500      continue
c
          do k=1,mcnics
            if (e12p(mciesp).gt.0.0) then
c               gi12pnt(k)=0.5d+00*aevbm(mciesp)/e12pnt(mciesp)
c     &              *(bevbm(k,mciesp)+0.5d+00*(wrk(k)+wrk1(k))+wrk1r(k))
c     &              *fixf*(1.0D+00+delta/(aevbm(mciesp)*be12))
                gi12pnt(k)=0.5d0*aevbm(mciesp)/e12pnt(mciesp)            1206OT08
     *         *(bevbm(k,mciesp)+0.5d0*(wrk(k)+wrk1(k))+wrk1r(k))        1206OT08
     *         *fixf*(1.d0+fixf*unn*(uterm(mciesp))**unn)                1206OT08
            else
              gi12pnt(k)=0.0d0
            endif
          enddo
c
c     weight the gradient
c
          do k=1,mcnics
            gi12b(k) = gi12b(k) + gi12pnt(k)*w(mciesp)                   0505OT07
          enddo
c
c     if shepard interpolation is used, calculate (dw_k/dr)*V12(r;k)     0505OT07
c
          if (mcimre.eq.2) then
            do k=1,mcnicb
            kw=mciicb(k)
             gi12a(kw)=gi12a(kw)+dwf(mciesp,kw)*e12pnt(mciesp)           0505OT07
            enddo
             do k=1,mcnics
              gi12(k)=gi12a(k)+gi12b(k)                                  0505OT07
            enddo
           else if (mcimre.eq.1) then                                    0505OT07
            do k=1,mcnics                                                0505OT07
             gi12(k)=gi12b(k)                                            0505OT07
            enddo
          endif
c
c----------------- end of first derivative calculations ------
c
c------------------ begin calculating the dqdri12 -----
c
         if (mccdqr.eq.1) then
c
          if (e12p(mciesp).gt.0.0d+00) then
             do 600 ik=1,mcnatm
             do 610 is=1,mcnics
c
c                dqdri12(is,ik)=dqdri12(is,ik)
c     &         +w(mciesp)/e12pnt(mciesp)*(-gi12pnt(is)*chg12pnt(ik)
c     &         +0.5d+00*fixf*(aevbm(mciesp)*ceerv(is,ik,mciesp)
c     &         +delta*delta/(aevbm(mciesp)*(be12**3))
c     &         *(bevbm(is,mciesp)+0.5d+00*(wrk(is)+wrk1(is))+wrk1r(is))
c     &         *(bee(ik,mciesp)+wrkv(ik)+wrkr(ik))    
c     &         +ceerv(is,ik,mciesp)*delta/be12))
c
                dqdri12(is,ik)=dqdri12(is,ik)
     &         +(-gi12pnt(is)*chg12pnt(ik)
     &         +aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf*fixf
     &         *(bevbm(is,mciesp)+0.5d+00*(wrk(is)+wrk1(is))+wrk1r(is))
     &         *(bee(ik,mciesp)+wrkv(ik)+wrkr(ik))/e12p(mciesp)    
     &         *uterm(mciesp)**unn
     &         *(unn*fixf*uterm(mciesp)**unn-unn+1.d0)
     &         +0.5d0*aevbm(mciesp)*ceerv(is,ik,mciesp)*fixf
     &         *(unn*fixf*uterm(mciesp)**unn+1.d0))/e12pnt(mciesp)
     &         *w(mciesp)

c
 610         continue
 600         continue
c
             do 650 ik=1,mcnicb
                iwk=mciicb(ik)
                do 660 j=1,mcnatm
                   dqdri12(iwk,j)=dqdri12(iwk,j)
     &                           +dwf(mciesp,iwk)*chg12pnt(j)
 660            continue
 650         continue
          endif
         endif
c
c------------------ begin calculating the hessian -----
c
c     first check if it is necessary (itypec = 2)
c
          if (itypec .eq. 2) goto 1000
c
c   1. calculate dd(e12(i))/(dqs(k)dqs(s))*w(i))                              0505OT07
c
          if (e12p(mciesp).gt.0.0) then
            do ik=1,mcnics
              do is=ik,mcnics
c
c                hi12(is,ik)=hi12(is,ik)
c     &         +w(mciesp)/e12pnt(mciesp)*(-gi12pnt(is)*gi12pnt(ik)
c     &         +0.5d+00*fixf*(aevbm(mciesp)
c     &         *0.5d+00*(cevbm(is,ik,mciesp)+cevbm(ik,is,mciesp))
c     &         +delta*delta/(aevbm(mciesp)*(be12**3))
c     &         *(bevbm(is,mciesp)+0.5d+00*(wrk(is)+wrk1(is))+wrk1r(is))
c     &         *(bevbm(ik,mciesp)+0.5d+00*(wrk(ik)+wrk1(ik))+wrk1r(ik))    
c     &         +cevbm(is,ik,mciesp)*delta/be12))
c
                hi12(is,ik)=hi12(is,ik)
     *         +w(mciesp)/e12pnt(mciesp)*(-gi12pnt(is)*gi12pnt(ik)             0612OT08
     *         +aevbm(mciesp)*aevbm(mciesp)/e12p(mciesp)                       0612OT08
     *         *(bevbm(is,mciesp)+0.5d0*(wrk(is)+wrk1(is))+wrk1r(is))          0612OT08
     *         *(bevbm(ik,mciesp)+0.5d0*(wrk(ik)+wrk1(ik))+wrk1r(ik))          0612OT08
     *         *unn*unn*fixf*fixf*uterm(mciesp)**unn                           0612OT08
     *         *(unn*fixf*uterm(mciesp)**unn-unn+1.d0)                         0612OT08
     *         +0.25d0*(cevbm(is,ik,mciesp)+cevbm(ik,is,mciesp))               0612OT08
     *         *aevbm(mciesp)*fixf*(unn*fixf*uterm(mciesp)**unn+1.d0))         0612OT08
c
                hi12(ik,is)=hi12(is,ik)
c
              enddo
            enddo
          endif
c
c     if shepard interpolation is on, calculate the second term:
c   2. e12(i)*ddW(i)/(dqs(k)dqs(s))
c
c          if (mcimre.eq.2) then
cOT	    ddwf2 = ddw2(mciesp)/wsum-w(mciesp)*sddw2/(wsum*wsum)
            do ik=1,mcnicb
              iwk=mciicb(ik)
              detqk=dqs(iwk,mciesp)
              do is=ik,mcnicb
                iws=mciicb(is)
                detqs=dqs(iws,mciesp)
cOT                d2wf=(ddw1(mciesp)*detqk*detqs*wsum
cOT     *              -dw(mciesp)*detqk*sdw(is)
cOT     *              -w(mciesp)*sddw1(is,ik)
cOT     *              -dw(mciesp)*detqs*sdw(ik)
cOT     *              +2.d0*w(mciesp)*sdw(ik)*sdw(is)/wsum)/(wsum**2)
cOT                if(iws .eq. iwk)d2wf=d2wf+ddwf2
               hi12(iws,iwk)=hi12(iws,iwk)+                                   0505OT07
     *         d2wf(iws,iwk,mciesp)*e12pnt(mciesp)                            0505OT07
                hi12(iwk,iws)=hi12(iws,iwk)                                   0505OT07
              enddo
c
c   3. calculate cross terms
c
              do j=1,mcnics
cOT               hi12(iwk,j)=hi12(iwk,j)+dwf(mciesp,ik)*gi12pnt(j)
cOT               hi12(j,iwk)=hi12(j,iwk)+dwf(mciesp,ik)*gi12pnt(j)
               hi12(iwk,j)=hi12(iwk,j)+dwf(mciesp,iwk)*gi12pnt(j)             0505OT07
               hi12(j,iwk)=hi12(j,iwk)+dwf(mciesp,iwk)*gi12pnt(j)             0505OT07
              enddo
            enddo
          endif
c        endif
c
c     end of loop over number of shepard points
c
 1000 continue
c
CAMBP#ifdef MPI
CAMBPc
CAMBPc     sum up
CAMBPc
CAMBP      call mpi_allreduce(e12,e12tmp,1,
CAMBP     &     mpi_double_precision,mpi_sum,commsander,ierr)
CAMBP      e12=e12tmp
CAMBPc
CAMBP      call mpi_allreduce(gi12,gi12tmp,mcnics,
CAMBP     &     mpi_double_precision,mpi_sum,commsander,ierr)
CAMBP      do i=1,mcnics
CAMBP         gi12(i)=gi12tmp(i)
CAMBP      end do
CAMBPc
CAMBP      call mpi_allreduce(chg12,chg12tmp,mcnatm,
CAMBP     &     mpi_double_precision,mpi_sum,commsander,ierr)
CAMBP      do i=1,mcnatm
CAMBP         chg12(i)=chg12tmp(i)
CAMBP      end do
CAMBPc
CAMBP#endif
c
      return
c
c>>>>                                                                    0527MH10
 2000 continue
c
      do 1001 mciesp=1,mcnesp
        if (w(mciesp).gt.0.d0) then
CAMBP#ifdef MPI
CAMBP           ipcount=ipcount+1
CAMBP           if(mod(ipcount,numtasks).ne.0) goto 1001
CAMBP#endif
c
c     Form of V12:  mcifre = 1  generalized gaussian (not used anymore)
c                   mcifre = 2  simple quadratic
c
c------------------- calculate e12 --------------------------------
c
          btrm=0.d0
          ctrm=0.d0
c
          do i=1,mcndis+mcnans
             dqs2(i,mciesp)=dqs(i,mciesp)
          end do
          do i=mcndis+mcnans+1,mcndis+mcnans+mcndas
             pn=dble(mcpnds(i-mcndis-mcnans))
             dqs2(i,mciesp)=sin(pn*dqs(i,mciesp))/pn
          end do
          do i=mcndis+mcnans+mcndas+1,mcnics
             dqs2(i,mciesp)=dqs(i,mciesp)
          end do
c
          do i=1,mcnics
            wrk(i) =0.d0
            btrm=btrm+bevbm(i,mciesp)*dqs2(i,mciesp)
            do j=1,mcnics
              wrk(i)=wrk(i)+dqs2(j,mciesp)*cevbm(i,j,mciesp)
            enddo
            ctrm=ctrm+dqs2(i,mciesp)*wrk(i)
          enddo
c
          do 201 i=1,mcnatm
             wrkv(i)=0.0d+00
             wrkr(i)=0.0d+00
             btrm=btrm+bee(i,mciesp)*dphi(i,mciesp)
             do 211 j=1,mcnatm
                wrkv(i)=wrkv(i)+dphi(j,mciesp)*ceevv(i,j,mciesp)
 211         continue
             do 221 j=1,mcnics
                wrkr(i)=wrkr(i)+dqs2(j,mciesp)*ceerv(j,i,mciesp)
 221         continue
             ctrm=ctrm+dphi(i,mciesp)*(wrkv(i)+2.0d+00*wrkr(i))
 201      continue
c
c     Added to avoid negative values for V12**2 term, 4/14/99 by Y. Kim
c
c          delta = 0.00000001d+00
          be12 = 1.d0+btrm+0.5d0*ctrm
          e12p(mciesp) = aevbm(mciesp)*be12
          if (e12p(mciesp).gt.0.0d0) then
c             fixf = dexp(-delta/e12p(mciesp))
             uterm(mciesp)=udelta/e12p(mciesp)                          1206OT08
             fixf = 1.d0/(1.d0+(uterm(mciesp))**unn)                    1206OT08
          else
            fixf = 0.0d0
          endif
          e12pf(mciesp) = e12p(mciesp)*fixf
c
          e12pnt(mciesp) = dsqrt(e12pf(mciesp))
c
          e12 = e12+w(mciesp)*e12pnt(mciesp)                            0505OT07
c
c------------------end of e12------------------------------------
c
c
c------------------ begin calculating the charges -----
c
          do 301 k=1,mcnatm
             if (e12p(mciesp).gt.0.0d+00) then
                chg12pnt(k)=0.5d0*aevbm(mciesp)*(bee(k,mciesp)
     *         +wrkv(k)+wrkr(k))*fixf/e12pnt(mciesp)*        
     *         (1.d0+fixf*unn*(uterm(mciesp))**unn)          
             else
                chg12pnt(k)=0.0d+00
             endif
 301      continue
c
c     weight the gradient
c
          do 311 k=1,mcnatm
             chg12(k)=chg12(k)+chg12pnt(k)*w(mciesp)                     0505OT07
 311      continue
c
c------------------ begin calculating the dqdv12 -----
c
         if (mccdqv.eq.1) then
          if (e12p(mciesp).gt.0.0d+00) then
             do 401 ik=1,mcnatm
             do 411 is=ik,mcnatm
                dqdv12(is,ik)=dqdv12(is,ik)
     &           +(-chg12pnt(is)*chg12pnt(ik)
     &           +aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf*fixf
     &           *(bee(is,mciesp)+wrkv(is)+wrkr(is))
     &           *(bee(ik,mciesp)+wrkv(ik)+wrkr(ik))/e12p(mciesp)
     &           *uterm(mciesp)**unn
     &           *(unn*fixf*uterm(mciesp)**unn-unn+1.0d+00)
     &           +0.5d+00*aevbm(mciesp)*ceevv(is,ik,mciesp)*fixf
     &           *(unn*fixf*uterm(mciesp)**unn+1.d0))/e12pnt(mciesp)
     &           *w(mciesp)
                dqdv12(ik,is)=dqdv12(is,ik)
 411         continue
 401         continue
          endif
         endif
c
c------------------ begin calculating the first derivatives -----
c
c     first check if it is necessary (itypec >= 1)
c
          if (itypec .eq. 1) goto 1001
c
          do i=1,mcndis+mcnans
             ddqs2(i,mciesp)=1.0d+00
          end do
          do i=mcndis+mcnans+1,mcndis+mcnans+mcndas
             pn=dble(mcpnds(i-mcndis-mcnans))
             ddqs2(i,mciesp)=cos(pn*dqs(i,mciesp))
          end do
          do i=mcndis+mcnans+mcndas+1,mcnics
             ddqs2(i,mciesp)=1.0d+00
          end do
c
          do k=1,mcnics
            wrk1s = 0.d0
              do k1 = 1,mcnics
                wrk1s = wrk1s+cevbm(k1,k,mciesp)*dqs2(k1,mciesp)
              enddo
            wrk1(k) = wrk1s
          enddo
c
          do 501 i=1,mcnics
             wrk1r(i)=0.0d+00
             do 511 j=1,mcnatm
                wrk1r(i)=wrk1r(i)+dphi(j,mciesp)*ceerv(i,j,mciesp)
 511         continue
 501      continue
c
          do k=1,mcnics
            if (e12p(mciesp).gt.0.0) then
                gi12pnt(k)=0.5d0*aevbm(mciesp)/e12pnt(mciesp)            1206OT08
     *         *(bevbm(k,mciesp)+0.5d0*(wrk(k)+wrk1(k))+wrk1r(k))        1206OT08
     *         *ddqs2(k,mciesp)
     *         *fixf*(1.d0+fixf*unn*(uterm(mciesp))**unn)                1206OT08
            else
              gi12pnt(k)=0.0d0
            endif
          enddo
c
c     weight the gradient
c
          do k=1,mcnics
            gi12b(k) = gi12b(k) + gi12pnt(k)*w(mciesp)                   0505OT07
          enddo
c
c     if shepard interpolation is used, calculate (dw_k/dr)*V12(r;k)     0505OT07
c
          if (mcimre.eq.2) then
            do k=1,mcnicb
            kw=mciicb(k)
             gi12a(kw)=gi12a(kw)+dwf(mciesp,kw)*e12pnt(mciesp)           0505OT07
            enddo
             do k=1,mcnics
              gi12(k)=gi12a(k)+gi12b(k)                                  0505OT07
            enddo
           else if (mcimre.eq.1) then                                    0505OT07
            do k=1,mcnics                                                0505OT07
             gi12(k)=gi12b(k)                                            0505OT07
            enddo
          endif
c
c----------------- end of first derivative calculations ------
c
c------------------ begin calculating the dqdri12 -----
c
         if (mccdqr.eq.1) then
c
          if (e12p(mciesp).gt.0.0d+00) then
             do 601 ik=1,mcnatm
             do 611 is=1,mcnics
c
                dqdri12(is,ik)=dqdri12(is,ik)
     &         +(-gi12pnt(is)*chg12pnt(ik)
     &         +aevbm(mciesp)*aevbm(mciesp)*unn*unn*fixf*fixf
     &         *(bevbm(is,mciesp)+0.5d+00*(wrk(is)+wrk1(is))+wrk1r(is))
     &         *ddqs2(is,mciesp)
     &         *(bee(ik,mciesp)+wrkv(ik)+wrkr(ik))/e12p(mciesp)    
     &         *uterm(mciesp)**unn
     &         *(unn*fixf*uterm(mciesp)**unn-unn+1.d0)
     &         +0.5d0*aevbm(mciesp)*ceerv(is,ik,mciesp)*fixf
     &         *ddqs2(is,mciesp) 
     &         *(unn*fixf*uterm(mciesp)**unn+1.d0))/e12pnt(mciesp)
     &         *w(mciesp)

c
 611         continue
 601         continue
c
             do 651 ik=1,mcnicb
                iwk=mciicb(ik)
                do 661 j=1,mcnatm
                   dqdri12(iwk,j)=dqdri12(iwk,j)
     &                           +dwf(mciesp,iwk)*chg12pnt(j)
 661            continue
 651         continue
          endif
         endif
c
c------------------ begin calculating the hessian -----
c
c     first check if it is necessary (itypec = 2)
c
          if (itypec .eq. 2) goto 1001
c
          do i=1,mcndis+mcnans
             d2dqs2(i,mciesp)=0.0d+00
          end do
          do i=mcndis+mcnans+1,mcndis+mcnans+mcndas
             pn=dble(mcpnds(i-mcndis-mcnans))
             d2dqs2(i,mciesp)=-pn*sin(pn*dqs(i,mciesp))
          end do
          do i=mcndis+mcnans+mcndas+1,mcnics
             d2dqs2(i,mciesp)=0.0d+00
          end do
c
c   1. calculate dd(e12(i))/(dqs(k)dqs(s))*w(i))                              0505OT07
c
          if (e12p(mciesp).gt.0.0) then
            do ik=1,mcnics
c
              hi12(ik,ik)=hi12(ik,ik)+w(mciesp)
     &       *0.5d0*aevbm(mciesp)*(bevbm(ik,mciesp)
     &       +0.5d0*(wrk(ik)+wrk1(ik))+wrk1r(ik))
     *       *d2dqs2(ik,mciesp)*fixf/e12pnt(mciesp)
     *       *(1.d0+fixf*unn*(uterm(mciesp))**unn)
c
              do is=ik,mcnics
c
                hi12(is,ik)=hi12(is,ik)
     *         +w(mciesp)/e12pnt(mciesp)*(-gi12pnt(is)*gi12pnt(ik)             0612OT08
     *         +aevbm(mciesp)*aevbm(mciesp)/e12p(mciesp)                       0612OT08
     *         *(bevbm(is,mciesp)+0.5d0*(wrk(is)+wrk1(is))+wrk1r(is))          0612OT08
     *         *(bevbm(ik,mciesp)+0.5d0*(wrk(ik)+wrk1(ik))+wrk1r(ik))          0612OT08
     *         *ddqs2(is,mciesp)*ddqs2(ik,mciesp)      
     *         *unn*unn*fixf*fixf*uterm(mciesp)**unn                           0612OT08
     *         *(unn*fixf*uterm(mciesp)**unn-unn+1.d0)                         0612OT08
     *         +0.25d0*(cevbm(is,ik,mciesp)+cevbm(ik,is,mciesp))               0612OT08
     *         *ddqs2(is,mciesp)*ddqs2(ik,mciesp)      
     *         *aevbm(mciesp)*fixf*(unn*fixf*uterm(mciesp)**unn+1.d0))         0612OT08
c
                hi12(ik,is)=hi12(is,ik)
c
              enddo
            enddo
          endif
c
c     if shepard interpolation is on, calculate the second term:
c   2. e12(i)*ddW(i)/(dqs(k)dqs(s))
c
c          if (mcimre.eq.2) then
            do ik=1,mcnicb
              iwk=mciicb(ik)
              detqk=dqs(iwk,mciesp)
              do is=ik,mcnicb
                iws=mciicb(is)
                hi12(iws,iwk)=hi12(iws,iwk)+                                  0505OT07
     *          d2wf(iws,iwk,mciesp)*e12pnt(mciesp)                           0505OT07
                hi12(iwk,iws)=hi12(iws,iwk)                                   0505OT07
              enddo
c
c   3. calculate cross terms
c
              do j=1,mcnics
               hi12(iwk,j)=hi12(iwk,j)+dwf(mciesp,iwk)*gi12pnt(j)             0505OT07
               hi12(j,iwk)=hi12(j,iwk)+dwf(mciesp,iwk)*gi12pnt(j)             0505OT07
              enddo
            enddo
          endif
c        endif
c
c     end of loop over number of shepard points
c
 1001 continue
c
CAMBP#ifdef MPI
CAMBPc
CAMBPc     sum up
CAMBPc
CAMBP      call mpi_allreduce(e12,e12tmp,1,
CAMBP     &     mpi_double_precision,mpi_sum,commsander,ierr)
CAMBP      e12=e12tmp
CAMBPc
CAMBP      call mpi_allreduce(gi12,gi12tmp,mcnics,
CAMBP     &     mpi_double_precision,mpi_sum,commsander,ierr)
CAMBP      do i=1,mcnics
CAMBP         gi12(i)=gi12tmp(i)
CAMBP      end do
CAMBPc
CAMBP      call mpi_allreduce(chg12,chg12tmp,mcnatm,
CAMBP     &     mpi_double_precision,mpi_sum,commsander,ierr)
CAMBP      do i=1,mcnatm
CAMBP         chg12(i)=chg12tmp(i)
CAMBP      end do
CAMBPc
CAMBP#endif
c<<<<                                                                    0527MH10
      return
c
      end
c     
c***********************************************************************
c     eeviic
c***********************************************************************
c     
      subroutine eeviic(xii,phi,ex,gx,hx,chg,itypec,iconf)
c     
      implicit real*8 (a-h,o-z)
c     
c     This subroutine is the driver for the electrostatic potential
c     calculations in the diagonal terms.
c     
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c     
      include 'eemcmm.inc'
c
      parameter (mcmca2=mcmcar*(mcmcar+1)/2)
      parameter (mcmic2=mcmics*(mcmics+1)/2)
c
      dimension xii(mcmcar),qii(mcmics)
      dimension chg(mcmatm), phi(mcmatm)
      dimension gx(mcmcar),hx(mcmcar,mcmcar)
      dimension dphi(mcmatm),dqi(mcmics)
      dimension xc(mcmatm),yc(mcmatm),zc(mcmatm)
      dimension grvi(mcmics),grv(mcmcar)
      dimension grv0i(mcmics),grv0(mcmcar)
      dimension amatb(mcmics,mcmcar)
      dimension amatbtc(mcmics,mcmca2)
      dimension amat2(mcmca2)
      dimension amat2i(mcmic2)
      dimension amat3(mcmca2)
      dimension scr4(mcmcar,mcmcar)
      dimension scr5(mcmics,mcmcar)
      dimension hi(mcmics,mcmics)
c
c     Store the orientation of the coordinate system for L bend
c
      dimension t(3,3)
c
c
c     
      do 100 i=1,mcnatm
         xc(i)=xii(3*i-2)
         yc(i)=xii(3*i-1)
         zc(i)=xii(3*i)
 100  continue
c     
c     transform cartesian coordinates into internal coorinates.
c     
      call mctcic(mcndis,mcnans,mcnads,mcndas,
     *            mcidis,mcians,mciads,mcidas,
     *            mcmics,mcmatm,xc,yc,zc,qii)
c     
c     calculate polarized charges
c     
      do 200 iphi=1,mcnatm
         dphi(iphi)=phi(iphi)-phi0(iphi,iconf)
 200  continue
c     
      do 210 iq=1,mcnics
         dqi(iq)=qii(iq)-qii0(iq,iconf)
 210  continue
c     
c     
c     
      if(mcsins.eq.1) goto 1000                                         0531MH10
c
      do 300 ichg=1,mcnatm
c     
         chgtmp=chg0(ichg,iconf)
c     
         do 310 jphi=1,mcnatm
            chgtmp=chgtmp+dqdv0(jphi,ichg,iconf)*dphi(jphi)
 310     continue
c     
         do 320 jq=1,mcnics
            chgtmp=chgtmp+dqdri0(jq,ichg,iconf)*dqi(jq)
 320     continue
c     
         chg(ichg)=chgtmp
c     
 300  continue
c     
c     add electrostatic contribution to ex
c     
      eqmvt=0.0d+00
      eqmmt=0.0d+00
c     
      do 400 i=1,mcnatm
c     
         chi=chg(i)
         eqmmt=eqmmt+chi*phi(i)
         eqmvt=eqmvt-chi*phi0(i,iconf)
c     
         do 410 j=1,mcnatm
            eqmvt=eqmvt-0.5d+00*dphi(j)*dqdv0(j,i,iconf)*dphi(i)
 410     continue
c     
 400  continue
c     
      ex=ex+eqmvt+eqmmt
c     
c     eqmr0(iconf)=ex
c     eqmv0(iconf)=eqmvt
c     eqmm0(iconf)=eqmmt
c     write(fu6,*) "EQMR=",eqmr0(iconf)
c     write(fu6,*) "EQMV=",eqmv0(iconf)
c     write(fu6,*) "EQMM=",eqmm0(iconf)
c     write(fu6,*) "EX  =",ex
c     
c     
c     csum=0.0D+00
c     do i=1,mcnatm
c     write(fu6,*) i,chg(i),phi(i)
c     csum=csum+chg(i)
c     end do
c     write(fu6,*) 'csum=',csum
c     
c     
c     calculate gradient
c     
      if(itypec.eq.1) return
c     
      call mcybmat(mcndis,mcnans,mcndas,mcnads,mcidis,mcians,
     *             mcidas,mciads,xc,yc,zc,mcnatm,mcnics,
     *             amatb,t,mcmatm,mcmics,mcmcar)
c     
      do 500 i=1,mcnics
         grvtmp=0.0d+00
         do 510 j=1,mcnatm
            grvtmp=grvtmp+dqdri0(i,j,iconf)*dphi(j)
 510     continue
         grvi(i)=grvtmp
 500  continue
c
      mcncar=3*mcnatm
      call trangj(grv,amatb,grvi,mcncar,mcnics,mcmcar,mcmics)
c     
      do 550 i=1,mcncar
         gx(i)=gx(i)+grv(i)
 550  continue
c
c
      if (mccdqr.eq.1) then
c
         do 600 i=1,mcnatm
c
            do 610 j=1,mcnics
               grv0i(j)=dqdri0(j,i,iconf)
 610        continue
            call trangj(grv0,amatb,grv0i,mcncar,mcnics,mcmcar,mcmics)
            do 620 j=1,mcncar
               dqdrr0(j,i,iconf)=grv0(j)
 620        continue
c
 600     continue
c
      end if
c
c     calculate hessian
c
      if(itypec.eq.2) return
c
      call btenscj(mcndis,mcnans,mcndas,mcnads,mcidis,mcians,
     *             mcidas,mciads,xc,yc,zc,mcnatm,scr4,
     *             amatbtc,mcnics,mcncar,mcmics,mcmca2,
     *             mcmatm,mcmcar,t)
c
      call formf2cj(amat2,amatbtc,grvi,mcmics,mcmca2,mcnics,mcncar)
c
      indic=1
      do 700 i=1,mcncar
         do 710 j=1,i
            if(i.ne.j) then
               hx(i,j)=hx(i,j)+amat2(indic)
               hx(j,i)=hx(j,i)+amat2(indic)
            else
               hx(i,i)=hx(i,i)+amat2(indic)               
            endif
            indic=indic+1
 710     continue
 700  continue
c
      return
c>>>>                                                                   0531MH10
 1000 continue
c
c     use sin(pn*dq)/pn for dihedral angles
c
      do 301 ichg=1,mcnatm
c     
         chgtmp=chg0(ichg,iconf)
c     
         do 311 jphi=1,mcnatm
            chgtmp=chgtmp+dqdv0(jphi,ichg,iconf)*dphi(jphi)
 311     continue
c     
         do 321 jq=1,mcndis+mcnans
            chgtmp=chgtmp+dqdri0(jq,ichg,iconf)*dqi(jq)
 321     continue
c
         do 331 jq=mcndis+mcnans+1,mcndis+mcnans+mcndas
            pn=dble(mcpnds(jq-mcndis-mcnans))
            chgtmp=chgtmp
     &            +dqdri0(jq,ichg,iconf)*sin(pn*dqi(jq))/pn
 331     continue
c
         do 341 jq=mcndis+mcnans+mcndas+1,mcnics
            chgtmp=chgtmp+dqdri0(jq,ichg,iconf)*dqi(jq)
 341     continue
c     
         chg(ichg)=chgtmp
c     
 301  continue
c     
c     add electrostatic contribution to ex
c     
      eqmvt=0.0d+00
      eqmmt=0.0d+00
c     
      do 401 i=1,mcnatm
c     
         chi=chg(i)
         eqmmt=eqmmt+chi*phi(i)
         eqmvt=eqmvt-chi*phi0(i,iconf)
c     
         do 411 j=1,mcnatm
            eqmvt=eqmvt-0.5d+00*dphi(j)*dqdv0(j,i,iconf)*dphi(i)
 411     continue
c     
 401  continue
c     
      ex=ex+eqmvt+eqmmt
c     
c     eqmr0(iconf)=ex
c     eqmv0(iconf)=eqmvt
c     eqmm0(iconf)=eqmmt
c     write(fu6,*) "EQMR=",eqmr0(iconf)
c     write(fu6,*) "EQMV=",eqmv0(iconf)
c     write(fu6,*) "EQMM=",eqmm0(iconf)
c     write(fu6,*) "EX  =",ex
c     
c     
c     csum=0.0D+00
c     do i=1,mcnatm
c     write(fu6,*) i,chg(i),phi(i)
c     csum=csum+chg(i)
c     end do
c     write(fu6,*) 'csum=',csum
c     
c     calculate gradient
c     
      if(itypec.eq.1) return
c     
      call mcybmat(mcndis,mcnans,mcndas,mcnads,mcidis,mcians,
     *             mcidas,mciads,xc,yc,zc,mcnatm,mcnics,
     *             amatb,t,mcmatm,mcmics,mcmcar)
c     
      do 501 i=1,mcndis+mcnans
         grvtmp=0.0d+00
         do 511 j=1,mcnatm
            grvtmp=grvtmp+dqdri0(i,j,iconf)*dphi(j)
 511     continue
         grvi(i)=grvtmp
 501  continue
c
      do 502 i=mcndis+mcnans+1,mcndis+mcnans+mcndas
         pn=dble(mcpnds(i-mcndis-mcnans))
         grvtmp=0.0d+00
         do 512 j=1,mcnatm
            grvtmp=grvtmp
     &            +cos(pn*dqi(i))*dqdri0(i,j,iconf)*dphi(j)
 512     continue
         grvi(i)=grvtmp
 502  continue
c
      do 503 i=mcndis+mcnans+mcndas+1,mcnics
         grvtmp=0.0d+00
         do 513 j=1,mcnatm
            grvtmp=grvtmp+dqdri0(i,j,iconf)*dphi(j)
 513     continue
         grvi(i)=grvtmp
 503  continue
c
      mcncar=3*mcnatm
      call trangj(grv,amatb,grvi,mcncar,mcnics,mcmcar,mcmics)
c     
      do 551 i=1,mcncar
         gx(i)=gx(i)+grv(i)
 551  continue
c
c
      if (mccdqr.eq.1) then
c
         do 601 i=1,mcnatm
c
            do 611 j=1,mcnics
               grv0i(j)=dqdri0(j,i,iconf)
 611        continue
            call trangj(grv0,amatb,grv0i,mcncar,mcnics,mcmcar,mcmics)
            do 621 j=1,mcncar
               dqdrr0(j,i,iconf)=grv0(j)
 621        continue
c
 601     continue
c
      end if
c
c     calculate hessian
c
      if(itypec.eq.2) return
c
      call btenscj(mcndis,mcnans,mcndas,mcnads,mcidis,mcians,
     *             mcidas,mciads,xc,yc,zc,mcnatm,scr4,
     *             amatbtc,mcnics,mcncar,mcmics,mcmca2,
     *             mcmatm,mcmcar,t)
c
      do 701 i=1,mcnics
         do 711 j=1,mcnics
            hi(j,i)=0.0d+00
 711     continue
 701  continue
c
      do 702 i=mcndis+mcnans+1,mcndis+mcnans+mcndas
         pn=dble(mcpnds(i-mcndis-mcnans))
         htmp=0.0d+00
         do 712 j=1,mcnatm
            htmp=htmp+dqdri0(i,j,iconf)*dphi(j)
 712     continue
         hi(i,i)=-pn*sin(pn*dqi(i))*htmp
 702  continue
c
      call formf2cj(amat2,amatbtc,grvi,mcmics,mcmca2,mcnics,mcncar)
      call tranlfj(amat2i,hi,mcnics,mcmic2,mcmics)
      call tranfcj(amat3,amatb,scr5,amat2i,amat2,
     *             mcnatm,mcmics,mcmcar,mcmic2,mcmca2,mcnics)
c
      indic=1
      do 703 i=1,mcncar
         do 713 j=1,i
            hx(i,j)=hx(i,j)+amat3(indic)
            hx(j,i)=hx(i,j)
            indic=indic+1
 713     continue
 703  continue
c
c<<<<                                                                   0531MH10
      return
      end
c
c ***************************************************************************
c     eechargetest
c ***************************************************************************
c
      subroutine eechargetest
c
c     This subroutine calculates analytical and numerical EE-MCSI charges
c     for comparison
c
      implicit double precision (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'                                              0225MH10
c
      dimension xt(mcmcar), dx(mcmcar)
c
      dimension phi(mcmatm)                                             0225MH10
      dimension chgnum(mcmatm)
c
      character*256 finame
      character*7  fistat
      character*20 fstat
      character*80 word(40)
c
      logical lexit
c
c     Initialize some variables
c
      mcncar = 3*mcnatm
c
      do i=1,mcmcar
         xt(i)=0.d0
      enddo
c
      do i=1,mcnatm                                                     0225MH10
         phi(i)=0.0d+00                                                 0225MH10
      end do                                                            0225MH10
c
c     Open the input file (esp.fu84) that have the geometries of points
c     for which MCMM calculation is desired.
c
      lexit  = .false.
      fistat = 'old'
      finame = 'esp.fu84'
c
      call mcfope (fu84, fistat, finame, lexit)
      if (lexit) then
         write (fu6,*) 'Error opening the fu84 input file'
         stop 'eechargetest 1'
      endif
c
c    Read the number of points in the esp.fu84 input file
c
      call mcrlnw(fu84,word,nword)
      if (word(1).eq.'POINTS') then
         if (nword.ge.2) then
            mcnpts = cfmct(word(2))
         else
            write (fu6,1000)
            stop 'eechargetest 1'
         endif
      else
         write (fu6,2000)
         stop 'eechargetest 2'
      endif
c
c    Read the format of the esp.fu84 input file
c
      call mcrlnw(fu84,word,nword)
      if (word(1).eq.'FORMAT') then
         if (nword.ge.2) then
            mcifrm = cfmct(word(2))
         else
            write (fu6,3000)
            stop 'eechargetest 3'
         endif
      else
         write (fu6,4000)
         stop 'eechargetest 4'
      endif
c
c     Check if the number of points is larger than the maximum number allowed
c
      if (mcnpts.gt.mcmpts) then
         write (fu6,5000)
         stop 'eechargetest 5'
      endif
c
c     Check if the format of the input is allowed
c
      if (mcifrm.lt.1.or.mcifrm.gt.4) then
         write (fu6,6000)
         stop 'eechargetest 6'
      endif
c
c     Start of the loop over mcnpts points
c
      do mcipts=1,mcnpts
c
c     Read the geometry:
c        mcifrm = 1: one line with the number of atoms
c                    one comment line
c                    mcnatm lines with one atom index and three coordinates
c        mcifrm = 2: one comment line
c                    mcnatm lines with one atom index and three coordinates
c        mcifrm = 3: one comment line
c                    mcnatm lines with three coordinates
c
         if (mcifrm.eq.1) then
            call mcrlnw(fu84,word,nword)
            if (nword.ge.1) noatms = cfmct(word(1))
            if (noatms.ne.mcnatm) then
               write (fu6,7000)
               stop 'eechargetest 7'
            endif
            call mcrlnw(fu84,word,nword)
            do i=1,mcnatm
               call mcrlnw(fu84,word,nword)
               if (nword.lt.4) then
                  write (fu6,8000)
                  stop 'eechargetest 8'
               else
                  xt(3*i-2) = cfmct(word(2))
                  xt(3*i-1) = cfmct(word(3))
                  xt(3*i) = cfmct(word(4))
c
                  if(nword.ge.5) phi(i) = cfmct(word(5))                0225MH10
c
               endif
            enddo
         elseif (mcifrm.eq.2) then
            call mcrlnw(fu84,word,nword)
            do i=1,mcnatm
               call mcrlnw(fu84,word,nword)
               if (nword.lt.4) then
                  write (fu6,8000)
                  stop 'eechargetest 9'
               else
                  xt(3*i-2) = cfmct(word(2))
                  xt(3*i-1) = cfmct(word(3))
                  xt(3*i) = cfmct(word(4))
c
                  if(nword.ge.5) phi(i) = cfmct(word(5))                0225MH10
c
               endif
            enddo
         elseif (mcifrm.eq.3) then
            call mcrlnw(fu84,word,nword)
            do i=1,mcnatm
               call mcrlnw(fu84,word,nword)
               if (nword.lt.3) then
                  write (fu6,8000)
                  stop 'eechargetest 10'
               else
                  xt(3*i-2) = cfmct(word(1))
                  xt(3*i-1) = cfmct(word(2))
                  xt(3*i) = cfmct(word(3))
c
                  if(nword.ge.4) phi(i) = cfmct(word(4))                0225MH10
c
               endif
            enddo
         elseif (mcifrm.eq.4) then
            call mcrlnw(fu84,word,nword)
            if (nword.ge.1) noatms = cfmct(word(1))
            if (noatms.ne.mcnatm) then
               write (fu6,7000)
               stop 'eechargetest 7'
            endif
            call mcrlnw(fu84,word,nword)
            do i=1,mcnatm
               call mcrlnw(fu84,word,nword)
               if (nword.lt.4) then
                  write (fu6,8000)
                  stop 'eechargetest 8'
               else
                  xt(3*i-2) = cfmct(word(3))
                  xt(3*i-1) = cfmct(word(4))
                  xt(3*i) = cfmct(word(5))
c
                  if(nword.ge.6) phi(i) = cfmct(word(6))                0225MH10
c
               endif
            enddo
         endif
c
c     Transform the geometry to bohr
c
         do i=1,mcncar
            if (mciufi.eq.2) then
               xt(i)=xt(i)/cmmc(i)
            elseif (mciufi.eq.3) then
               xt(i)=xt(i)/fboan
            elseif (mciufi.eq.4) then
               xt(i)=xt(i)/(fboan*cmmc(i))
            endif
         enddo
c                                                                       0225MH10
c     Transform the potential to a.u.                                   0225MH10
c                                                                       0225MH10
         if(mciee.eq.1 .and. mciuph.eq.1) then                          0225MH10
            do i=1,mcnatm                                               0225MH10
               phi(i)=phi(i)/fhaev                                      0225MH10
            enddo                                                       0225MH10
         endif                                                          0225MH10
c
c Get numerical gradient
c (the reason why we call mghook rather than mehook for numerical gradient is
c because these codes use
c different TINKER programs to get the MM energy, and sometimes these energies are 
c different (e.g. for liner water molecule, the HOH bending energy is
c zero when calculated with gradient.f, and is nonzero
c when calculated with energy.f). Before these issues are sorted out, we
c cannot use mehook.)
c
c
c     EE-MCSI calculation to get numerical charges
c
         do i=1,mcnatm
c
            tmp=phi(i)
            phi(i)=tmp+dh
            call eeghok(xt,phi,v1,e1,e2,e12,dx)
c
            phi(i)=tmp-dh
            call eeghok(xt,phi,v2,e1,e2,e12,dx)
c
            chgnum(i)=(v1-v2)/(2.d0*dh)
            phi(i)=tmp
c
         enddo
c
c     Get analytical charges
c
         call eeghok(xt,phi,v,e1,e2,e12,dx)
c
c     Print the geometry of the point and the MCMM results 
c
         call mcprez(mcipts,xt,v,e1,e2,e12,dx,f)
c
         if(mciee.eq.1) call eeprez(phi,v)                              0225MH10
c
         write(6,1001)
         do i=1,mcnatm
            write(6,2002) i,chgnum(i),chgr(i),chgnum(i)-chgr(i)
         enddo
 1001    format(/15X,'Numerical',10X,'Analytical',13X,'Diff')
 2002    format(1x,i4,3f20.10)
      enddo
c
c     Close the input file
c
      fstat = 'keep'
c
      call mcfclo (fu84, fstat)
c
 1000 format(1x,'Error: POINTS keyword should have an argument.')
 2000 format(1x,'Error: POINTS keyword should be on the first ',
     *          'line of the esp.fu84 input file.')
 3000 format(1x,'Error: FORMAT keyword should have an argument.')
 4000 format(1x,'Error: FORMAT keyword should be on the second ',
     *          'line of the esp.fu84 input file.')
 5000 format(1x,'Error: Too many geometries in fu84 input file.',
     *      /1x,'Increase mcmpts in mcparm.inc and recompile.')
 6000 format(1x,'Error: The format of the esp.fu84 input file ',
     *          'is not allowed.')
 7000 format(1x,'Error in the number of atoms in esp.fu84.')
 8000 format(1x,'Error in reading geometries in esp.fu84.')
c
c
      return
      end
c
c ***************************************************************************
c     eedqdphitest
c ***************************************************************************
c
      subroutine eedqdphitest
c
c     This subroutine calculates analytical and numerical EE-MCSI dQ/d(phi)
c     for comparison
c
      implicit double precision (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'                                              0225MH10
c
      dimension xt(mcmcar), dx(mcmcar)
c
      dimension phi(mcmatm)                                             0225MH10
      dimension dqdvnum(mcmatm,mcmatm)
      dimension chgpls(mcmatm),chgmns(mcmatm)
c
      character*256 finame
      character*7  fistat
      character*20 fstat
      character*80 word(40)
c
      logical lexit
c
c     Initialize some variables
c
      mcncar = 3*mcnatm
c
      do i=1,mcmcar
         xt(i)=0.d0
      enddo
c
      do i=1,mcnatm                                                     0225MH10
         phi(i)=0.0d+00                                                 0225MH10
      end do                                                            0225MH10
c
c     Open the input file (esp.fu84) that have the geometries of points
c     for which MCMM calculation is desired.
c
      lexit  = .false.
      fistat = 'old'
      finame = 'esp.fu84'
c
      call mcfope (fu84, fistat, finame, lexit)
      if (lexit) then
         write (fu6,*) 'Error opening the fu84 input file'
         stop 'eedqdphitest 1'
      endif
c
c    Read the number of points in the esp.fu84 input file
c
      call mcrlnw(fu84,word,nword)
      if (word(1).eq.'POINTS') then
         if (nword.ge.2) then
            mcnpts = cfmct(word(2))
         else
            write (fu6,1000)
            stop 'eedqdphitest 1'
         endif
      else
         write (fu6,2000)
         stop 'eedqdphitest 2'
      endif
c
c    Read the format of the esp.fu84 input file
c
      call mcrlnw(fu84,word,nword)
      if (word(1).eq.'FORMAT') then
         if (nword.ge.2) then
            mcifrm = cfmct(word(2))
         else
            write (fu6,3000)
            stop 'eedqdphitest 3'
         endif
      else
         write (fu6,4000)
         stop 'eedqdphitest 4'
      endif
c
c     Check if the number of points is larger than the maximum number allowed
c
      if (mcnpts.gt.mcmpts) then
         write (fu6,5000)
         stop 'eedqdphitest 5'
      endif
c
c     Check if the format of the input is allowed
c
      if (mcifrm.lt.1.or.mcifrm.gt.4) then
         write (fu6,6000)
         stop 'eedqdphitest 6'
      endif
c
c     Start of the loop over mcnpts points
c
      do mcipts=1,mcnpts
c
c     Read the geometry:
c        mcifrm = 1: one line with the number of atoms
c                    one comment line
c                    mcnatm lines with one atom index and three coordinates
c        mcifrm = 2: one comment line
c                    mcnatm lines with one atom index and three coordinates
c        mcifrm = 3: one comment line
c                    mcnatm lines with three coordinates
c
         if (mcifrm.eq.1) then
            call mcrlnw(fu84,word,nword)
            if (nword.ge.1) noatms = cfmct(word(1))
            if (noatms.ne.mcnatm) then
               write (fu6,7000)
               stop 'eedqdphitest 7'
            endif
            call mcrlnw(fu84,word,nword)
            do i=1,mcnatm
               call mcrlnw(fu84,word,nword)
               if (nword.lt.4) then
                  write (fu6,8000)
                  stop 'eedqdphitest 8'
               else
                  xt(3*i-2) = cfmct(word(2))
                  xt(3*i-1) = cfmct(word(3))
                  xt(3*i) = cfmct(word(4))
c
                  if(nword.ge.5) phi(i) = cfmct(word(5))                0225MH10
c
               endif
            enddo
         elseif (mcifrm.eq.2) then
            call mcrlnw(fu84,word,nword)
            do i=1,mcnatm
               call mcrlnw(fu84,word,nword)
               if (nword.lt.4) then
                  write (fu6,8000)
                  stop 'eedqdphitest 9'
               else
                  xt(3*i-2) = cfmct(word(2))
                  xt(3*i-1) = cfmct(word(3))
                  xt(3*i) = cfmct(word(4))
c
                  if(nword.ge.5) phi(i) = cfmct(word(5))                0225MH10
c
               endif
            enddo
         elseif (mcifrm.eq.3) then
            call mcrlnw(fu84,word,nword)
            do i=1,mcnatm
               call mcrlnw(fu84,word,nword)
               if (nword.lt.3) then
                  write (fu6,8000)
                  stop 'eedqdphitest 10'
               else
                  xt(3*i-2) = cfmct(word(1))
                  xt(3*i-1) = cfmct(word(2))
                  xt(3*i) = cfmct(word(3))
c
                  if(nword.ge.4) phi(i) = cfmct(word(4))                0225MH10
c
               endif
            enddo
         elseif (mcifrm.eq.4) then
            call mcrlnw(fu84,word,nword)
            if (nword.ge.1) noatms = cfmct(word(1))
            if (noatms.ne.mcnatm) then
               write (fu6,7000)
               stop 'eedqdphitest 7'
            endif
            call mcrlnw(fu84,word,nword)
            do i=1,mcnatm
               call mcrlnw(fu84,word,nword)
               if (nword.lt.4) then
                  write (fu6,8000)
                  stop 'eedqdphitest 8'
               else
                  xt(3*i-2) = cfmct(word(3))
                  xt(3*i-1) = cfmct(word(4))
                  xt(3*i) = cfmct(word(5))
c
                  if(nword.ge.6) phi(i) = cfmct(word(6))                0225MH10
c
               endif
            enddo
         endif
c
c     Transform the geometry to bohr
c
         do i=1,mcncar
            if (mciufi.eq.2) then
               xt(i)=xt(i)/cmmc(i)
            elseif (mciufi.eq.3) then
               xt(i)=xt(i)/fboan
            elseif (mciufi.eq.4) then
               xt(i)=xt(i)/(fboan*cmmc(i))
            endif
         enddo
c                                                                       0225MH10
c     Transform the potential to a.u.                                   0225MH10
c                                                                       0225MH10
         if(mciee.eq.1 .and. mciuph.eq.1) then                          0225MH10
            do i=1,mcnatm                                               0225MH10
               phi(i)=phi(i)/fhaev                                      0225MH10
            enddo                                                       0225MH10
         endif                                                          0225MH10
c
c Get numerical gradient
c (the reason why we call mghook rather than mehook for numerical gradient is
c because these codes use
c different TINKER programs to get the MM energy, and sometimes these energies are 
c different (e.g. for liner water molecule, the HOH bending energy is
c zero when calculated with gradient.f, and is nonzero
c when calculated with energy.f). Before these issues are sorted out, we
c cannot use mehook.)
c
c
c     EE-MCSI calculation to get numerical dqdphi
c
         do i=1,mcnatm
c
            tmp=phi(i)
c
            phi(i)=tmp+dh
            call eeghok(xt,phi,v1,e1,e2,e12,dx)
            do j=1,mcnatm
               chgpls(j)=chgr(j)
            enddo
c
            phi(i)=tmp-dh
            call eeghok(xt,phi,v2,e1,e2,e12,dx)
            do j=1,mcnatm
               chgmns(j)=chgr(j)
            enddo
c
            phi(i)=tmp
            do j=1,mcnatm
               dqdvnum(i,j)=(chgpls(j)-chgmns(j))/(2.d0*dh)
            enddo
c
         enddo
c
c     symmetrize dqdphi
c       
         do i=1,mcnatm
            do j=1,i-1
               tmp=0.5d+00*(dqdvnum(i,j)+dqdvnum(j,i))
               dqdvnum(i,j)=tmp
               dqdvnum(j,i)=tmp
            enddo
         enddo
c
c     get analytical dqdphi
c
         call eeghok(xt,phi,v,e1,e2,e12,dx)
c
c     Print the geometry of the point and the MCMM results 
c
         call mcprez(mcipts,xt,v,e1,e2,e12,dx,f)
c
         if(mciee.eq.1) call eeprez(phi,v)                              0225MH10
c
         write(6,1001)
         do i=1,mcnatm
            do j=1,i
               write(6,2002) i,j,dqdvnum(i,j),dqdvr(i,j),
     &              dqdvnum(i,j)-dqdvr(i,j)
            enddo
         enddo
 1001    format(/19X,'Numerical',10X,'Analytical',13X,'Diff')
 2002    format(1x,2i4,3f20.10)
      enddo
c
c     Close the input file
c
      fstat = 'keep'
c
      call mcfclo (fu84, fstat)
c
 1000 format(1x,'Error: POINTS keyword should have an argument.')
 2000 format(1x,'Error: POINTS keyword should be on the first ',
     *          'line of the esp.fu84 input file.')
 3000 format(1x,'Error: FORMAT keyword should have an argument.')
 4000 format(1x,'Error: FORMAT keyword should be on the second ',
     *          'line of the esp.fu84 input file.')
 5000 format(1x,'Error: Too many geometries in fu84 input file.',
     *      /1x,'Increase mcmpts in mcparm.inc and recompile.')
 6000 format(1x,'Error: The format of the esp.fu84 input file ',
     *          'is not allowed.')
 7000 format(1x,'Error in the number of atoms in esp.fu84.')
 8000 format(1x,'Error in reading geometries in esp.fu84.')
c
c
      return
      end
c
c ***************************************************************************
c     eedqdrtest
c ***************************************************************************
c
      subroutine eedqdrtest
c
c     This subroutine calculates analytical and numerical EE-MCSI dQ/d(phi)
c     for comparison
c
      implicit double precision (a-h,o-z)
c
      include 'mcparm.inc'
      include 'mcperc.inc'
      include 'mccomm.inc'
c
      include 'eemcmm.inc'                                              0225MH10
c
      dimension xt(mcmcar), dx(mcmcar)
c
      dimension phi(mcmatm)                                             0225MH10
      dimension dqdrnum(mcmcar,mcmatm)
      dimension chgpls(mcmatm),chgmns(mcmatm)
c
      character*256 finame
      character*7  fistat
      character*20 fstat
      character*80 word(40)
c
      logical lexit
c
c     Initialize some variables
c
      mcncar = 3*mcnatm
c
      do i=1,mcmcar
         xt(i)=0.d0
      enddo
c
      do i=1,mcnatm                                                     0225MH10
         phi(i)=0.0d+00                                                 0225MH10
      end do                                                            0225MH10
c
c     Open the input file (esp.fu84) that have the geometries of points
c     for which MCMM calculation is desired.
c
      lexit  = .false.
      fistat = 'old'
      finame = 'esp.fu84'
c
      call mcfope (fu84, fistat, finame, lexit)
      if (lexit) then
         write (fu6,*) 'Error opening the fu84 input file'
         stop 'eedqdrtest 1'
      endif
c
c    Read the number of points in the esp.fu84 input file
c
      call mcrlnw(fu84,word,nword)
      if (word(1).eq.'POINTS') then
         if (nword.ge.2) then
            mcnpts = cfmct(word(2))
         else
            write (fu6,1000)
            stop 'eedqdrtest 1'
         endif
      else
         write (fu6,2000)
         stop 'eedqdrtest 2'
      endif
c
c    Read the format of the esp.fu84 input file
c
      call mcrlnw(fu84,word,nword)
      if (word(1).eq.'FORMAT') then
         if (nword.ge.2) then
            mcifrm = cfmct(word(2))
         else
            write (fu6,3000)
            stop 'eedqdrtest 3'
         endif
      else
         write (fu6,4000)
         stop 'eedqdrtest 4'
      endif
c
c     Check if the number of points is larger than the maximum number allowed
c
      if (mcnpts.gt.mcmpts) then
         write (fu6,5000)
         stop 'eedqdrtest 5'
      endif
c
c     Check if the format of the input is allowed
c
      if (mcifrm.lt.1.or.mcifrm.gt.4) then
         write (fu6,6000)
         stop 'eedqdrtest 6'
      endif
c
c     Start of the loop over mcnpts points
c
      do mcipts=1,mcnpts
c
c     Read the geometry:
c        mcifrm = 1: one line with the number of atoms
c                    one comment line
c                    mcnatm lines with one atom index and three coordinates
c        mcifrm = 2: one comment line
c                    mcnatm lines with one atom index and three coordinates
c        mcifrm = 3: one comment line
c                    mcnatm lines with three coordinates
c
         if (mcifrm.eq.1) then
            call mcrlnw(fu84,word,nword)
            if (nword.ge.1) noatms = cfmct(word(1))
            if (noatms.ne.mcnatm) then
               write (fu6,7000)
               stop 'eedqdrtest 7'
            endif
            call mcrlnw(fu84,word,nword)
            do i=1,mcnatm
               call mcrlnw(fu84,word,nword)
               if (nword.lt.4) then
                  write (fu6,8000)
                  stop 'eedqdrtest 8'
               else
                  xt(3*i-2) = cfmct(word(2))
                  xt(3*i-1) = cfmct(word(3))
                  xt(3*i) = cfmct(word(4))
c
                  if(nword.ge.5) phi(i) = cfmct(word(5))                0225MH10
c
               endif
            enddo
         elseif (mcifrm.eq.2) then
            call mcrlnw(fu84,word,nword)
            do i=1,mcnatm
               call mcrlnw(fu84,word,nword)
               if (nword.lt.4) then
                  write (fu6,8000)
                  stop 'eedqdrtest 9'
               else
                  xt(3*i-2) = cfmct(word(2))
                  xt(3*i-1) = cfmct(word(3))
                  xt(3*i) = cfmct(word(4))
c
                  if(nword.ge.5) phi(i) = cfmct(word(5))                0225MH10
c
               endif
            enddo
         elseif (mcifrm.eq.3) then
            call mcrlnw(fu84,word,nword)
            do i=1,mcnatm
               call mcrlnw(fu84,word,nword)
               if (nword.lt.3) then
                  write (fu6,8000)
                  stop 'eedqdrtest 10'
               else
                  xt(3*i-2) = cfmct(word(1))
                  xt(3*i-1) = cfmct(word(2))
                  xt(3*i) = cfmct(word(3))
c
                  if(nword.ge.4) phi(i) = cfmct(word(4))                0225MH10
c
               endif
            enddo
         elseif (mcifrm.eq.4) then
            call mcrlnw(fu84,word,nword)
            if (nword.ge.1) noatms = cfmct(word(1))
            if (noatms.ne.mcnatm) then
               write (fu6,7000)
               stop 'eedqdrtest 7'
            endif
            call mcrlnw(fu84,word,nword)
            do i=1,mcnatm
               call mcrlnw(fu84,word,nword)
               if (nword.lt.4) then
                  write (fu6,8000)
                  stop 'eedqdrtest 8'
               else
                  xt(3*i-2) = cfmct(word(3))
                  xt(3*i-1) = cfmct(word(4))
                  xt(3*i) = cfmct(word(5))
c
                  if(nword.ge.6) phi(i) = cfmct(word(6))                0225MH10
c
               endif
            enddo
         endif
c
c     Transform the geometry to bohr
c
         do i=1,mcncar
            if (mciufi.eq.2) then
               xt(i)=xt(i)/cmmc(i)
            elseif (mciufi.eq.3) then
               xt(i)=xt(i)/fboan
            elseif (mciufi.eq.4) then
               xt(i)=xt(i)/(fboan*cmmc(i))
            endif
         enddo
c                                                                       0225MH10
c     Transform the potential to a.u.                                   0225MH10
c                                                                       0225MH10
         if(mciee.eq.1 .and. mciuph.eq.1) then                          0225MH10
            do i=1,mcnatm                                               0225MH10
               phi(i)=phi(i)/fhaev                                      0225MH10
            enddo                                                       0225MH10
         endif                                                          0225MH10
c
c Get numerical gradient
c (the reason why we call mghook rather than mehook for numerical gradient is
c because these codes use
c different TINKER programs to get the MM energy, and sometimes these energies are 
c different (e.g. for liner water molecule, the HOH bending energy is
c zero when calculated with gradient.f, and is nonzero
c when calculated with energy.f). Before these issues are sorted out, we
c cannot use mehook.)
c
c
c     EE-MCSI calculation to get numerical dqdr
c
         do i=1,mcncar
c
            tmp=xt(i)
c
            xt(i)=tmp+dh
            call eeghok(xt,phi,v1,e1,e2,e12,dx)
            do j=1,mcnatm
               chgpls(j)=chgr(j)
            enddo
c
            xt(i)=tmp-dh
            call eeghok(xt,phi,v2,e1,e2,e12,dx)
            do j=1,mcnatm
               chgmns(j)=chgr(j)
            enddo
c
            xt(i)=tmp
            do j=1,mcnatm
               dqdrnum(i,j)=(chgpls(j)-chgmns(j))/(2.d0*dh)
            enddo
c
         enddo
c
c     Get analytical dqdr
c
         call eeghok(xt,phi,v,e1,e2,e12,dx)
c
c     Print the geometry of the point and the MCMM results 
c
         call mcprez(mcipts,xt,v,e1,e2,e12,dx,f)
c
         if(mciee.eq.1) call eeprez(phi,v)                              0225MH10
c
         write(6,1001)
         do i=1,mcnatm
            do j=1,mcncar
               write(6,2002) i,j,dqdrnum(j,i),dqdrr(j,i),
     &              dqdrnum(j,i)-dqdrr(j,i)
            enddo
         enddo
 1001    format(/19X,'Numerical',10X,'Analytical',13X,'Diff')
 2002    format(1x,2i4,3f20.10)
c
      enddo
c
c     Close the input file
c
      fstat = 'keep'
c
      call mcfclo (fu84, fstat)
c
 1000 format(1x,'Error: POINTS keyword should have an argument.')
 2000 format(1x,'Error: POINTS keyword should be on the first ',
     *          'line of the esp.fu84 input file.')
 3000 format(1x,'Error: FORMAT keyword should have an argument.')
 4000 format(1x,'Error: FORMAT keyword should be on the second ',
     *          'line of the esp.fu84 input file.')
 5000 format(1x,'Error: Too many geometries in fu84 input file.',
     *      /1x,'Increase mcmpts in mcparm.inc and recompile.')
 6000 format(1x,'Error: The format of the esp.fu84 input file ',
     *          'is not allowed.')
 7000 format(1x,'Error in the number of atoms in esp.fu84.')
 8000 format(1x,'Error in reading geometries in esp.fu84.')
c
c
      return
      end



